(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 module)
  #:use-module (language python dir)
  #:use-module (language python procedure)
  #:use-module (language python bool)
  #: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 (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-syntax-rule (use a ...)
  (catch #t
    (lambda () (use-modules a ...))
    (lambda x
      (warn "failed to load " x)
      (raise (ImportError '(a ...))))))

(define s/d 'set!)

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

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

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

(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)
     (let lp ((for-e for-e))
       (match for-e
         (((#:power #f (#:tuple . l) . _))
          (lp l))
         (_
          `(,(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)

    ((#:with (l ...) code)
     (scope code (union vs
                  (let lp ((l l))
                    (match l
                     (((a b) . l)
                      (cons (exp '() b) (lp l)))
                     ((x . l) (lp l))
                     (() '()))))))
    
    ((#:classdef f . _)
     (union (list (exp '() f)) vs))

    ((#:global . _)
     vs)
                
    ((#:import (#:name ((ids ...) . as)) ...)
     (let lp ((ids ids) (as as) (vs vs))
       (if (pair? as)
	   (lp (cdr ids) (cdr as)
	       (let ((as  (car as))
		     (ids (car ids)))
		 (union vs (list (exp '() (if as as (car ids)))))))
	   vs)))

    ((#:expr-stmt l (#:assign u ... v))
     (union
      (fold (lambda (l s)
              (union
               s
               (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)))              
            '()
            (cons l u))
      vs))

    ((#:for es in code . final)
     (let ((vs (let lp ((es es))
                 (match es
                   (((#:power #f (#:tuple . l) . _))
                    (lp l))
                   (_ (union vs (map (g vs exp) es)))))))
       (scope final (scope code vs))))

     
    ((#:expr-stmt l (#:assign k . u))
     (union
      (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)
      (scope `(#:expr-stmt ,k (#:asignvs . ,u)) 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)
    ((#:import (#:name ((ids ...) . as)) ...)
     (let lp ((ids ids) (as as) (vs vs))
       (if (pair? as)
	   (lp (cdr ids) (cdr as)
	       (let ((as  (car as))
		     (ids (car ids)))
		 (union vs (list (exp '() (if as as (car ids)))))))
	   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 'ref))
   ((__setattr__) (O 'set))
   ((__delattr__) (O 'del))
   ((__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))
   ((isidentifier) (S 'py-identifier))
   ((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))
    (match arg
      (((#:comp . (and x (_ (#:cfor . _) . _))) . arg2)
       (cons `(* ,(exp vs `(#:tuple ,@x))) (lp arg2)))
      (((#:* a) . arg)
       (cons `(* ,(exp vs a)) (lp arg)))
      (((#:** a) . arg)
       (cons `(** ,(exp vs a)) (lp arg)))
      (((#:= a b) . arg)
       (cons `(= ,(exp vs a) ,(exp vs b)) (lp arg)))
      ((x . arg)
       (cons (exp vs x) (lp arg)))
      (()
       '()))))

(define (getarg x)
  (match x
    ((#:tp x . l)
     x)
    (x x)))

(define (get-args_ vs arg)  
  (let lp ((arg arg))
    (match arg
      (((#:arg x) . arg)
       (cons (exp vs (getarg x))
             (lp arg)))
      ((x . args)
       (lp args))
      
      (()
       '()))))

(define (get-args= vs arg)
  (let lp ((arg arg))
    (match arg
      (((#:= x v) . arg)
       (cons (list '= (exp vs (getarg x)) (exp vs v))
             (lp arg)))
      
      ((x . args)
       (lp args))
      
      (()
       '()))))

(define (get-args* vs arg)
  (let lp ((arg arg))
    (match arg
      (((#:* x) . arg)
       (cons (list '* (exp vs (getarg x)))
             (lp arg)))

      ((x . args)
       (lp args))
      
      (()
       '()))))

(define (get-args** vs arg)
  (let lp ((arg arg))
    (match arg
      (((#:** x) . arg)
       (cons (list '** (exp vs (getarg x)))
             (lp arg)))

      ((x . args)
       (lp args))
      
      (()
       '()))))

(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)
               (list (G 'cons) `(,(G 'list) ,@(reverse r)) `(,(G 'list) ,@l))
               (lp (cdr l) (cons x r))))
        (list (G 'cons)  `(,(G 'list) ,@(reverse r)) ''()))))

(define (get-addings vs x fast?)
  (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 fast? is-fkn? fast)
                                `(#:call-obj (lambda (e)
                                               (lambda ,xs
                                                 (apply ,it e ,xs))))
                                #f)))
             (if is-fkn?
                 is-fkn?
                 (if (and fast? fast)
                     `(#:fastfkn-ref ,fast ',tag)
                     (aif it (and fast? (fast-ref tag))
                          `(#:fast-id ,it ',tag)
                          `(#:identifier ',tag))))))
          
          ((#:arglist args)
           `(#:apply ,@(get-kwarg vs args)))
          
          ((#: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 fast?))))))
  
(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
    ((#:verb x) x)
    ((#:test (#:power kind v addings . _) . _)
     (let* ((v       (exp vs v))
            (fast?   (not (eq? v 'super)))
            (addings (get-addings vs addings fast?))
            (p.a     (match kind
                       (#f (cons #f '()))
                       ((v add)
                        (cons (exp vs v) add))))
            (p      (car p.a))
            (pa     (cdr p.a))
            (pa     (get-addings vs pa fast?)))
       (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 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 ...)))
                   
    ...))

(define (tr-comp 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)))))

(gen-table x vs
 (#:power
  ((_ _ (x) () . #f)
   (exp vs x))
  
  ((_ _ x () . #f)
   (exp vs x))
  
  ((_ #f vf trailer . **)
   (let* ((vf      (exp vs vf))
          (fast?   (not (eq? vf 'super))))
     (define (pw x)
       (if **
           `(expt ,x ,(exp vs **))
           x))
     (pw
      (let ((trailer (get-addings vs trailer fast?)))
        `(,(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* ((b (make-bytevector (length l))))
     (let lp ((l l) (i 0))
       (if (pair? l)
           (begin
             (bytevector-u8-set! b i (car l))
             (lp (cdr l) (+ i 1)))
           `(,(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 (list (C 'boolit) (exp vs x)))))
 
 (#:or
  ((_ . x)
   (cons 'or (map (lambda (x) (list (C 'boolit) (exp vs x))) x))))
    
 (#:and
  ((_ . x)
   (cons 'and (map (lambda (x) (list (C 'boolit) (exp vs x))) x))))
    
 (#:test
  ((_ e1 #f)
   (exp vs e1))

  ((_ e1 (e2 #f))
   (list 'if (list (C 'boolit) (exp vs e2)) (exp vs e1) (C 'None)))

  ((_ e1 (e2 e3))
   (list 'if (list (C 'boolit) (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* ((f     (exp vs base))
          (fast? (not (eq? f 'super)))
          (add   (get-addings vs l fast?))
          (fin   (get-addings vs (list fin) fast?)))
         
     `(,(C 'del-x) (,(C 'ref-x) ,f ,@add) ,@fin))))

 (#:with
  ((_ (l ...) code)
   (let* ((l (map (lambda (x)
                    (match x
                      ((a b) (list (exp vs b) (gensym "as") (exp vs a)))
                      ((b)   (list (exp vs b)))))
                  l))
          (vs (union vs (let lp ((l l))
                          (match l
                            (((x) . l) (lp l))
                            (((a b c) . l) (cons a (lp l)))
                            (() '()))))))

     (define (f x)
       (match x
         ((a b c) (list 'set! a b))
         ((a) (list (G 'values)))))
     
     (define (g x)
       (match x
         ((a b c) (list b c))
         ((a)     (list a))))
     
     `(,(W 'with) ,(map g l)
       (,(G 'begin)
        ,@(map f l)
        ,(exp vs code))))))
   
 (#:if
  ((_ test a ((tests . as) ...) . else)
   `(,(G 'cond)
     (,(list (C 'boolit) (exp vs test)) ,(exp vs a))
     ,@(map (lambda (p a) (list (list (C 'boolit) (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 code)
    (with-fluids ((is-class? #t))
      (let ()
        (define (clean l)
          (match l
            (((#:apply   . l). u) (append (clean l) (clean u)))
            (((`= x v ) . l) (cons* (symbol->keyword x) v (clean l)))
            ((x         . l) (cons x (clean l)))
            (() '())))
        (let* ((decor   (let ((r (fluid-ref decorations)))
                          (fluid-set! decorations '())
                          r))               
               (class   (exp vs class))
               (vs  (union (list class) vs))
               (ns  (scope code vs))
               (ls  (diff ns vs))

               (parents (match parents
                          (() #f)
                          (#f #f)
                          ((#:arglist . _)
                           (get-addings vs (list parents) #f)))))
          `(set! ,class
             (,(C 'class-decor) ,decor
              (,(C 'with-class) ,class
               (,(C 'mk-p-class2)
                ,class                
                ,(if parents
                     (arglist->pkw (clean parents))
                     `(,(G 'cons) '() '()))
                ,(map (lambda (x) `(define ,x #f)) ls)
                ,(exp vs code))))))))))
 (#:verb
  ((_ x) x))
 
 (#:scm
  ((_ (#:string _ s)) (with-input-from-string s read)))
 
 (#:import
  ((_ (#:from (() . nm) . #f))
   `(,(C 'use) (language python module ,@(map (lambda (nm) (exp vs nm))
						nm))))
  ((_ (#:from (() . nm)  l))
   `(,(C 'use)  ((language python module ,@(map (lambda (nm) (exp vs nm))
						 nm))
                 #:select ,(map (lambda (x)
                                  (match x
                                    ((a . #f)
                                     (let ((s (exp vs a)))
                                       s))
                                     
                                    ((a . b)
                                     (let ((s (exp vs a)))
                                       (cons s (exp vs b))))))
                                l))))
					      
  
  ((_ (#:name ((ids ...) . as)) ...)
   `(begin
      ,@(map
	 (lambda (ids as)	     
	   (let ((path (map (g vs exp) ids)))
	     (if as
		 (exp
		  vs
		  `(#:expr-stmt
		    ((#:test (#:power #f ,as ())))
		    (#:assign 
		     ((#:verb
		       ((@ (language python module) import)
			((@ (language python module) Module)
			 ',(reverse (append '(language python module) path))
			 ',(reverse path))
			,(exp vs as)))))))
		 (exp
		  vs
		  `(#:expr-stmt
		    ((#:test (#:power #f ,(car ids) ())))
		    (#:assign
		     ((#:verb
		       ((@ (language python module) import)
			((@ (language python module) Module)
			 ',(append '(language python module) path))
			,(exp vs (car ids)))))))))))
	 ids as))))
	       
 (#:for
  ((_ e in code . #f)
   (=> next)
   (let lp ((e e))
     (match e
       (((#:power #f (#:tuple . l) . _))
        (lp l))
       
       (((#: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 lp ((es es))
     (match es
       (((#:power #f (#:tuple . l) . _))
        (lp l))
       (_            
        (let* ((es2   (map (g vs exp) es))
               (vs2   (union es2 vs))
               (code2 (exp vs2 code))
               (p     (is-ec #t code2 #t (list (C 'continue))))
               (else2 (if else (exp vs2 else) #f))
               (in2   (map (g vs exp) in)))
          (list (C 'cfor) 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) (lambda () ,(exp vs x)) #:finally (lambda () fin))
       `(,(T 'try) (lambda () ,(exp vs x)))))
    
  ((_ x exc else . fin)
   `(,(T 'try) (lambda () ,(exp vs x))
     ,@(let lp ((exc exc) (r '()))
         (match exc
           ((((test . #f) code) . exc)
            (lp exc (cons `(#:except ,(exp vs test) ,(exp vs code)) r)))

	   (((#f code) . exc)
            (lp exc (cons `(#:except #t ,(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 else `((#:except #t ,(exp vs else))) '())
     ,@(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)
      #f
      code)
   (let* ((decor   (let ((r (fluid-ref decorations)))
                          (fluid-set! decorations '())
                          r))
          (arg_ (get-args_ vs args))
	  (arg= (get-args= vs args))
	  (dd=  (map cadr arg=))
          (c?   (fluid-ref is-class?))
          (f    (exp vs f))
          (y?   (is-yield f #f code))
          (r    (gensym "return"))
          (*f   (get-args* vs args))
	  (dd*  (map cadr *f))
          (**f  (get-args** vs args))
	  (dd** (map cadr **f))
          (aa  `(,@arg_ ,@*f ,@arg= ,@**f))
          (ab  (gensym "ab"))
          (vs  (union dd** (union dd* (union dd= (union arg_ 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?
               `(set! ,f
                  (,(C 'def-decor) ,decor
                   (,(C 'def-wrap) ,y? ,f ,ab
                    (,(D 'lam) ,aa
                     (,(C 'with-return) ,r
                      ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
                              (,(C 'with-self) ,c? ,aa
                               ,(with-fluids ((return r))
                                   (exp ns code))))))))))
               
               `(set! ,f
                  (,(C 'def-decor) ,decor
                   (,(D 'lam) ,aa
                    (,(C 'with-return) ,r
                     ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
                             (,(C 'with-self) ,c? ,aa
                              ,(with-fluids ((return r))
                                (exp ns code))))))))))
            
           (if y?
               `(set! ,f
                  (,(C 'def-decor) ,decor
                   (,(C 'def-wrap) ,y? ,f ,ab
                    (,(D 'lam) ,aa
                     (,(C 'with-return) ,r 
                      (let ,(map (lambda (x) (list x #f)) ls)
                        (,(C 'with-self) ,c? ,aa
                         ,(with-fluids ((return r))
                            (mk
                             (exp ns code))))))))))
               `(set! ,f
                  (,(C 'def-decor) ,decor
                   (,(D 'lam) ,aa
                    (,(C 'with-return) ,r 
                     (let ,(map (lambda (x) (list x #f)) ls)
                       (,(C 'with-self) ,c? ,aa
                        ,(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
  ((_ (#:var-args-list . v) e)
   (let ((as (get-args_  vs v))
         (a= (get-args=  vs v))
         (a* (get-args*  vs v))
         (** (get-args** vs v)))         
     (list (C `lam) `(,@as ,@a* ,@a= ,@**) (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))))

  ((_ a (#:assign b c . u))
   (let ((z (gensym "x")))
     `(let ((,z ,(exp vs `(#:expr-stmt1 ,b (#:assign ,c . ,u)))))
        ,(exp vs `(#:expr-stmt ,a (#:assign ((#:verb ,z))))))))
  
  ((_ 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)))))

 (#:assert
  ((_ x f n m)
   `(if (,(G 'not) (,(G 'and) ,@(map (lambda (x) `(,(C 'boolit) ,(exp vs x)))
                                     x)))
        (,(C 'raise) ,(C 'AssertionError) ',f ,n ,m))))


  
 (#:expr-stmt1
  ((_ a (#:assign b c . u))
   (let ((z (gensym "x")))
     `(let ((,z ,(exp vs `(#:expr-stmt1 ,b
                                        (#:assign ,c . ,u)))))
        ,(exp vs `(#:expr-stmt1 ,a (#:assign ((#:verb ,z))))))))
  
  ((_ 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)))
                ,(exp vs (car l)))
             `(begin
                ,@(map (lambda (l u) (make-set vs op l u))
                       l
                       (map (g vs exp) u))
                (values ,@(map (g exp vs) l)))))
        
        ((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 ,@(map (g exp vs) l)))))
        
        ((and (= (length l) 1) (not op))
         `(begin
            ,(make-set vs op (car l) `(,(G 'list) ,@(map (g vs exp) u)))
            (values ,(exp vs (car l))))))))))
  
 (#:return
  ((_  x)
   (if x
       `(,(fluid-ref return) ,@(map (g vs exp) x))
       `(,(fluid-ref return)))))
       

 (#: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))
   (tr-comp op (exp vs x) (exp vs y)))

  ((_ x (op . y) . l)
   (let ((m (gensym "op")))
     `(let ((,m ,(exp vs y)))
        (and ,(tr-comp op (exp vs x) m)
             ,(exp vs `(#:comp (#:verb ,m) . ,l))))))))


(define (exp vs x)
  (match (pr x)
    ((e)
     (exp vs e))
    ((tag . l)
     ((hash-ref tagis tag
		(lambda y (warn (format #f "not tag in tagis ~a" tag)) 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 x
      (((#:stmt
         ((#:expr-stmt
           ((#:test
             (#:power #f
              (#:identifier "module" . _)
              ((#:arglist arglist))
              . #f) #f))
           (#:assign)))) . rest)

       (let ()
         (define args
           (map (lambda (x)
                  (exp '() x))
                arglist))

         `((,(G 'define-module) (language python module ,@args)
            #:use-module (language python module python)
            #:use-module (language python exceptions))
           (define __doc__    #f)
           (define __module__ '(language python module ,@args)))))
      (x '())))
  
  (if (fluid-ref (@@ (system base compile) %in-compile))
      (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)
             (fluid-set! (@@ (system base message) %dont-warn-list) '())
             ,@(map (lambda (s) `(,(C 'var) ,s)) globs)
             ,@(map (g globs exp) x)
             (,(C 'export-all)))))
      (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)
             (fluid-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 set! @@)
    ((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)

    ((set! . _)
     #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 clambda
  (lambda (x)
    (syntax-case x ()
      ((_ (x ...) code ...)
       (with-syntax ((n (length #'(x ...))))
         #'(let ((f (lambda (x ... . u) code ...)))
             (if (> n 1)                
                 (case-lambda
                   ((c)
                    (if (pair? c)
                        (let ((cc (cdr c)))
                          (if (pair? cc)
                              (apply f c)
                              (f c cc)))
                        (py-apply f (* c))))
                   (q (apply f q)))
                 f)))))))

(define-syntax cfor
  (syntax-rules ()
    ((_ (x) (a) code #f #f)
     (if (pair? a)
         (let/ec break-ret
           (let lp ((l a))
             (if (pair? l)
                 (begin
                   (set! x (car l))
                   (with-sp ((continue (values))
                             (break    (break-ret)))
                            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)
                 (let/ec continue-ret
                   (set! 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 lp ((l a))
             (if (pair? l)
                 (begin
                   (set! x (car l))
                   (with-sp ((continue (values))
                             (break    (break-ret)))
                      code))
                 (lp (cdr l))))
           next)
         (for/adv1 (x) (a) code next #f)))

    ((_ (x) (a) code next #t)
     (if (pair? a)
         (let/ec break-ret
           (let lp ((l a))
             (if (pair? l)
                 (let/ec continue-ret
                   (set! x (car l))
                   (with-sp ((continue (continue-ret))
                             (break    (break-ret)))
                      code))
                 (lp (cdr l))))
           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))
                     ((xx ...) (generate-temporaries #'(x ...))))
         #'(let ((inv (wrap-in in)))
             (catch StopIteration
               (lambda ()
                 (let lp ()
                   (call-with-values (lambda () (next inv))
                     (clambda (xx ...)
                       (set! x xx) ... 
                       (with-sp ((break    (values))
                                 (continue (values)))
                                code
                                (lp))))))
               (lambda z (values))))))

      ((_ (x ...) (in ...) code #f #f)
       (with-syntax (((inv ...) (generate-temporaries #'(in ...)))
                     ((xx  ...) (generate-temporaries #'(x ...))))
         #'(let ((inv (wrap-in in)) ...)
             (catch StopIteration
               (lambda ()
                 (let lp ()
                   (call-with-values (lambda () (values (next inv) ...))
                     (clambda (xx ...)
                       (set! x xx) ...
                       (with-sp ((break    (values))
                                 (continue (values)))
                                code
                                (lp))))))
               (lambda z (values))))))

      ((_ (x ...) (in) code #f #t)
       (with-syntax ((inv       (gentemp #'in))
                     ((xx  ...) (generate-temporaries #'(x ...))))
          #'(let ((inv (wrap-in in)))
              (let lp ()
                (let/ec break-ret
                  (catch StopIteration
                    (lambda ()
                      (call-with-values (lambda () (next inv))
                        (clambda (xx ...)
                          (set! x xx) ...
                          (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 ...)))
                     ((xx  ...) (generate-temporaries #'(x ...))))
          #'(let ((inv (wrap-in in)) ...)
              (let lp ()
                (let/ec break-ret
                  (catch StopIteration
                    (lambda ()
                      (call-with-values (lambda () (values (next inv) ...))
                        (clambda (xx ...)
                          (set! x xx) ...
                          (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
                     (catch StopIteration
                       (lambda ()
                         (let lp ()
                           (call-with-values (lambda () (next inv))
                             (clambda (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/ec break-ret
                     (catch StopIteration
                       (lambda ()
                         (let lp ()
                           (call-with-values (lambda () (next inv))
                             (clambda (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
                   (catch StopIteration
                     (lambda ()
                       (let lp ()
                         (call-with-values (lambda () get)
                           (clambda (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/ec break-ret
                   (catch StopIteration
                     (lambda ()
                       (let lp ()
                         (call-with-values (lambda () get)
                           (clambda (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 miss (list 'miss))
(define-inlinable (wr k x)
  (if (eq? x miss)
      (raise (AttributeError k))
      x))

(define-syntax ref-x
  (lambda (x)
    (syntax-case x (quote __dict__)
      ((_ v)
       #'v)
      ((_ v (#:fastfkn-ref f _) . l)
       #'(ref-x (lambda x (if (pyclass? v) (apply f x) (apply f v x))) . l))
      ((_ v (#:fast-id f _) . l)
       #'(ref-x (f v) . l))
      ((_ v (#:identifier '__dict__) . l)
       #'(ref-x (py-dict v) . l))
      ((_ v (#:identifier x) . l)
       #'(ref-x (wr x (ref v x miss)) . 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 (py-apply v x ...) . l))
      ((_ v (#:apply x ...) . l)
       #'(ref-x (py-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 (wr 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))))


(define-syntax boolit
  (syntax-rules (and or not < <= > >=)
    ((_ (and x y)) (and (boolit x) (boolit y)))
    ((_ (or  x y)) (or  (boolit x) (boolit y)))
    ((_ (not x  )) (not (boolit x)))
    ((_ (<   x y)) (<  x y))
    ((_ (<=  x y)) (<= x y))
    ((_ (>   x y)) (>  x y))
    ((_ (>=  x y)) (>= x y))
    ((_ #t) #t)
    ((_ #f) #f)
    ((_ x ) (bool x))))

(define (export-all)
  (define mod (current-module))
  (if (module-defined? mod '__all__)
      (module-export! mod
        (for ((x : (module-ref mod '__all__))) ((l '()))
             (cons (string->symbol (scm-str x)) l)
             #:final l))))