(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 (rnrs bytevectors)
  #:use-module (language python dict)
  #: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 (language python string)
  #:use-module (language python bytes)
  #:use-module (language python number)
  #:use-module (language python def)
  #:use-module ((language python with) #:select ())
  #:use-module (ice-9 pretty-print)
  #:export (comp))

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

(define-inlinable (C   x) `(@@ (language python compile) ,x))
(define-inlinable (N   x) `(@@ (language python number)  ,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 (E   x) `(@@ (language python exceptions) ,x))
(define-inlinable (L   x) `(@@ (language python list)    ,x))
(define-inlinable (A   x) `(@@ (language python array)   ,x))
(define-inlinable (S   x) `(@@ (language python string)  ,x))
(define-inlinable (B   x) `(@@ (language python bytes)   ,x))
(define-inlinable (Se  x) `(@@ (language python set)     ,x))
(define-inlinable (D   x) `(@@ (language python def)     ,x))
(define-inlinable (Di  x) `(@@ (language python dict)    ,x))
(define-inlinable (O   x) `(@@ (oop pf-objects)          ,x))
(define-inlinable (G   x) `(@  (guile)                   ,x))
(define-inlinable (H   x) `(@  (language python hash)    ,x))
(define-inlinable (W   x) `(@  (language python with)    ,x))

(define s/d 'set!)

(define (pre) (warn "Patching guile will lead to way better experience use 'python.patch' on guile-2.2"))

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

(define (dont-warn v)
  (catch #t
    (lambda ()
      (set! (@@ (system base message) %dont-warn-list)
	    (cons v
		  (@@ (system base message) %dont-warn-list))))
    (lambda x (values))))

(define *prefixes* (make-fluid '()))
(define (add-prefix id)
  (catch #t
     (lambda ()
       (if (fluid-ref (@@ (system base compile) %in-compile))
	   (fluid-set! *prefixes* (cons id (fluid-ref *prefixes*)))
	   (begin
	     (when (not (module-defined? (current-module) '__prefixes__))
		   (module-define! (current-module)
				   '__prefixes__ (make-fluid '())))
	     
	     (let ((p (module-ref (current-module) '__prefixes__)))
	       (fluid-set! p (cons id (fluid-ref p)))))))
     (lambda x (values))))

(define (is-prefix? id)
  (catch #t
    (lambda ()
      (if (fluid-ref (@@ (system base compile) %in-compile))
	  (member id (fluid-ref *prefixes*))
	  (if (not (module-defined? (current-module) '__prefixes__))
	      #f
	      (let ((p (module-ref (current-module) '__prefixes__)))
		(member id (fluid-ref p))))))
    (lambda x #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 (pp x)
  (pretty-print (syntax->datum x))
  x)

(define (gen-sel vs e item)
  (match e
    (#f item)
    ((#:cfor for-e in-e cont)
     `(,(F 'for) ((,@(map (g vs exp) for-e) : ,(exp vs in-e))) ()
       ,(gen-sel vs cont item)))
    ((#:cif cif cont)
     `(if ,(exp vs cif)          
          ,(gen-sel vs cont item)))))

(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-syntax-rule (mkfast ((a) v) ...)
  (let ((h (make-hash-table)))
    (hash-set! h 'a v)
    ...
    h))

(define (fast-ref x)
  (aif it (assoc x `((__class__ . ,(O 'py-class))))
       (cdr it)
       #f))

(define fasthash
  (mkfast
   ;; General
   ((__init__)    (O 'py-init))
   ((__getattr__) (O 'getattr))
   ((__setattr__) (O 'setattr))
   ((__delattr__) (O 'delattr))
   ((__ne__)      (O 'ne))
   ((__eq__)      (O 'equal?))
   ((__repr__)    (O 'repr))
   
   ;;iterators
   ((__iter__)      (F 'wrap-in))
   ((__next__)      (F 'next))
   ((__send__)      (Y 'send))
   ((__exception__) (Y 'sendException))
   ((__close__)     (Y 'sendClose))
   
   ;; Numerics
   ((__index__)    (N 'py-index))
   ((__add__ )     (N '+))
   ((__mul__ )     (N '*))
   ((__sub__ )     (N '-))
   ((__radd__ )    (N 'r+))
   ((__rmul__ )    (N 'r*))
   ((__rsub__ )    (N 'r-))
   ((__neg__ )     (N '-))
   ((__le__  )     (N '<))
   ((__lt__  )     (N '<=))
   ((__ge__  )     (N '>))
   ((__gt__  )     (N '>=))
   ((__abs__ )     (N 'py-abs))
   ((__pow__ )     (N 'expt))
   ((__rpow__ )    (N 'rexpt))
   ((__truediv__)  (N 'py-/))
   ((__rtruediv__) (N 'py-r/))
   ((__and__)      (N 'py-logand))   
   ((__or__)       (N 'py-logior))
   ((__xor__)      (N 'py-logxor))
   ((__rand__)     (N 'py-rlogand))   
   ((__ror__)      (N 'py-rlogior))
   ((__rxor__)     (N 'py-rlogxor))
   ((__divmod__)   (N 'py-divmod))
   ((__rdivmod__)  (N 'py-rdivmod))
   ((__invert__)   (N 'py-lognot))
   ((__int__)      (N 'mk-int))
   ((__float__)    (N 'mk-float))
   ((__lshift__)   (N 'py-lshift))
   ((__rshift__)   (N 'py-rshift))
   ((__rlshift__)  (N 'py-rlshift))
   ((__rrshift__)  (N 'py-rrshift))
   ((as_integer_ratio) (N 'py-as-integer-ratio))
   ((conjugate)    (N 'py-conjugate))
   ((denominator)  (N 'py-denominator))
   ((numerator)    (N 'py-numerator))
   ((fromhex)      (N 'py-fromhex))
   ((hex)          (N 'py-hex))
   ((imag)         (N 'py-imag))
   ((is_integer)   (N 'py-is-integer))
   ((real)         (N 'py-real))
   ((__mod__)      (N 'py-mod))
   ((__rmod__)     (N 'py-rmod))
   ((__floordiv__) (N 'py-floordiv))
   ((__rfloordiv__)(N 'py-rfloordiv))
   ((__hex__)      (N 'hex))
   
   ;; Lists
   ((append)       (L 'pylist-append!))
   ((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!))
   ((__len__)      (L 'len))
   ((__contains__) (L 'in))
   ((__delitem__)  (L 'pylist-delete!))
   ((__delslice__) (L 'pylist-delslice))
   ((__setitem__)  (L 'pylist-set!))
   
   ;; String
   ((format)     (S 'py-strformat))
   ((format_map) (S 'py-format-map))
   ((capitalize) (S 'py-capitalize))
   ((center)     (S 'py-center ))
   ((endswith)   (S 'py-endswith))
   ((expandtabs) (S 'py-expandtabs))
   ((find)       (S 'py-find   ))
   ((rfind)      (S 'py-rfind  ))
   ((isalnum)    (S 'py-isalnum))
   ((isalpha)    (S 'py-isalpha))
   ((isdigit)    (S 'py-isdigit))
   ((islower)    (S 'py-islower))
   ((isspace)    (S 'py-isspace))
   ((isupper)    (S 'py-isupper))
   ((istitle)    (S 'py-istitle))
   ((join)       (S 'py-join   ))
   ((ljust)      (S 'py-join   ))
   ((rljust)     (S 'py-rljust ))
   ((lower)      (S 'py-lower  ))
   ((upper)      (S 'py-upper  ))
   ((lstrip)     (S 'py-lstrip ))
   ((rstrip)     (S 'py-rstrip ))
   ((partition)  (S 'py-partition))
   ((replace)    (S 'py-replace))
   ((strip)      (S 'py-strip  ))
   ((title)      (S 'py-title  ))
   ((rpartition) (S 'py-rpartition))
   ((rindex)     (S 'py-rindex ))
   ((split)      (S 'py-split  ))
   ((rsplit)     (S 'py-rsplit ))
   ((splitlines) (S 'py-splitlines))
   ((startswith) (S 'py-startswith))
   ((swapcase)   (S 'py-swapcase))
   ((translate)  (S 'py-translate))
   ((zfill)      (S 'py-zfill))

   ;;DICTS
   ((copy)       (Di 'py-copy))
   ((fromkeys)   (Di 'py-fromkeys))
   ((get)        (Di 'py-get))
   ((has_key)    (Di 'py-has_key))
   ((items)      (Di 'py-items))
   ((iteritems)  (Di 'py-iteritems))
   ((iterkeys)   (Di 'py-iterkeys))
   ((itervalues) (Di 'py-itervalues))
   ((keys)       (Di 'py-keys))
   ((values)     (Di 'py-values))
   ((popitem)    (Di 'py-popitem))
   ((setdefault) (Di 'py-setdefault))
   ((update)     (Di 'py-update))
   ((clear)      (Di 'py-clear))
   ((__hash__)   (H  'py-hash))))
  

(define (fastfkn x) (hash-ref fasthash x))

(define (get-kwarg vs arg)
  (let lp ((arg arg) (l '()) (kw '()))
    (match arg
      (((#:= a b) . arg)
       (lp arg
           l
           (cons*
            (exp vs b)
            (symbol->keyword
             (exp vs a))
            kw)))
      ((x . arg)
       (lp arg (cons (exp vs x) l) kw))
      (()
       (values (reverse l) (reverse kw))))))

(define (get-kwarg-def vs arg)
  (let lp ((arg arg))
    (match arg
      ((((x . _) #f) . arg)
       (cons (exp vs x)
             (lp arg)))
      ((((a . _) b) . arg)      
       (cons (list '= (exp vs a) (exp vs b))
             (lp arg)))
      (()
       '()))))

(define (kw->li dict)
  (for ((k v : dict)) ((l '()))
    (cons* v (symbol->keyword (string->symbol k)) l)
    #:final
    (reverse l)))

(define (arglist->pkw . l)
  (let lp ((l l) (r '()))
    (if (pair? l)
        (let ((x (car l)))
          (if (keyword? x)
              (cons (reverse r) l)
              (lp (cdr l) (cons x r))))
        (cons (reverse l) '()))))

(define (get-addings vs x)
  (match x
    (() '())
    ((x . l)
     (let ((is-fkn? (match l
                      ((#f) #t)
                      (((#:arglist . _) . _)
                       #t)
                      (_
                       #f))))
       
       (cons
        (match x
          ((#:identifier . _)
           (let* ((tag     (exp vs x))
                  (xs      (gensym "xs"))
                  (fast    (fastfkn tag))
                  (is-fkn? (aif it (and is-fkn? fast)
                                `(#:call-obj (lambda (e)
                                               (lambda ,xs
                                                 (apply ,it e ,xs))))
                                #f)))
             (if is-fkn?
                 is-fkn?
                 (if fast
                     `(#:fastfkn-ref ,fast ',tag)
                     (aif it (fast-ref tag)
                          `(#:fast-id ,it ',tag)
                          `(#:identifier ',tag))))))
          
          ((#:arglist args apply kw)
           (call-with-values (lambda () (get-kwarg vs args))
             (lambda (args kwarg)
               (if (or kw apply)
                   `(#:apply ,@args ,@kwarg 
                             ,`(,(L 'to-list)
                                (,(G 'append)
                                 (if apply (exp vs apply) ''())
                                 (if kw
                                     '(,(C 'kw->li) (exp vs kw))
                                     ''()))))
                   `(#:call ,@args ,@kwarg)))))
          
          ((#:subscripts (n #f #f))
           `(#:vecref ,(exp vs n)))
        
          ((#:subscripts (n1 n2 n3))
           (let ((w (lambda (x) (if (eq? x None) (E 'None) x))))
             `(#:vecsub            
               ,(w (exp vs n1)) ,(w (exp vs n2)) ,(w (exp vs n3)))))
        
          ((#:subscripts (n #f #f) ...)
           `(#:array-ref ,@ (map (lambda (n)
                                   (exp vs n))
                                 n)))
        
          ((#:subscripts (n1 n2 n3) ...)
           (let ((w (lambda (x) (if (eq? x None) (E 'None) x))))
             `(#:arraysub
               ,@(map (lambda (x y z)
                        `(,(exp vs x) ,(exp vs y) ,(exp vs z)))
                      n1 n2 n3))))
        
          (_ (error "unhandled addings")))
        (get-addings vs l))))))
  
(define-syntax-rule (setwrap u)
  (call-with-values (lambda () u)
    (case-lambda
      ((x) x)
      (x x))))

(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 v addings . _) . _)
     (let* ((v       (exp vs v))
            (v.add   (if (is-prefix? v)
                         (let ((w (symbol->string (exp vs (car addings)))))
                           (cons (string-append (symbol->string v) "." w)
                                 (cdr addings)))
                         (cons v addings)))
            (v       (car v.add))
            (addings (cdr v.add))
            (addings (get-addings vs addings))
            (p.a     (match kind
                       (#f (cons #f '()))
                       ((v add)
                        (if (is-prefix? v)
                            (let ((w (symbol->string (exp vs (car add)))))
                              (cons (string-append (symbol->string v) "." w)
                                 (cdr add)))
                            (cons (exp vs v) add)))))
            (p      (car p.a))
            (pa     (cdr p.a))
            (pa     (get-addings vs pa)))
       (define q (lambda (x) `',x))
       (if kind
           (if (not p)
               (if (null? addings)                   
                   (if op
                       `(,s/d ,v (,(C 'setwrap) (,(tr-op op) ,v ,u)))
                       `(,s/d ,v (,(C 'setwrap) ,u)))
                   (if op
                       `(,s/d ,(exp vs kind)
                              (,(C 'fset-x) ,v ,addings
                               (,(C 'setwrap)
                                (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u))))
                     
                       `(,s/d ,(exp vs kind)
                              (,(C 'fset-x) ,v ,addings
                               (,(C 'setwrap) ,u)))))
               
               (let ((pre (if (equal? p v)
                              (let lp ((pa pa) (ad addings) (r '()))
                                (if (and (pair? pa) (pair? ad))
                                    (let ((px (car pa)) (ax (car ad)))
                                      (if (equal? px ax)
                                          (lp (cdr pa) (cdr ad) (cons px r))
                                          #f))
                                    (if (pair? pa)
                                        #f
                                        (reverse r))))
                              #f)))
                 (if (null? addings)                   
                     (if op
                         `(,s/d ,v (,(C 'setwrap) (,(tr-op op) ,v ,u)))
                         `(,s/d ,v (,(C 'setwrap) ,u)))
                     (if op
                         `(,(C 'set-x) ,v ,pre ,p ,pa ,addings
                           (,(C 'setwrap)
                            (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)))
                     
                         `(,(C 'set-x) ,v ,pre ,p ,pa ,addings
                           (,(C 'setwrap) ,u))))))
     
           (if (null? addings)
               (if op
                   `(,s/d ,v (,(C 'setwrap)
                              (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)))
                   `(,s/d ,v (,(C 'setwrap)
                              ,u)))
               `(,(C 'set-x)
                 ,v
                 ,addings
                 (,(C 'setwrap)
                  ,(if op
                       `(,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)
                       u)))))))))

(define (filter-defs x)
  (match (let lp ((x x))
           (match x
             ((('begin . l))
              (lp (cons 'begin l)))
             (('begin . l)
              (let lp ((l l))
                (match l
                  ((('values) . l)
                   (lp l))
                  ((x . l)
                   (cons x (lp l)))
                  (x x))))))
    (('begin)
     '())
    (x x)))
                  
(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 decorations (make-fluid '()))
(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* ((vf    (exp vs vf))
          (vf.tr (if (is-prefix? vf)
                     (cons
                      (string->symbol
                       (string-append
                        (symbol->string vf)
                        "."
                        (symbol->string (exp vs (car trailer)))))
                      (cdr trailer))
                     (cons vf trailer)))
          (vf      (car vf.tr))
          (trailer (cdr vf.tr)))
     (define (pw x)
       (if **
           `(expt ,x ,(exp vs **))
           x))
     (pw
      (let ((trailer (get-addings vs trailer)))
        `(,(C 'ref-x) ,vf ,@trailer))))))
 
 (#:identifier
  ((#:identifier x . _)
   (string->symbol x)))

 (#:decorated
  ((_ (l ...))
   (fluid-set! decorations (map (g vs exp) l))
   '(values)))
 
 (#:string
  ((_ l)
   (string-join l "")))

 (#:bytes
  ((_ l)
   (let* ((n (let lp ((l l) (s 0))
               (if (pair? l)
                   (lp (cdr l) (+ s (length (car l))))
                   s)))
          (b (make-bytevector n)))
     (let lp ((l l) (i 0))
       (if (pair? l)
           (let lp2 ((u (car l)) (i i))
             (if (pair? u)
                 (begin
                   (bytevector-u8-set! b i (car u))
                   (lp2 (cdr u) (+ i 1)))
                 (lp (cdr l) i)))))
     `(,(B 'bytes) ,b))))
           
     
 (#:+
  ((_ . l)
   (cons '+ (map (g vs exp) l))))
 
 (#:-
  ((_ . l)
   (cons '- (map (g vs exp) l))))
 
 (#:*
  ((_ . l)
   (cons '* (map (g vs exp) l))))
 
 (#:/
  ((_ . l)
   (cons (N 'py-/) (map (g vs exp) l))))

 (#:%
  ((_ . l)
   (cons (N 'py-mod) (map (g vs exp) l))))
 
 (#://
  ((_ . l)
   (cons (N 'py-floordiv) (map (g vs exp) l))))
 
 (#:<<
  ((_ . l)
   (cons (N 'py-lshift) (map (g vs exp) l))))
 
 (#:>>
  ((_ . l)
   (cons (N 'py-rshift) (map (g vs exp) l))))

 (#:u~
  ((_ x)
   (list (N 'py-lognot) (exp vs x))))

 (#:u-
  ((_ x)
   (list '- (exp vs x))))

 (#:u+
  ((_ x)
   (list '+ (exp vs x))))

 (#:band
  ((_ . l)
   (cons (N 'py-logand) (map (g vs exp) l))))
    
 (#:bxor
  ((_ . l)
   (cons (N 'py-logxor) (map (g vs exp) l))))
 
 (#:bor
  ((_ . l)
   (cons (N 'py-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))))

 (#:del
  ;;We don't delete variables
  ((_  (#:power #f base () . #f))
   '(void))
  
  ((_  (#:power #f base (l ... fin) . #f))
   (let ((add (get-addings vs l))
         (fin (get-addings vs (list fin)))
         (f   (exp vs base)))     
     `(,(C 'del-x) (,(C 'ref-x) ,f ,@add) ,@fin))))

 (#:with
  ((_ (l ...) code)
   (let ((l (map (lambda (x)
		   (match x
		     ((a b) (list (exp vs a) (exp vs b)))
		     ((b)   (list (exp vs b)))))
		 l)))
     `(,(W 'with) ,l ,(exp vs code)))))
   
 (#: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
   ((_ class parents defs)
    (with-fluids ((is-class? #t))
      (let ()
        (let* ((decor   (let ((r (fluid-ref decorations)))
                          (fluid-set! decorations '())
                          r))
               (class   (exp vs class))
               (parents (match parents
                          (() #f)
                          (#f #f)
                          ((#:arglist . _)
                           (get-addings vs (list parents))))))
          `(define ,class
             (,(C 'class-decor) ,decor
              (,(C 'with-class) ,class
               (,(C 'mk-p-class)
                ,class                
                ,(if parents
                     `(,(C 'ref-x) ,(C 'arglist->pkw) ,@parents)
                     `(,(G 'cons) '() '()))
                ,@(match (filter-defs (exp vs defs))
                    (('begin . l)
                     l)
                    ((('begin . l))
                     l)
                    (l l)))))))))))

 (#:scm
  ((_ (#:string _ s)) (with-input-from-string s read)))
 
 (#:import
  ((_ (#:from (() nm) . #f))
   `(use-modules (language python module ,(exp vs nm))))
  
  ((_ (#:name ((ids ...) . as) ...))
   `(begin
      ,@(map (lambda (ids as)
               (let* ((syms (map (g vs exp) ids))
                      (id   (if as (exp vs as) (car (reverse syms)))))
                 (add-prefix id)
                 `(use-modules ((language python module ,@syms)
                                #:prefix
                                ,(string->symbol
                                  (string-append (symbol->string id) "."))))))
             ids as))))
                             
                                   
  
 
 (#: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
       *e **e)
      #f
      code)
   (let* ((decor   (let ((r (fluid-ref decorations)))
                          (fluid-set! decorations '())
                          r))
          (args (get-kwarg-def vs args))
          (c?   (fluid-ref is-class?))
          (f    (exp vs f))
          (y?   (is-yield f #f code))
          (r    (gensym "return"))
          (*f   (match *e
                  (((e . #f) ()) (list (list '* (exp vs e))))
                  (#f '())))
          (dd2  (match *e
                  (((e . #f) ()) (list (exp vs e)))
                  (#f '())))
          (**f   (match **e
                   ((e . #f) (list (list '** (exp vs e))))
                   (#f '())))
          (dd3  (match **e
                  ((e . #f) (list (exp vs e)))
                  (#f '())))
          (as   (map (lambda (x) (match x
                                   (('= a _) a)
                                   (a        a)))
                     args))
          (ab  (gensym "ab"))
          (vs  (union dd3 (union dd2 (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-decor) ,decor
                   (,(C 'def-wrap) ,y? ,f ,ab
                    (,(D 'lam) (,@args ,@*f ,@**f)
                     (,(C 'with-return) ,r
                      ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
                              (,(C 'with-self) ,c? ,args
                               ,(with-fluids ((return r))
                                   (exp ns code))))))))))
               
               `(define ,f
                  (,(C 'def-decor) ,decor
                   (,(D 'lam) (,@args ,@*f ,@**f)
                    (,(C 'with-return) ,r
                     ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
                             (,(C 'with-self) ,c? ,args
                             ,(with-fluids ((return r))
                                (exp ns code))))))))))
            
           (if y?
               `(define ,f
                  (,(C 'def-decor) ,decor
                   (,(C 'def-wrap) ,y? ,f ,ab
                    (,(D 'lam) (,@args ,@*f ,@**f)
                     (,(C 'with-return) ,r 
                      (let ,(map (lambda (x) (list x #f)) ls)
                        (,(C 'with-self) ,c? ,args
                         ,(with-fluids ((return r))
                            (mk
                             (exp ns code))))))))))
               `(define ,f
                  (,(C 'def-decor) ,decor
                   (,(D 'lam) (,@args ,@*f ,@**f)
                    (,(C 'with-return) ,r 
                     (let ,(map (lambda (x) (list x #f)) ls)
                       (,(C 'with-self) ,c? ,args
                        ,(with-fluids ((return r))
                           (exp ns code))))))))))))))
 
 (#:global
  ((_ . _)
   '(values)))
 
 (#:list
  ((_ x (and e (#:cfor . _)))
   (let ((l (gensym "l")))
     `(let ((,l (,(L 'to-pylist) '())))
        ,(gen-sel vs e `(,(L 'pylist-append!) ,l ,(exp vs x)))
        ,l)))
  
  ((_ . l)
   (list (L 'to-pylist) (let lp ((l l))
                          (match l                             
                            ((or () #f) ''())                            
                            (((#:starexpr  #:power #f (#:list . l) . _) . _)
                             (lp l))
                            (((#:starexpr  #:power #f (#:tuple . l) . _) . _)
                             (lp l))
                            (((#:starexpr . l) . _)
                             `(,(L 'to-list) ,(exp vs l)))
                            ((x . l)
                             `(cons ,(exp vs x) ,(lp l))))))))
 (#:tuple
  ((_ x (and e (#:cfor . _)))
   (let ((l  (gensym "l")))
     `(let ((,l '()))
        ,(gen-sel vs e `(set! ,l (cons ,(exp vs x) ,l)))
        (reverse ,l))))

  ((_ . l)
   (let lp ((l l))
     (match l
       (() ''())
       (((#:starexpr  #:power #f (#:list . l) . _) . _)
        (lp l))
       (((#:starexpr  #:power #f (#:tuple . 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))
   (let ((l (map (g vs exp) l)))
     (if (= (length l) 1)
	 (car l)
	 `(,(G 'values) ,@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)
             `(begin
                ,(make-set vs op (car l) (exp vs (car u)))
                (values))
             `(begin
                @,(map (lambda (l u) (make-set vs op l u))
                       l
                       (map (g vs exp) u))
                (values))))
        
        ((and (= (length u) 1) (not op))         
         (let ((vars (map (lambda (x) (gensym "v")) l))
               (q    (gensym "q"))
               (f    (gensym "f")))
           `(begin
              (call-with-values (lambda () ,(exp vs (car u)))
                (letrec ((,f
                          (case-lambda
                            ((,q)
                             (if (pair? ,q)
                                 (apply ,f ,q)
                                 (apply ,f (,(L 'to-list) ,q))))
                            (,vars
                             ,@(map (lambda (l v) (make-set vs op l v))
                                    l vars)))))
                  ,f))
              (values))))
        
        ((and (= (length l) 1) (not op))
         `(begin
            ,(make-set vs op (car l) `(,(G 'list) ,@(map (g vs exp) u)))
            (values)))))))
  
  ((_
    ((#: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))))

 (#:dict
  ((_ . #f)
   `(,(Di 'make-py-hashtable)))

  ((_  (#:e k . v) (and e (#:cfor . _)))
   (let ((dict (gensym "dict")))
     `(let ((,dict (,(Di 'make-py-hashtable))))
        ,(gen-sel vs e `(,(L 'pylist-set!) ,dict ,(exp vs k) ,(exp vs v)))
        ,dict)))
  
  ((_  (#:e k . v) ...)
   (let ((dict (gensym "dict")))
     `(let ((,dict (,(Di 'make-py-hashtable))))
        ,@(map (lambda (k v)
                 `(,(L 'pylist-set!) ,dict ,(exp vs k) ,(exp vs v)))
               k v)
        ,dict)))

  ((_  k (and e (#:cfor . _)))
   (let ((dict (gensym "dict")))
     `(let ((,dict (,(Se 'set))))
        ,(gen-sel vs e `((,(O 'ref) ,dict 'add) ,(exp vs k)))
        ,dict)))
  
  ((_  k ...)
   (let ((set (gensym "dict")))
     `(let ((,set (,(Se 'set))))
        ,@(map (lambda (k)
                 `((,(O 'ref) ,set 'add) ,(exp vs k)))
               k)
        ,set))))
                  
                           
 (#: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 (G 'not) (list (O 'equal?) x y)))
       ("=="    (list (O 'equal?) x y))
       ("is"    (list (G 'eq?) x y))
       ("isnot" (list (G 'not) (list (G 'eq?)    x y)))
       ("in"    (list (L 'in) x y))
       ("notin" (list (G 'not) (list (L 'in)     x y)))
       ("<>"    (list (G 'not) (list (O '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)
    (#:None  (E 'None))
    (#:null  ''())
    (#:False #f)
    (#:pass  `(values))
    (#:break
     (C 'break))    
    (#:continue
     (C 'continue))
    (x x)))

(define-syntax-rule (define- n x) (define! 'n 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))
      (with-fluids ((*prefixes* '()))             
        (if (fluid-ref (@@ (system base compile) %in-compile))
            (set! s/d 'set!)
            (set! s/d (C '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))))
      (begin
        (if (fluid-ref (@@ (system base compile) %in-compile))
            (set! s/d 'set!)
            (set! s/d (C '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 (gentemp stx) (datum->syntax stx (gensym "x")))

(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 (gentemp #'in)))
         #'(let ((inv (wrap-in in)))
             (catch StopIteration
               (lambda ()
                 (let lp ()
                   (call-with-values (lambda () (next inv))
                     (lambda (x ...)
                       (with-sp ((break    (values))
                                 (continue (values)))
                                code
                                (lp))))))
               (lambda z (values))))))

      ((_ (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 (gentemp #'in)))          
          #'(let ((inv (wrap-in in)))
              (let lp ()
                (let/ec break-ret
                  (catch StopIteration
                    (lambda ()
                      (call-with-values (lambda () (next inv))
                        (lambda (x ...)
                          (let/ec continue-ret
                            (with-sp ((break     (break-ret))
                                      (continue  (continue-ret)))
                                     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 (gentemp #'in)))
         (with-syntax (((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 () (next inv))
                               (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 () (next inv))
                               (lambda (xx ...)
                                 (set! x xx) ...
                                 (with-sp ((break     (break-ret))
                                           (continue  (values)))
                                          code)
                                 (lp)))))
                         (lambda e else)))))))))
      
      ((_ (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
  (syntax-rules ()
    ((_ v)
     v)
    ((_ v (#:fastfkn-ref f _) . l)
     (ref-x (lambda x (if (py-class? v) (apply f x) (apply f v x))) . l))
    ((_ v (#:fast-id f _) . l)
     (ref-x (f v) . l))
    ((_ v (#:identifier x) . l)
     (ref-x (ref v x) . l))
    ((_ v (#:identifier x) . l)
     (ref-x (ref v x) . l))
    ((_ v (#:call-obj x) . l)
     (ref-x (x v) . l))
    ((_ v (#:call x ...) . l)
     (ref-x (v x ...) . l))
    ((_ v (#:apply x ...) . l)
     (ref-x (apply v x ...) . l))
    ((_ v (#:apply x ...) . l)
     (ref-x (apply v x ...) . l))
    ((_ v (#:vecref x) . l)
     (ref-x (pylist-ref v x) . l))
    ((_ v (#:vecsub . x) . l)
     (ref-x (pylist-slice v . x) . l))))

(define-syntax del-x
  (syntax-rules ()
    ((_ v (#:identifier x))
     (ref-x (ref v 'x)))
    ((_ v (#:call-obj x))
     (values))
    ((_ v (#:call x ...))
     (values))
    ((_ v (#:apply x ...))
     (values))
    ((_ v (#:vecref x))
     (pylist-delete! v x))
    ((_ v (#:vecsub x ...))
     (pylist-subset! v x ... pylist-null))))

(define-syntax set-x
  (syntax-rules ()
    ((_ v (a ... b) val)
     (set-x-2 (ref-x v a ...) b val))
    ((_ v #f p pa a val)
     (set-x p pa (fset-x v a val)))
    ((_ v pre p pa a val)
     (set-c v pre a val))
    ((_ v (a ... b) val)
     (set-x-2 (ref-x v a ...) b val))))

(define-syntax set-c
  (syntax-rules ()
    ((_ v (a) (b) val)
     (set v a val))
    ((_ v () as val)
     (tr v (fset-x v as val)))
    ((_ v ((#:identifier a) . as) (b . bs) val)
     (set-c (ref v a) as bs val))))
    
(define-syntax fset-x
  (syntax-rules ()
    ((_ v ((#:identifier x) ...) val)
     ((@ (oop pf-objects) fset-x) v (list x ...) val))))

(define-syntax set-x-2
  (syntax-rules ()
    ((_ v (#:fastfkn-ref f id) val)
     (set v id val))
    ((_ v (#:fastid-ref f id) val)
     (set v id val))
    ((_ v (#:identifier x) val)
     (set v x val)) 
    ((_ v (#:vecref n) val)
     (pylist-set! v n val))
    ((_ v (#:vecsub x ...) val)
     (pylist-subset! v x ... val))))


(define-syntax class-decor
  (syntax-rules ()
    ((_ () x) x)
    ((_ (f ... r) y)
     (class-decor (f ...) (r y)))))

(define-syntax def-decor
  (syntax-rules ()
    ((_ () x) x)
    ((_ (f ... r) y)
     (def-decor (f ...) (r y)))))
        
(define-syntax with-self
  (syntax-rules ()
    ((_ #f _       c)
     c)
    ((_ _  (s . b) c)
     (syntax-parameterize ((*self* (lambda (x) #'s))) c))))

(define-syntax with-class
  (syntax-rules ()
    ((_ s c)
     (syntax-parameterize ((*class* (lambda (x) #'s))) c))))