(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 (language python exceptions)
  #:use-module (language python yield)
  #:use-module (language python for)
  #:use-module (language python try)
  #:use-module (language python list)
  #:use-module (ice-9 pretty-print)
  #:export (comp))

(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))

(define s/d 'set!)

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

(define (dont-warn v)
  (set! (@@ (system base message) %dont-warn-list)
    (cons v
          (@@ (system base message) %dont-warn-list))))

(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-inlinable (C x) `(@@ (language python compile) ,x))
(define-inlinable (Y x) `(@@ (language python yield) ,x))
(define-inlinable (T x) `(@@ (language python try) ,x))
(define-inlinable (F x) `(@@ (language python for) ,x))
(define-inlinable (L x) `(@@ (language python list) ,x))
(define-inlinable (O x) `(@@ (oop pf-objects) ,x))
(define-inlinable (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 f . _)
     (union (list (exp '() f)) vs))

    ((#:lambdef . _)
     vs)
    
    ((#:classdef f . _)
     (union (list (exp '() f)) vs))

    ((#:global . _)
     vs)
    
    ((#:expr-stmt l (#:assign u))
     (union (fold (lambda (x s)
                   (match x
                     ((#:test (#:power v2 v1 () . _) . _)
                      (if v2
                          (union
                           (union (list (exp '() v1))
                                  (list (exp '() v2)))
                           s)
                          (union (list (exp '() v1)) s)))
                     (_ s)))
                  '()              
                  l)
            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 (gen-yield f)
  (string->symbol
   (string-append
    (symbol->string f)
    ".yield")))

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

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

(define-syntax-rule (<< x y) (ash x y))
(define-syntax-rule (>> x y) (ash x (- y)))

(define (fastfkn x)
  (case x
    ;; Lists
    ((append)  (L 'pylist-apbpend!))
    ((count)   (L 'pylist-count!))
    ((extend)  (L 'pylist-extend!))
    ((index)   (L 'pylist-index))
    ((pop)     (L 'pylist-pop!))
    ((insert)  (L 'pylist-insert!))
    ((remove)  (L 'pylist-remove!))
    ((reverse) (L 'pylist-reverse!))
    ((sort)    (L 'pylist-sort!))
    (else #f)))

(define (make-set vs op x u)
  (define (tr-op op)
    (match op
      ("+="  '+)
      ("-="  '-)
      ("*="  '*)
      ("/="  '/)
      ("%="  'modulo)
      ("&="  'logand)
      ("|="  'logior)
      ("^="  'logxor)
      ("**=" 'expt)
      ("<<=" (C '<<))
      (">>=" (C '>>))
      ("//="  'floor-quotient)))
  
  (match x
    ((#:test (#:power kind (#:identifier v . _) addings . _) . _)
     (let ((addings (map (lambda (x) (exp vs x)) addings)))
       (define q (lambda (x) `',x))
       (if kind
           (let ((v (string->symbol v)))
             (if (null? addings)                   
                 (if op
                     `(,s/d ,v (,(tr-op op) ,v ,u))
                     `(,s/d ,v ,u))
                 (if op
                     `(,s/d ,(exp vs kind)
                            (,(O 'fset-x) ,v (list ,@(map q addings))
                             (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)))
                     
                     `(,s/d ,(exp vs kind)
                            (,(O 'fset-x) ,v (list ,@(map q addings)) ,u)))))
           
           (let ((v (string->symbol v)))
             (if (null? addings)
                 (if op
                     `(,s/d ,v (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u))
                     `(,s/d ,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 'refq) ,v 'x) ',new))
                                    (() v)))
                     ',(exp vs las)
                     ,(if op
                          `(,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)
                          u))))))))))
  
(define is-class? (make-fluid #f))
(define (gen-yargs vs x)
  (match (pr 'yarg x)    ((#:list args)
     (map (g vs exp) args))))

(define inhibit-finally #f)

(define tagis (make-hash-table))
(define-syntax-rule (gen-table x vs (tag code ...) ...)
  (begin
    (hash-set! tagis tag
               (lambda (x vs)
                 (match x code ...)))
                   
    ...))

(gen-table x vs
 (#:power
  ((_ _ (x) () . #f)
   (exp vs x))
  
  ((_ _ x () . #f)
   (exp vs x))
  
  ((_ #f vf trailer . **)
   (let ()
     (define (pw x)
       (if **
           `(expt ,x ,(exp vs **))
           x))
     (pw
      (let lp ((e (exp vs vf)) (trailer trailer))
        (match trailer
          (()
           e)
          ((#f)          
           (list e))
          ((x . trailer)
           (let ((is-fkn? (match trailer
                            (((#:arglist . _) . _)
                             #t)
                            (_
                             #f))))
             (match (pr x)
               ((#:identifier . _)
                (let* ((tag     (exp vs x))
                       (xs      (gensym "xs"))
                       (is-fkn? (aif it (and is-fkn? (fastfkn tag))
                                     `(lambda ,xs (apply ,it ,e ,xs))
                                     #f)))
                  (lp (if is-fkn?
                          is-fkn?
                          `(,(O 'refq) ,e ',tag #f))
                      trailer)))
               
               ((#:arglist args apply  #f)
                (if apply
                    (lp `(apply ,e
                                ,@(map (g vs exp) args)
                                ,`(,(L 'to-list) ,(exp vs apply)))
                        trailer)
                    (lp `(,e ,@(map (g vs exp) args)) trailer)))
               
               (_ (error "unhandled trailer")))))))))))

 (#:identifier
  ((#:identifier x . _)
   (string->symbol x)))

 (#:string
  ((#:string #f x)
   x))

 (#:+
  ((_ . l)
   (cons '+ (map (g vs exp) l))))
 (#:-
  ((_ . l)
   (cons '- (map (g vs exp) l))))
 (#:*
  ((_ . l)
   (cons '* (map (g vs exp) l))))
 (#:/
  ((_ . l)
   (cons '/ (map (g vs exp) l))))

 (#:%
  ((_ . l)
   (cons 'modulo (map (g vs exp) l))))
 
 (#://
  ((_ . l)
   (cons 'floor-quotient (map (g vs exp) l))))

 (#:<<
  ((_ . l)
   (cons (C '<<) (map (g vs exp) l))))
 
 (#:>>
  ((_ . l)
   (cons (C '>>) (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))
    
  ((_ 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))))
    
 (#: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 kind) 
                           ,class
                           ,(map (lambda (x) `(,(O 'get-class) ,x)) parents)
                           #:const
                           ,(match (exp vs defs)
                              (('begin . l)
                               l)
                              ((('begin . l))
                               l)
                              (l l))
                           #:dynamic
                           ())))))))

  (#:import
   ((_ ((() nm) . #f))
    `(use-modules (language python module ,(exp vs nm)))))

  (#:for
   ((_ e in code . #f)
    (=> next)
    (match e
      (((#:power #f (#:identifier x . _) () . #f))
       (match in
         (((#:test power . _))
          (match power
            ((#:power #f
                      (#: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))))

   ((_ 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 . #f)
    (let ((lp (gensym "lp")))
      `(let ,lp ()
            (if ,(exp vs test)
                (begin
                  ,(exp vs code)
                  (,lp))))))

    ((_ test code else)
     (let ((lp (gensym "lp")))
       `(let ,lp ()
             (if test
                 (begin
                   ,(exp vs code)
                   (,lp))
                 ,(exp vs else))))))

  (#:try
   ((_ x (or #f ()) #f . fin)
    (if fin
        `(,(T 'try) ,(exp vs x) #:finally (lambda () fin))
        (exp vs x)))
    
    
   ((_ x exc else . fin)
    `(,(T 'try) ,(exp vs x)
      ,@(let lp ((exc exc) (r (if else (exp vs else) '())))
          (match exc
            ((((test . #f) code) . exc)
             (lp exc (cons `(#:except ,(exp vs code)) r)))
             
            ((((test . as) code) . exc)
             (let ((l (gensym "l")))
               (lp exc
                   (cons
                    `(#:except ,(exp vs test) => (lambda (,(exp vs as) . ,l)
                                                   ,(exp vs code)))
                    r))))
            (() 
             (reverse r))))
      ,@(if fin `(#:finally (lambda () ,(exp vs fin))) '()))))

  (#:subexpr
   ((_ . l)
    (exp vs l)))
   
  (#:raise
   ((_ #f   . #f)
    `(,(T 'raise) (,(O 'Exception))))
    
   ((_ code . #f)
    `(,(T 'raise) ,(exp vs code)))
   
   ((_ code . from)
    (let ((o (gensym "o"))
          (c (gensym "c")))              
      `(,(T 'raise)
        (let ((,c ,(exp vs code)))
          (let ((,o (if (,(O 'pyclass?) ,c)
                        (,c)
                        ,c)))
            (,(O 'set) ,o '__cause__ ,(exp vs from))
            ,o))))))
             
      
  (#:yield
   ((_ args)
    (let ((f (gensym "f")))
      `(begin
         (fluid-set! ,(Y 'in-yield) #t)
         (let ((,f (scm.yield ,@(gen-yargs vs args))))
           (,f)))))

    
   ((_ f args)
    (let ((f (gen-yield (exp vs f)))
          (g (gensym "f")))
      `(begin
         (set! ,(C 'inhibit-finally) #t)
         (let ((,g (,f ,@(gen-yargs vs args))))
           (,g))))))
    
  (#:def
   ((_ f
       (#:types-args-list
        args
        extra #f)
       #f
       code)
    (let* ((c?  (fluid-ref is-class?))
           (f   (exp vs f))
           (y?  (is-yield f #f code))
           (r   (gensym "return"))
           (dd  (match extra
                  (((e . #f) ()) (list (exp vs e)))
                  (#f '())))
           (dd2 (if (null? dd) dd (car dd)))
           (as  (map (lambda (x) (match x
                                   ((((#:identifier x . _) . #f) #f)
                                    (string->symbol x))))
                     args))
           (ab  (gensym "ab"))
           (vs  (union dd (union as vs)))
           (ns  (scope code vs))
           (df  (defs code '()))
           (ex  (gensym "ex"))
           (y   'scm.yield)
           (y.f (gen-yield f))
           (ls  (diff (diff ns vs) df)))
      
      (define (mk code)
        `(let-syntax ((,y   (syntax-rules ()
                              ((_ . args)
                               (abort-to-prompt ,ab . args))))
                      (,y.f (syntax-rules ()
                              ((_ . args)
                               (abort-to-prompt ,ab . args)))))
           ,code))
      
      (with-fluids ((is-class? #f))
        (if c?
            (if y?
                `(define ,f
                   (,(C 'def-wrap) ,y? ,f ,ab
                    (lambda (,@as ,@dd2)
                      (,(C 'with-return) ,r
                       ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
                               ,(with-fluids ((return r))
                                  (exp ns code))))))))
                
                `(define ,f (lambda (,@as ,@dd2)
                               (,(C 'with-return) ,r
                                ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
                                        ,(with-fluids ((return r))
                                           (exp ns code))))))))
            
            (if y?
                `(define ,f
                   (,(C 'def-wrap) ,y? ,f ,ab
                    (lambda (,@as ,@dd2)
                      (,(C 'with-return) ,r
                       (let ,(map (lambda (x) (list x #f)) ls)
                         ,(with-fluids ((return r))
                            (mk
                             (exp ns code))))))))
                `(define ,f
                   (lambda (,@as ,@dd2)
                     (,(C 'with-return) ,r
                      (let ,(map (lambda (x) (list x #f)) ls)
                        ,(with-fluids ((return r))
                           (exp ns code))))))))))))
  
  (#:global
   ((_ . _)
    '(values)))

  (#:list
   ((_ . l)
    (list (L 'to-pylist) (let lp ((l l))
                           (match l
                             (() ''())
                             (((#:starexpr  #:power #f (#:list . l) . _) . _)
                              (lp l))
                             (((#:starexpr . l) . _)
                              `(,(L 'to-list) ,(exp vs l)))
                             ((x . l)
                              `(cons ,(exp vs x) ,(lp l))))))))

  (#: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))
   
   ((_ l type)
    (=> fail)
    (call-with-values
        (lambda () (match type
                     ((#:assign u)
                      (values #f u))
                     ((#:augassign op u)
                      (values op u))
                     (_ (fail))))
      
      (lambda (op u)
        (cond
         ((= (length l) (length u))
          (if (= (length l) 1)
              (make-set vs op (car l) (exp vs (car u)))
              (cons 'begin
                    (map (lambda (l u) (make-set vs op l u))
                         l
                         (map (g vs exp) u)))))
         ((and (= (length u) 1) (not op))
          (let ((vars (map (lambda (x) (gensym "v")) l)))
            `(call-with-values (lambda () (exp vs (car u)))
               (lambda vars
                 ,@(map (lambda (l v) (make-set vs op l v))
                        l vars)))))))))
   
    ((_
      ((#:test (#:power #f (#:identifier v . _) () . #f) #f))
      (#:assign (l)))
     (let ((s (string->symbol v)))
       `(,s/d ,s ,(exp vs l)))))
            

  (#:return
   ((_ . x)
    `(,(fluid-ref return) ,@(map (g vs exp) x))))
    
                           
  (#:comp
   ((_ x #f)
    (exp vs x))

   ((_ 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)))))

(define (exp vs x)
  (match (pr x)
    ((e)
     (exp vs e))
    ((tag . l)
     ((hash-ref tagis tag (lambda y (warn "not tag in tagis") x)) x vs))

    (#:True  #t)
    (#:False #f)
    (#:pass  `(values))
    (#:break
     (C 'break))    
    (#:continue
     (C 'continue))
    (x x)))

(define (comp x)
  (define start
    (match (pr 'start x)
      (((#:stmt
         ((#:expr-stmt
           ((#:test
             (#:power #f
              (#: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)
            #:use-module (language python module python)))))
      (x '())))

  (if (fluid-ref (@@ (system base compile) %in-compile))
      (set! s/d 'set!)
      (set! s/d 'define))
  
  (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 (is-yield f p x)
  (match x
    ((#:def nm args _ code)
     (is-yield f #t code))
    ((#:yield x _)
     (eq? f (exp '() x))) 
    ((#:yield _)
     (not p))
    ((a . l)
     (or
      (is-yield f p a)
      (is-yield f p l)))
    (_
     #f)))



(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 var
  (lambda (x)
    (syntax-case x ()
      ((_ v)
       (begin
         (dont-warn (syntax->datum #'v))
         #'(if (module-defined? (current-module) '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)) ...)
             (catch StopIteration
               (lambda ()
                 (let lp ()
                   (call-with-values (lambda () (values (next inv) ...))
                     (lambda (x ...)
                       (with-sp ((break    (values))
                                 (continue (values)))
                          code
                          (lp))))))
               (lambda z (values))))))

      ((_ (x ...) (in ...) code #f #t)
       (with-syntax (((inv ...) (generate-temporaries #'(in ...))))          
          #'(let ((inv (wrap-in in)) ...)
              (let lp ()
                (let/ec break-ret
                  (catch StopIteration
                    (lambda ()
                      (call-with-values (lambda () (values (next inv) ...))
                        (lambda (x ...)
                          (let/ec continue-ret
                            (with-sp ((break     (break-ret))
                                      (continue  (continue-ret)))
                                     code))
                          (lp))))
                    (lambda z (values))))))))

      ((_  (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 ...))))
         (if (syntax->datum #'p)
             #'(let ((inv (wrap-in in)) ...)               
                 (let/ec break-ret
                   (let ((x #f) ...)
                     (catch StopIteration
                       (lambda ()
                         (let lp ()
                           (call-with-values (lambda () get)
                             (lambda (xx ...)
                               (set! x xx) ...
                               (let/ec continue-ret
                                 (with-sp ((break     (break-ret))
                                           (continue  (continue-ret)))
                                   code))
                               (lp)))))
                       (lambda q else)))))
             
             #'(let ((inv (wrap-in in)) ...)
                 (let ((x #f) ...)
                   (let/ec break-ret
                     (catch StopIteration
                       (lambda ()
                         (let lp ()
                           (call-with-values (lambda () get)
                             (lambda (xx ...)
                               (set! x xx) ...
                               (with-sp ((break     (break-ret))
                                         (continue  (values)))
                                        code)
                               (lp)))))
                       (lambda e else))))))))))))
    
(define-syntax def-wrap
  (lambda (x)
    (syntax-case x ()
      ((_ #f f ab x)
       (pr 'def-wrap #'f 'false)
       #'x)
      
      ((_ #t f ab code)
       (pr 'def-wrap #'f 'true)
       #'(lambda x
           (define obj (make <yield>))
           (define ab  (make-prompt-tag))
           (slot-set! obj 'k #f)
           (slot-set! obj 'closed #f)
           (slot-set! obj 's
                      (lambda ()
                        (call-with-prompt
                         ab
                         (lambda ()
                           (let/ec return                          
                             (apply code x))
                           (slot-set! obj 'closed #t)
                           (throw StopIteration))
                         (letrec ((lam
                                   (lambda (k . l)
                                     (fluid-set! in-yield #f)
                                     (slot-set! obj 'k
                                                (lambda (a)
                                                  (call-with-prompt
                                                   ab
                                                   (lambda ()
                                                     (k a))
                                                   lam)))
                                     (apply values l))))
                           lam))))
           obj)))))
                      
(define-syntax ref-x
  (lambda (x)
    (syntax-case x ()
      ((_ v)
       #'v)
      ((_ v x . l)
       #'(ref-x (refq v 'x) . l)))))