string loops

[software/python-on-guile.git] / modules / language / python / compile.scm

(define-module (language python compile)
  #:use-module (ice-9 match)
  #:use-module (ice-9 control)
  #:use-module (oop pf-objects)
  #:use-module (oop goops)
  #:use-module (ice-9 pretty-print)
  #:export (comp))

(define-syntax clear-warning-data
  (lambda (x)
    (pr 'clear)
    (set! (@@ (system base message) %dont-warn-list) '())
    #f))

(define-syntax dont-warn
  (lambda (x)
    (syntax-case x ()
      ((_ d)
       #t
       (begin
         (set! (@@ (system base message) %dont-warn-list)
           (cons (syntax->datum #'d)
                 (@@ (system base message) %dont-warn-list)))
         #f)))))

(define-syntax call
  (syntax-rules ()
    ((_ (f) . l) (f . l))))

(define (fold f init l)
  (if (pair? l)
      (fold f (f (car l) init) (cdr l))
      init))

(define (pr . x)
  (define port (open-file "/home/stis/src/python-on-guile/log.txt" "a"))
  (with-output-to-port port
    (lambda ()
      (pretty-print (syntax->datum x))))
  (close port)
  (car (reverse x)))

(define (pf x)
  (define port (open-file "/home/stis/src/python-on-guile/compile.log" "a"))
  (with-output-to-port port
    (lambda () (pretty-print (syntax->datum x)) x))
  (close port)
  x)

(define (C x) `(@@ (language python compile) ,x))
(define (O x) `(@@ (oop pf-objects) ,x))
(define (G x) `(@ (guile) ,x))

(define (union as vs)
  (let lp ((as as) (vs vs))
    (match as
      ((x . as)
       (if (member x vs)
           (lp as vs)
           (lp as (cons x vs))))
      (()
       vs))))

(define (diff as vs)
  (let lp ((as as) (rs '()))
    (match as
      ((x . as)
       (if (member x vs)
           (lp as rs)
           (lp as (cons x rs))))
      (()
       rs))))

(define (get-globals code)
  (let lp ((vs (glob code '())) (rs (scope code '())))
    (match vs
      ((x . l)
       (if (member x rs)
           (lp l rs)
           (lp l (cons x rs))))
      (()
       rs))))

(define (glob x vs)
  (match x
    ((#:global . l)
     (let lp ((l l) (vs vs))
       (match l
         (((#:identifier v . _) . l)
          (let ((s (string->symbol v)))            
            (if (member s vs)
                (lp l vs)
                (lp l (cons s vs)))))
         (()
          vs))))
    ((x . y)
     (glob y (glob x vs)))
    (x vs)))

(define (scope x vs)
  (match x
    ((#:def  (#:identifier f . _) . _)
     (union (list (string->symbol f)) vs))
    ((#:lambdef . _)
     vs)
    ((#:classdef . _)
     vs)
    ((#:global . _)
     vs)
    ((#:identifier v . _)
     (let ((s (string->symbol v)))
       (if (member s vs)
           vs
           (cons s vs))))
    ((x . y)
     (scope y (scope x vs)))
    (_ vs)))

(define (defs x vs)
  (match x
    ((#:def  (#:identifier f . _) . _)
     (union (list (string->symbol f)) vs))
    ((#:lambdef . _)
     vs)
    ((#:class . _)
     vs)
    ((#:global . _)
     vs)
    ((x . y)
     (defs y (defs x vs)))
    (_ vs)))

(define (g vs e)
  (lambda (x) (e vs x)))

(define return (make-fluid 'error-return))

(define (make-set vs x u)
  (match x
    ((#:test (#:power (#:identifier v . _) addings . _) . _)
     (let ((v (string->symbol v)))
       (if (null? addings)
           `(set! ,v ,u)
           (let* ((rev (reverse addings))
                  (las (car rev))
                  (new (reverse (cdr rev))))
             `(,(O 'set) ,(let lp ((v v) (new new))
                             (match new
                               ((x . new)
                                (lp `(,(O 'ref) ,v ,(exp vs x)) ',new))
                               (() v)))
               ',(exp vs las) ,u)))))))

(define is-class? (make-fluid #f))

(define (exp vs x)
  (match (pr x)
    
    ((#:power (x) () . #f)
     (exp vs x))
    ((#:power x () . #f)
     (exp vs x))
    
    
    ;; Function calls (x1:x1.y.f(1) + x2:x2.y.f(2)) will do functional calls
    ((#:power vf trailer . #f)
     (let lp ((e (exp vs vf)) (trailer trailer))
       (match trailer
         (()
          e)
         ((#f)          
          (list e))
         ((x . trailer)
          (match (pr x)
            ((#:identifier . _)
             (lp `(,(O 'ref) ,e ',(exp vs x) #f) trailer))
            ((#:arglist args #f #f)
             (lp `(,e ,@(map (g vs exp) args)) trailer))
            (_ (error "unhandled trailer")))))))
                                                    
    ((#:identifier x . _)
     (string->symbol x))

    ((#:string #f x)
     x)
    
    (((and x (or #:+ #:- #:* #:/)) . l)
     (cons (keyword->symbol x) (map (g vs exp) l)))

    ((#:u~ x)
     (list 'lognot (exp vs x)))

    ((#:band . l)
     (cons 'logand (map (g vs exp) l)))

    ((#:bxor . l)
     (cons 'logxor (map (g vs exp) l)))

    ((#:bor . l)
     (cons 'logior (map (g vs exp) l)))

    ((#:not x)
     (list 'not (exp vs x)))

    ((#:or . x)
     (cons 'or (map (g vs exp) x)))

    ((#:and . x)
     (cons 'and (map (g vs exp) x)))
    
    ((#:test e1 #f)
     (exp vs e1))
    
    ((#:test e1 e2 e3)
     (list 'if (exp vs e2) (exp vs e1) (exp vs e3)))

    ((#:if test a ((tests . as) ...) . else)
     `(,(G 'cond)
       (,(exp vs test) ,(exp vs a))
       ,@(map (lambda (p a) (list (exp vs p) (exp vs a))) tests as)
       ,@(if else `((else ,(exp vs else))) '())))
    
    ((#:suite . l) (cons 'begin (map (g vs exp) l)))

    ((#:try x #f #f fin)
     `(dynamic-wind
        (lambda () #f)
        (lambda () ,(exp vs x))
        (lambda () ,(exp vs fin))))

    ((#:while test code #f)
     (let ((lp (gensym "lp")))
       `(let ,lp ()
          (if test
              (begin
                ,(exp vs code)
                (,lp))))))

    ((#:classdef (#:identifier class . _) parents defs)
     (with-fluids ((is-class? #t))
       (let ()
         (define (filt l)
           (reverse
            (fold (lambda (x s)
                    (match x
                      (((or 'fast 'functional)) s)
                      (x (cons x s))))
                  '() l)))
         (define (is-functional l)
           (fold (lambda (x pred)
                   (if pred
                       pred
                       (match x
                         (('functional) #t)
                         (_ #f)))) #f l))
         (define (is-fast l)
           (fold (lambda (x pred)
                   (if pred
                       pred
                       (match x
                         (('fast) #t)
                         (_ #f)))) #f l))
         
         
         (let* ((class   (string->symbol class))
                (parents (match parents
                           (#f
                            '())
                           ((#:arglist args . _)
                            (map (g vs exp) args))))
                (is-func (is-functional parents))
                (is-fast (is-fast       parents))
                (kind    (if is-func
                             (if is-fast
                                 'mk-pf-class
                                 'mk-pyf-class)
                             (if is-fast
                                 'mk-p-class
                                 'mk-py-class)))              
                (parents (filt parents)))
           `(define ,class (,(O 'wrap)
                            (,(O kind)
                             ,class
                             ,(map (lambda (x) `(,(O 'get-class) ,x)) parents)
                             #:const
                             ,(match (exp vs defs)
                                (('begin . l)
                                 l)
                                ((('begin . l))
                               l)
                                (l l))
                             #:dynamic
                             ())))))))
                          
       
    (#:break
     (C 'break))
    
    (#:continue
     (C 'continue))
    
    ((#:for e in code . #f)
     (=> next)
     (match e
       (((#:power (#:identifier x . _) () . #f))
        (match in
          (((#:test power . _))
           (match power
             ((#:power
               (#:identifier "range" . _)
               ((#:arglist arglist . _))
               . _)
              (match arglist
                ((arg)
                 (let ((v   (gensym "v"))
                       (x   (string->symbol x))
                       (lp  (gensym "lp")))
                   `(let ((,v ,(exp vs arg)))
                      (let ,lp ((,x 0))
                           (if (< ,x ,v)
                               (begin
                                 ,(exp vs code)
                                 (,lp (+ ,x 1))))))))
                ((arg1 arg2)
                 (let ((v1   (gensym "va"))
                       (v2   (gensym "vb"))
                       (lp  (gensym "lp")))
                   `(let ((,v1 ,(exp vs arg1))
                          (,v2 ,(exp vs arg2)))
                      (let ,lp ((,x ,v1))
                           (if (< ,x ,v2)
                               (begin
                                 ,(exp vs code)
                                 (,lp (+ ,x 1))))))))
                ((arg1 arg2 arg3)
                 (let ((v1   (gensym "va"))
                       (v2   (gensym "vb"))
                       (st   (gensym "vs"))
                       (lp  (gensym "lp")))
                   `(let ((,v1 ,(exp vs arg1))
                          (,st ,(exp vs arg2))
                          (,v2 ,(exp vs arg3)))
                      (if (> st 0)
                          (let ,lp ((,x ,v1))
                               (if (< ,x ,v2)
                                   (begin
                                     ,(exp vs code)
                                     (,lp (+ ,x ,st)))))
                          (if (< st 0)
                              (let ,lp ((,x ,v1))
                                   (if (> ,x ,v2)
                                       (begin
                                         ,(exp vs code)
                                         (,lp (+ ,x ,st)))))
                              (error "range with step 0 not allowed"))))))
                (_ (next))))
             (_ (next))))
          (_ (next))))
       (_ (next))))

    ((#:for es in code . else)
     (let* ((es2   (map (g vs exp) es))
            (vs2   (union es2 vs))
            (code2 (exp vs2 code))
            (p     (is-ec #t code2 #t (list (C 'break) (C 'continue))))
            (else2 (if else (exp vs2 else) #f))
            (in2   (map (g vs exp) in)))
       (list (C 'for) es2 in2 code2 else2 p)))
           
    ((#:while test code else)
     (let ((lp (gensym "lp")))
       `(let ,lp ()
          (if test
              (begin
                ,(exp vs code)
                (,lp))
              ,(exp vs else)))))
    
    ((#:try x exc else fin)
     (define (f x)
       (match else
         ((#f x)
          `(catch #t
             (lambda () ,x)
             (lambda ,(gensym "x") ,(exp vs x))))))
    
     `(dynamic-wind
        (lambda () #f)
        (lambda ()
          ,(f
            (let lp ((code (exp vs x)) (l (reverse exc)))                    
              (match l
                ((((e) c) . l)
                 (lp `(catch ,(exp vs e)
                        (lambda () ,code)
                        (lambda ,(gensym "x")
                          ,(exp vs c))) l))
                ((((e . as) c) . l)
                 (lp `(let ((,as ,(exp vs e)))
                        (catch ,as
                          (lambda () ,code)
                          (lambda ,(gensym "x")
                            ,(exp vs c)))) l))
                (()
                 code))))
          (lambda () ,(exp vs fin)))))

    ((#:def (#:identifier f . _)
            (#:types-args-list
             args
             #f #f)
            #f
            code)
     (let* ((c? (fluid-ref is-class?))
            (f  (string->symbol f))
            (r  (gensym "return"))
            (as (map (lambda (x) (match x
                                  ((((#:identifier x . _) . #f) #f)
                                   (string->symbol x))))
                     args))
            (vs (union as vs))
            (ns (scope code vs))
            (df (defs code '()))
            (ex (gensym "ex"))
            (ls (diff (diff ns vs) df)))
       (with-fluids ((is-class? #f))
         (if c?
             `(define ,f (letrec ((,f
                                   (case-lambda
                                     ((,ex ,@as)
                                      (,f ,@as))
                                     ((,@as)
                                      (,(C 'with-return) ,r
                                       (let ,(map (lambda (x) (list x #f)) ls)
                                         ,(with-fluids ((return r))
                                            (exp ns code))))))))
                           ,f))

             `(define ,f (lambda (,@as)
                           (,(C 'with-return) ,r
                            (let ,(map (lambda (x) (list x #f)) ls)
                              ,(with-fluids ((return r))
                                 (exp ns code))))))))))
     
    ((#:global . _)
     '(values))
    
    ((#:lambdef v e)
     (list `lambda v (exp vs e)))

    ((#:stmt l)
     (if (> (length l) 1)
         (cons 'values (map (g vs exp) l))
         (exp vs (car l))))
     

    ((#:expr-stmt (l) (#:assign))
     (exp vs l))

    ((#:expr-stmt l (#:assign u))
     (cond
      ((= (length l) (length u))
       (if (= (length l) 1)
           (make-set vs (car l) (exp vs (car u)))
           (cons 'begin
                 (map make-set
                      (map (lambda x vs) l)
                      l
                      (map (g vs exp) u)))))
      ((= (length u) 1)
       (let ((vars (map (lambda (x) (gensym "v")) l)))
         `(call-with-values (lambda () (exp vs (car u)))
            (lambda vars
              ,@(map make-set l vars)))))))
                             
            

    ((#:return . x)
     `(,(fluid-ref return) ,@(map (g vs exp) x)))
    
    ((#:expr-stmt
      ((#:test (#:power (#:identifier v . _) () . #f) #f))
      (#:assign (l)))
     (let ((s (string->symbol v)))
       `(set! ,s ,(exp vs l))))
                           
    ((#:comp x #f)
     (exp vs x))

    ((#:comp x (op . y))
     (define (tr op x y)
       (match op
         ((or "<" ">" "<=" ">=")
          (list (G (string->symbol op)) x y))
         ("!="    (list 'not (list 'equal? x y)))
         ("=="    (list 'equal? x y))
         ("is"    (list 'eq? x y))
         ("isnot" (list 'not (list 'eq? x y)))
         ("in"    (list 'member x y))
         ("notin" (list 'not (list 'member x y)))
         ("<>"    (list 'not (list 'equal? x y)))))
     (tr op (exp vs x) (exp vs y)))
    
    (x x)))

(define (comp x)
  (define start
    (match (pr 'start x)
      (((#:stmt
         ((#:expr-stmt
           ((#:test
             (#:power
              (#:identifier "module" . _)
              ((#:arglist arglist #f #f))
              . #f) #f))
           (#:assign)))) . _)
       (let ()
         (define args
           (map (lambda (x)
                  (exp '() x))
                arglist))

         `((,(G 'define-module)
            (language python module ,@args)))))
      (x '())))
  
  (if (pair? start)
      (set! x (cdr x)))

  (let ((globs (get-globals x)))
    `(begin
       ,@start
       ,(C 'clear-warning-data)
       (set! (@@ (system base message) %dont-warn-list) '())
       ,@(map (lambda (s) `(,(C 'var) ,s)) globs)
       ,@(map (g globs exp) x))))

(define-syntax-parameter break
  (lambda (x) #'(values)))

(define-syntax-parameter continue
  (lambda (x) (error "continue must be bound")))

(define-syntax-rule (with-sp ((x v) ...) code ...)
  (syntax-parameterize ((x (lambda (y) #'v)) ...) code ...))

(define (is-ec ret x tail tags)
  (syntax-case (pr 'is-ec x) (begin let if define @@)
    ((begin a ... b)
     #t
     (or
      (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
      (is-ec ret #'b tail tags)))
    
    ((let lp ((y x) ...) a ... b)
     (symbol? (syntax->datum #'lp))
     (or
      (or-map (lambda (x) (is-ec ret x #f tags)) #'(x ...))
      (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
      (is-ec ret #'b tail tags)))
        
    ((let ((y x) ...) a ... b)
     #t
     (or
      (or-map (lambda (x) (is-ec ret x #f tags)) #'(x ...))
      (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
      (is-ec ret #'b tail tags)))
        
    ((if p a b)
     #t
     (or
      (is-ec ret #'p #f   tags)
      (is-ec ret #'a tail tags)
      (is-ec ret #'b tail tags)))
    
    ((define . _)
     #t
     #f)
    
    ((if p a)
     #t
     (or
      (is-ec ret #'p #f   tags)
      (is-ec ret #'a tail tags)))
    
    ((@@ _ _)
     #t
     (if (member (pr (syntax->datum x)) tags)
         #t
         #f))
    
    ((a ...)
     #t
     (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...)))
    
    (x
     #t
     #f)))

(define-syntax with-return
  (lambda (x)
    (define (analyze ret x)
      (syntax-case x (begin let if)
        ((begin a ... b)
         #`(begin a ... #,(analyze ret #'b)))
        ((let lp v a ... b)
         (symbol? (syntax->datum #'lp))
         #`(let lp v a ... #,(analyze ret #'b)))
        ((let v a ... b)
         #`(let v a ... #,(analyze ret #'b)))
        ((if p a b)
         #`(if p #,(analyze ret #'a) #,(analyze ret #'b)))
        ((if p a)
         #`(if p #,(analyze ret #'a)))
        ((return a b ...)
         (equal? (syntax->datum #'return) (syntax->datum ret))
         (if (eq? #'(b ...) '())
             #'a
             #`(values a b ...)))
        (x #'x)))
   
    (define (is-ec ret x tail)
      (syntax-case x (begin let if define @@)
        ((begin a ... b)
         #t
         (or
          (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
          (is-ec ret #'b tail)))
        
        ((let lp ((y x) ...) a ... b)
         (symbol? (syntax->datum #'lp))
         (or
          (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
          (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
          (is-ec ret #'b tail)))
        
        ((let ((y x) ...) a ... b)
         #t
         (or
          (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
          (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
          (is-ec ret #'b tail)))

        ((define . _)
         #t
         #f)

        ((if p a b)
         #t
         (or
          (is-ec ret #'p #f)
          (is-ec ret #'a tail)
          (is-ec ret #'b tail)))
        
        ((if p a)
         #t
         (or
          (is-ec ret #'p #f)
          (is-ec ret #'a tail)))

        ((return a b ...)
         (equal? (syntax->datum #'return) (syntax->datum ret))
         (not tail))
        
        ((a ...)
         #t
         (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)))

        (x
         #t
         #f)))

    (syntax-case x ()
      ((_ ret  l)
       (let ((code (analyze #'ret #'l)))
         (if (is-ec #'ret #'l #t)
             #`(let/ec ret #,code)
             code))))))

(define-syntax-rule (var v)
  (begin
    (dont-warn v)
    (if (defined? 'v)
        (values)
        (define! 'v #f))))

(define-inlinable (non? x) (eq? x #:nil))

(define-syntax for
  (syntax-rules ()
    ((_ (x) (a) code #f #f)
     (if (pair? a)
         (let lp ((l a))
           (if (pair? l)
               (let ((x (car l)))
                 (with-sp ((continue (lp (cdr l)))
                           (break    (values)))                          
                          code
                          (lp (cdr l))))))
         (for/adv1 (x) (a) code #f #f)))

    ((_ (x) (a) code #f #t)
     (if (pair? a)
         (let/ec break-ret
           (let lp ((l a))
             (if (pair? l)
                 (begin
                   (let/ec continue-ret
                     (let ((x (car l)))
                       (with-sp ((continue (continue-ret))
                                 (break    (break-ret)))                     
                         code)))
                   (lp (cdr l))))))
         (for/adv1 (x) (a) code #f #t)))

    ((_ (x) (a) code next #f)
     (if (pair? a)
         (let/ec break-ret
           (let ((x (let lp ((l a) (old #f))
                      (if (pair? l)                          
                          (let ((x (car l)))
                            (let/ec continue-ret
                              (with-sp ((continue (continue-ret))
                                        (break    (break-ret)))
                                code))
                            (lp (cdr l)))
                          old))))
             next))
         (for/adv1 (x) (a) code next #f)))
    
    ((_ x a code next p)
     (for/adv1 x a code next p))))

(define-syntax for/adv1
  (lambda (x)
    (syntax-case x ()
      ((_ (x ...) (in ...) code #f #f)
       (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
         #'(let ((inv (wrap-in in)) ...)
             (let lp ()
               (call-with-values (lambda () (values (next inv) ...))
                 (lambda (x ...)
                   (if (or (non? x) ...)
                       (values)
                       (begin
                         code
                         (lp)))))))))

      ((_ (x ...) (in ...) code #f #t)
       (with-syntax (((inv ...) (generate-temporaries #'(in ...))))          
          #'(let ((inv (wrap-in in)) ...)
              (let lp ()
                (let/ec break-ret
                  (call-with-values (lambda () (values (next inv) ...))
                    (lambda (x ...)
                      (if (or (non? x) ...)
                          (values)
                          (begin
                            (let/ec continue-ret
                              (with-sp ((break     (break-ret))
                                        (continue  (continue-ret)))
                                       code))
                            (lp))))))))))

      ((_  (x ...) in code else #f)
       #'(for-adv (x ...) in code else #f))

      ((_ (x ...) in code else #t)
       #'(for-adv (x ...) in code else #t)))))


(define-syntax for-adv
  (lambda (x)
    (define (gen x y)
      (if (= (length (syntax->datum x)) (= (length (syntax->datum y))))
          (syntax-case x ()
            ((x ...) #'(values (next x) ...)))
          (syntax-case x ()
            ((x)  #'(next x)))))
    
    (syntax-case x ()
      ((_ (x ...) (in ...) code else p)
       (with-syntax (((inv ...) (generate-temporaries #'(in ...))))          
       (with-syntax ((get      (gen #'(inv ...) #'(x ...)))
                     ((xx ...) (generate-temporaries #'(x ...))))
         #'(let ((inv (wrap-in in)) ...)
             (if p
                 (let/ec break-ret
                   (call-with-values
                       (lambda ()
                         (let lp ((xx #f) ...)
                           (call-with-values (lambda () get)
                             (lambda (x ...)
                               (let/ec continue-ret
                                 (if (or (non? x) ...)
                                     (values xx ...)
                                     (with-sp ((break     (break-ret))
                                               (continue  (continue-ret)))
                                              code)))
                               (lp x ...))))))
                   (lambda (x ...) else))

                 (let/ec break-ret
                   (call-with-values
                       (lambda ()
                         (let lp ((xx #f) ...)
                           (call-with-values (lambda () get)
                             (lambda (x ...)
                               (if (or (non? x) ...)
                                   (values xx ...)
                                   (begin
                                     (with-sp ((break     (break-ret))
                                               (continue  (values)))
                                       code)
                                     (lp x ...)))))))
                     (lambda (x ...) else)))))))))))
    

(define-class <scm-list>   () (x) l)
(define-class <scm-string> () (x) s i)

(define-method (next (l <scm-list>))
  (let ((ll (slot-ref l 'l)))
    (if (pair? ll)
        (begin
          (slot-set! l 'l (cdr ll))
          (car ll))
        #:nil)))

(define-method (next (l <scm-string>))
  (let ((s (slot-ref l 's))
        (i (slot-ref l 'i)))
    (if (= i (string-length s))
        #:nil
        (begin
          (slot-set! l 'i (+ i 1))
          (string-ref s i)))))

(define (wrap-in x)
  (cond
   ((pair? x)
    (let ((o (make <scm-list>)))
      (slot-set! o 'l x)
      o))
   
   ((string? x)
    (let ((o (make <scm-string>)))
      (slot-set! o 's x)
      (slot-set! o 'i 0)
      o))
   
    (else
     x)))