(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 format2) #:select (fnm))
  #:use-module ((language python with) #:select ())
  #:use-module (ice-9 pretty-print)
  #:export (comp exit-fluid exit-prompt pks))

(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 (F2  x) `(@@ (language python format2) ,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 (mk/ec x) x)

(define-syntax-rule (let/ecx c a ...)
  (let/ec c a ...))

(define-syntax-rule (let/ect c a ...)
  (let/ec c ((mk/ec (lambda (c) a ...)) c)))

(eval-when (compile eval load)
  (if (equal? (effective-version) "3.0")
      (module-set! (current-module) 'let/ecx
                   (module-ref (current-module) 'let/ect))))
                   
(define exit-prompt (make-prompt-tag))
(define exit-fluid  (make-fluid #f))

(define (formatter . x) "<missing>")

(define (mk-string vs l)
  (define (mk-string2 x)
    (if (string? x)
        x
        (let ((l (let lp ((l x))
                   (match l
                     ((x . l)
                      (cons
                       (if (string? x)
                           x
                           (match x
                             ((#:field tag a b)
                              `(,(C 'formatter) ,(exp vs tag) ,a ,b))))
                       (lp l)))
                     (() '())))))
          (match l
            ((x) x)
            ((x . l) (cons* '+ x l))))))
                              
  (let ((r
         (let lp ((l l))
           (match l
             ((x . l)
              (let ((x (mk-string2 x))
                    (l (lp l)))
                (if (and (string? x) (= (length l) 1) (string? (car l)))
                    (list (+ x (car l)))
                    (cons x l))))
             (() (list ""))))))
    (if (string? r)
        r
        (cons '+ r))))
  
             

(define-syntax-rule (with-exit code ...)
  (with-fluids ((exit-fluid #t))
    (call-with-prompt exit-prompt
      (lambda () code ...)
      (lambda (k val)
        (if (not (equal? val 0))
            (format #t "exit with error ~a~%" val))))))

(define (get-exported-symbols x)
  (aif it (resolve-module x)
       (aif it (module-public-interface it)
            (let ((l '()))
              (module-for-each
               (lambda (k b)
                 (set! l (cons k l)))
               it)
              l)
            '())
       '()))

(define cvalues (G 'values))

(define-syntax-rule (wth code)
  (let ((old s/d))
    (set! s/d (C 'qset!))
    (let ((r code))
      (set! s/d old)
      r)))


(define-syntax use-modules--
  (lambda (x)
    (define (keyword-like? stx)
      (let ((dat (syntax->datum stx)))
        (and (symbol? dat)
             (eqv? (string-ref (symbol->string dat) 0) #\:))))
    (define (->keyword sym)
      (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
    
    (define (quotify-iface args)
      (let loop ((in args) (out '()))
        (syntax-case in ()
          (() (reverse! out))
          ;; The user wanted #:foo, but wrote :foo. Fix it.
          ((sym . in) (keyword-like? #'sym)
           (loop #`(#,(->keyword (syntax->datum #'sym)) . in) out))
          ((kw . in) (not (keyword? (syntax->datum #'kw)))
           (syntax-violation 'define-module "expected keyword arg" x #'kw))
          ((#:renamer renamer . in)
           (loop #'in (cons* #'renamer #:renamer out)))
          ((kw val . in)
           (loop #'in (cons* #''val #'kw out))))))

    (define (quotify specs)
      (let lp ((in specs) (out '()))
        (syntax-case in ()
          (() (reverse out))
          (((name name* ...) . in)
           (and-map symbol? (syntax->datum #'(name name* ...)))
           (lp #'in (cons #''((name name* ...)) out)))
          ((((name name* ...) arg ...) . in)
           (and-map symbol? (syntax->datum #'(name name* ...)))
           (with-syntax (((quoted-arg ...) (quotify-iface #'(arg ...))))
             (lp #'in (cons #`(list '(name name* ...) quoted-arg ...)
                            out)))))))
    
    (syntax-case x ()
      ((_ spec ...)
       (with-syntax (((quoted-args ...) (quotify #'(spec ...))))
         #'(eval-when (expand)
             (process-use-modules (list quoted-args ...))
             *unspecified*))))))

(define-syntax use-modules-
  (lambda (x)
    (define (keyword-like? stx)
      (let ((dat (syntax->datum stx)))
        (and (symbol? dat)
             (eqv? (string-ref (symbol->string dat) 0) #\:))))
    (define (->keyword sym)
      (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
    
    (define (quotify-iface args)
      (let loop ((in args) (out '()))
        (syntax-case in ()
          (() (reverse! out))
          ;; The user wanted #:foo, but wrote :foo. Fix it.
          ((sym . in) (keyword-like? #'sym)
           (loop #`(#,(->keyword (syntax->datum #'sym)) . in) out))
          ((kw . in) (not (keyword? (syntax->datum #'kw)))
           (syntax-violation 'define-module "expected keyword arg" x #'kw))
          ((#:renamer renamer . in)
           (loop #'in (cons* #'renamer #:renamer out)))
          ((kw val . in)
           (loop #'in (cons* #''val #'kw out))))))

    (define (quotify specs)
      (let lp ((in specs) (out '()))
        (syntax-case in ()
          (() (reverse out))
          (((name name* ...) . in)
           (and-map symbol? (syntax->datum #'(name name* ...)))
           (lp #'in (cons #''((name name* ...)) out)))
          ((((name name* ...) arg ...) . in)
           (and-map symbol? (syntax->datum #'(name name* ...)))
           (with-syntax (((quoted-arg ...) (quotify-iface #'(arg ...))))
             (lp #'in (cons #`(list '(name name* ...) quoted-arg ...)
                            out)))))))
    
    (syntax-case x ()
      ((_ spec ...)
       (with-syntax (((quoted-args ...) (quotify #'(spec ...))))
         #'(eval-when (eval load)
             (process-use-modules (list quoted-args ...))
             *unspecified*))))))

(define-syntax-rule (use p l a ...)
  (begin
    (eval-when (expand)
      (catch #t
        (lambda ()
          (if (not p) (reload-module (resolve-module 'l)))
          (use-modules-- a ...))
        (lambda x
          #f)))
    (eval-when (eval load)
      (catch #t
        (lambda ()
          (if (not p) (reload-module (resolve-module 'l)))
          (use-modules- a ...))
        (lambda x
          (raise (ImportError ((@ (guile) format)
                               #f "failed to import ~a ~a" 'l x))))))))

(define level (make-fluid 0))

(define (flat x)
  (let lp ((x (list x)))
    (if (pair? x)
        (let ((e (car x)))
          (if (pair? e)
              (let ((ee (car e)))
                (if (equal? ee '(@ (guile) cons))
                    (append (lp (list (cadr  e)))
                            (lp (list (caddr e)))
                            (lp (cdr x)))
                    (lp (cdr x))))
              (if (symbol? e)
                  (cons e (lp (cdr x)))
                  '())))
        '())))
                    
(define s/d (C 'qset!))

(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 (gw-persson x l)
  (if (or (member x (fluid-ref (@@ (system base message) %dont-warn-list)))
          (member x l))
      x
      #f))

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

(define-syntax-rule  (with-warn code ...)
  (with-fluids (((@@ (system base message) %dont-warn-list) '()))
    code ...))

(define-syntax-rule  (with-warn-data x code ...)
  (with-fluids (((@@ (system base message) %dont-warn-list) x))
    code ...))

(define (get-warns)
   (list (G 'quote) (fluid-ref (@@ (system base message) %dont-warn-list))))

(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 do-pr #t)

(define (pr . x)
  (if do-pr
      (let ()
        (define port (open-file "/home/stis/src/python-on-guile/modules/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/modules/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 (gv x)
  (if (equal? x '_)
      (gensym "_")
      x))

(define (is-special? vs x)
  (if (or-map (lambda (x) (match x ((#:starexpr . _) #t) (_ #f))) x)
      (let lp ((l (map (g vs exp) x)))
        (if (pair? l)
            `((@ (guile) cons) ,(car l) ,(lp (cdr l)))
            `((@ (guile) quote) ())))
      #f))

(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
         (((#:sub l))
          `(,(F 'for) ((,@(map (lambda (x) (gv ((g vs exp) x))) l)
			: ,(exp vs in-e))) ()
                        ,(gen-sel vs cont item)))
         (_
          `(,(F 'for) ((,@(map (lambda (x) (gv ((g vs exp) x))) for-e)
			: ,(exp vs in-e))) ()
            ,(gen-sel vs cont item))))))
    ((#:cif cif cont)
     `(,(G '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)

    ((#:comma a)
     (scope a vs))

    ((#:comma a . l)
     (union
      (scope a vs)
      (scope (cons #:comma l) 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? ids)
           (let lp2 ((ids2 (car ids)) (as2 (car as)) (vs vs))
             (if (pair? as2)
                 (lp2 (cdr ids2) (cdr as2)
                      (let ((as2  (car as2))
                            (ids2 (car ids2)))
                        (union vs (list (exp '() (if as2 as2 (car ids2)))))))
                 (lp (cdr ids) (cdr as) vs)))
           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 (flat (exp '() v1))
                                      (flat (exp '() v2)))
                               s)
                              (union (flat (exp '() v1)) s)))
                         
                         ((#:starexpr #:power _ v1 . _)
                          (union
                           (flat (exp '() v1))
                           s))
                         
                         (_ s)))
                     '()              
                     l)))              
            '()
            (cons l u))
      vs))

    ((#:for es in code . final)
     (let ((vs (union
                vs
                (let lp ((es es))
                  (match es
                   (((#:sub . l) . u)
                    (union (lp l) (lp u))) 
                   (((#:power #f (#:tuple . l) . _) . u)
                    (union (lp l) (lp u)))
                   (((and (#:power . _) x) . u)
                    (union (list (exp vs x)) (lp u)))
                   ((e . es)
                    (union (lp e) (lp 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 (flat (exp '() v1))
                                    (flat (exp '() v2)))
                             s)
                            (union (flat (exp '() v1)) s)))
                       (_ s)))
                   '()              
                   l)
             vs)
      (scope `(#:expr-stmt ,k (#:asignvs . ,u)) vs)))
    
    ((x . y)
     (scope y (scope x vs)))
    (_ vs)))

(define ignore (make-fluid '()))

(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))
   ((__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))
   ((bit_length)   (N 'py-bit-length))
   ((as_integer_ratio) (N 'py-as-integer-ratio))
   ((conjugate)    (N 'py-conjugate))
   ((denominator)  (N 'py-denominator))
   ((numerator)    (N 'py-numerator))
   ((to_bytes)     (N 'py-to-bytes))
   ((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))
   ((encode)     (S 'py-encode))
  
   ;;Nytevectors   
   ((decode)     (B 'py-decode))
  
   ;;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
      (((#:* 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)) `(,(G 'quote) ())))))

(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
                                                 (,(G 'apply) ,it e ,xs))))
                                #f)))
             (if is-fkn?
                 is-fkn?
                 (if (and fast? fast)
                     `(#:fastfkn-ref ,fast (,(G 'quote) ,tag))
                     (aif it (and fast? (fast-ref tag))
                          `(#:fast-id ,it (,(G 'quote) ,tag))
                          `(#:identifier (,(G 'quote) ,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)
    (lambda (x . x*)
      (if (null? x*)
          x
          (cons x x*)))))

#;
(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
      ("+="  '+)
      ("-="  '-)
      ("*="  '*)
      ("/="  '/)
      ("%="  (G 'modulo))
      ("&="  (G 'logand))
      ("|="  (G 'logior))
      ("^="  (G 'logxor))
      ("**=" (N 'expt))
      ("<<=" (C '<<))
      (">>=" (C '>>))
      ("//=" (G '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 x    ((#:list args)
     (map (g vs exp) args))))

(define inhibit-finally #f)
(define decorations (make-fluid '()))
(define tagis (make-hash-table))

(define (lr as)
  (lambda (vs x)
    (define (eval p a b) ((cdr (assoc p as)) a b))
    (define (expit x)
      (match x
	((#:e e) e)
	(x (exp vs x))))     
    (let lp ((x x))
      (match x
       ((p a b)
	(if (assoc p as)
	    (match b
	      ((q c d)
	       (if (assoc q as)
		   (lp (list q (list #:e (lp (list p a c))) d))
		   (eval p (expit a) (expit b))))
	      (_ (eval p (expit a) (expit b))))
	    (expit x)))
       (_ (expit x))))))
    
(define (mklr x)
  (lambda (a b)
    (list x a b)))

(define (f% s a)
  (if (string? s)
      (list (F2 'format) s a)
      (list (N  'py-mod) s a)))

(define lr+ (lr	`((#:+ . ,(mklr (G '+))) (#:-  . ,(mklr (G '-))))))
(define lr* (lr `((#:* . ,(mklr (G '*))) (#:/  . ,(mklr (N 'py-/)))
		  (#:% . ,f%)            (#:// . ,(mklr (N 'py-floordiv))))))

(define lr-or (lr `((#:bor . ,(mklr (N 'py-logior))))))
(define lr-and (lr `((#:band . ,(mklr (N 'py-logand))))))
(define lr-xor (lr `((#:bxor . ,(mklr (N 'py-logxor))))))
	    
(define-syntax-rule (gen-table x vs (tag code ...) ...)
  (begin
    (hash-set! tagis tag
               (lambda (x vs)
                 (match x code ...)))
                   
    ...))

(define *doc* (make-fluid #f))
(define (get-doc)
  (aif it (fluid-ref *doc*)
       it
       ""))
(define set-doc
  (case-lambda
    (()  (fluid-set! *doc* #f))
    ((x)
     (if (not (fluid-ref *doc*))
         (fluid-set! *doc* x)))))

(define (u-it m)
  (if (and (eq? (list-ref m 0) 'language)
           (eq? (list-ref m 1) 'python)
           (eq? (list-ref m 0) 'module))
      (cddr m)
      '()))

(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 **
           `(,(N '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))
   `(,cvalues)))
 
 (#:string
  ((_ l)
   (mk-string vs 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))))))
           
     
 (#:+
  (x
   (lr+ vs x)))
 
 (#:-
  (x
   (lr+ vs x)))
 
 (#:*
  (x
   (lr* vs x)))
 
 (#:/
  (x
   (lr* vs x)))
 
 (#:%
  (x
   (lr* vs x)))
 
 (#://
  (x
   (lr* vs x)))

 (#:<<
  ((_ . 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
  (x (lr-and vs x)))
 
 (#:bxor
  (x (lr-xor vs x)))
 
 (#:bor
  (x (lr-or vs x)))
    
 (#:not
  ((_ x)
   (list (G 'not) (list (C 'boolit) (exp vs x)))))
 
 (#:or
  ((_ . x)
   (cons (G 'or) (map (lambda (x) (list (C 'boolit) (exp vs x))) x))))
    
 (#:and
  ((_ . x)
   (cons (G 'and) (map (lambda (x) (list (C 'boolit) (exp vs x))) x))))
    
 (#:test
  ((_ e1 #f)
   (exp vs e1))

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

  ((_ e1 (e2 e3))
   (list (G 'if) (list (C 'boolit) (exp vs e2)) (exp vs e1) (exp vs e3))))

 (#:del
  ;;We don't delete variables
  ((_  . l)
   `(,(G 'begin)
      ,@(let lp ((l l))
          (match l
            (((#:power #f base () . #f) . l)
             (cons `(set! ,(exp vs base) #f)
                   (lp l)))
   
  
            (((#:power #f base (l ... fin) . #f) . ll)
             (let* ((f     (exp vs base))
                    (fast? (not (eq? f 'super)))
                    (add   (get-addings vs l fast?))
                    (fin   (get-addings vs (list fin) fast?)))
               (cons
                `(,(C 'del-x) (,(C 'ref-x) ,f ,@add) ,@fin)
                (lp ll))))
            (() '()))))))

 (#: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
  ((_ #:stmt  . l) (cons (G 'begin)  (map (g vs exp) l)))
  ((_         . l) (cons (G '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))
               (vo  vs)
               (vs  (union (list class) vs))
               (ns  (scope code '()))
               (ls  ns #;(diff ns vs))

               (parents (match parents
                          (() #f)
                          (#f #f)
                          ((#:arglist . _)
                           (get-addings vs (list parents) #f))))
               (cd.doc  (with-fluids ((*doc* #f))
                          (let ((cd (wth (exp vs code))))
                            (cons cd (get-doc)))))
               (cd      (car cd.doc))
               (doc     (cdr cd.doc)))
          `(set! ,class
             (,(C 'class-decor) ,decor
              (,(C 'with-class) ,class
               (,(C 'mk-p-class2)
                ,class                
                ,(if parents
                     (arglist->pkw (clean parents))
                     `(,(G 'cons) (,(G 'quote) ()) (,(G 'quote) ())))
                ,doc
                ,(map (lambda (x) `(define ,x ,(gw-persson x vo))) ls)
                ,cd)))))))))
 (#:verb
  ((_ x) x))
 
 (#:scm
  ((_ (#:string _ s)) (with-input-from-string s read)))

 (#:comma
  ((_
    (and x
         (#:expr-stmt
          ((#:test
            (#:power #f (#:string l) () . #f)
            #f))
          (#:assign))))
   (set-doc (mk-string vs l))
   (exp vs x))
  
  ((_ a)
   (exp vs a))

  ((_ (and a
           (#:expr-stmt
            ((#:test
              (#:power #f (#:string ll) () . #f)
              #f))
            (#:assign))) . l)
   (set-doc (mk-string vs ll))
   `(,(G 'begin) ,(exp vs a) ,(exp vs (cons #:comma l))))
  
  ((_ a . l)
   `(,(G 'begin) ,(exp vs a) ,(exp vs (cons #:comma l)))))
  
 (#:import
  ((_ (#:from (() () . nm) . #f))
   (let* ((xl (map (lambda (nm) (exp vs nm)) nm))
          (l  `(language python module ,@xl)))

     ;; Make sure to load the module in
     (let ((? (catch #t
                (lambda () (Module (reverse l) (reverse xl)) #t)
                (lambda x #f))))
       (if (eq? ? #t) (for-each dont-warn (get-exported-symbols l)))       
       `(,(C 'use) ,? ,l ,l))))

  ((_ (#:from (("." . nn) . nm) . #f))
   (let* ((u   (module-name (current-module)))
          (u   (reverse (list-cdr-ref (reverse (u-it u)) (length nn))))
          (xl  (append u (map (lambda (nm) (exp vs nm)) nm)))
          (l  `(language python module ,@xl)))

     ;; Make sure to load the module in
     (let ((? (catch #t
                (lambda () (Module (reverse l) (reverse xl)) #t)
                (lambda x #f))))
       (if (eq? ? #t) (for-each dont-warn (get-exported-symbols l)))       
       `(,(C 'use) ,? ,l ,l))))

  ((_ (#:from ("." . nn) . #f))
   (let* ((nm  '())
          (u   (module-name (current-module)))
          (u   (reverse (list-cdr-ref (reverse (u-it u)) (length nn))))
          (xl  (append u (map (lambda (nm) (exp vs nm)) nm)))
          (l  `(language python module ,@xl)))

     ;; Make sure to load the module in
     (let ((? (catch #t
                (lambda () (Module (reverse l) (reverse xl)) #t)
                (lambda x #f))))
       (if (eq? ? #t) (for-each dont-warn (get-exported-symbols l)))       
       `(,(C 'use) ,? ,l ,l))))
  
  ((_ (#:from (() () . nm)  l))
   ;; Make sure to load the module in
   (let* ((xl  (map (lambda (nm) (exp vs nm)) nm))
          (ll `(language python module ,@xl)))
     
     `(,(C 'use) #t ()
       (,ll
        #:select
        ,(map (lambda (x)
                (match x
                  ((a . #f)
                   (let ((s (exp vs a)))
                     (fluid-set! ignore
                                 (cons s (fluid-ref ignore)))
                     (dont-warn s)
                     s))
                  
                  ((a . b)
                   (let ((s1 (exp vs a))
                         (s2 (exp vs b)))
                     (fluid-set! ignore
                                 (cons s2
                                       (fluid-ref ignore)))
                     (dont-warn s2)
                     (cons s1 s2)))))
              l)))))

  ((_ (#:from (("." . nn) . nm)  l))
   ;; Make sure to load the module in
   (let* ((u   (module-name (current-module)))
          (u   (reverse (list-cdr-ref (reverse (u-it u)) (length nn))))
          (xl  (append u (map (lambda (nm) (exp vs nm)) nm)))
          (ll `(language python module ,@xl)))
     
     `(,(C 'use) #t ()
       (,ll
        #:select
        ,(map (lambda (x)
                (match x
                  ((a . #f)
                   (let ((s (exp vs a)))
                     (fluid-set! ignore
                                 (cons s (fluid-ref ignore)))
                     (dont-warn s)
                     s))
                  
                  ((a . b)
                   (let ((s1 (exp vs a))
                         (s2 (exp vs b)))
                     (fluid-set! ignore
                                 (cons s2
                                       (fluid-ref ignore)))
                     (dont-warn s2)
                     (cons s1 s2)))))
              l)))))

    ((_ (#:from ("." . nn) l))
     ;; Make sure to load the module in
     (let* ((nm  '())
            (u   (module-name (current-module)))
            (u   (reverse (list-cdr-ref (reverse (u-it u)) (length nn))))
            (xl  (append u (map (lambda (nm) (exp vs nm)) nm)))
            (ll `(language python module ,@xl)))
     
       `(,(C 'use) #t ()
         (,ll
          #:select
          ,(map (lambda (x)
                  (match x
                    ((a . #f)
                     (let ((s (exp vs a)))
                       (fluid-set! ignore
                                   (cons s (fluid-ref ignore)))
                       (dont-warn s)
                       s))
                    
                    ((a . b)
                     (let ((s1 (exp vs a))
                           (s2 (exp vs b)))
                       (fluid-set! ignore
                                   (cons s2
                                         (fluid-ref ignore)))
                       (dont-warn s2)
                       (cons s1 s2)))))
                l)))))

  
   ((_ (#:name ((dots ids ...) . as) ...) ...)
   `(,(G 'begin)
      ,@(map
         (lambda (dots ids as)
           `(,(G 'begin)
             ,@(map (lambda (dots ids as)
                      (let* ((u   (module-name (current-module)))
                             (u   (if (null? dots)
                                      '()
                                      (reverse (list-cdr-ref
                                                (reverse (u-it u))
                                                (- (length dots) 1)))))

                              (path (append (if (null? dots) '() u)
                                            (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)
                                     (,(G 'quote)
                                      ,(reverse (append
                                                 '(language python module)
                                                 path)))
                                     (,(G 'quote) ,(reverse path)))
                                    ,(exp vs as)))))))
                             (exp
                              vs
                              `(#:expr-stmt
                                ((#:test (#:power #f ,(car ids) ())))
                                (#:assign
                                 ((#:verb
                                   ((@ (language python module) import)
                                    ((@ (language python module) Module)
                                     (,(G 'quote)
                                      ,(append '(language python module)
                                               path)))
                                    ,(exp vs (car ids)))))))))))
                     dots ids as)))
         dots 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 . _))
                       . _)
              (let* ((code2 (exp vs code))
                     (p     (is-ec #t code2 #t (list (C 'continue)))))
                
              (match arglist
                ((arg)
                 (if p
                     (let ((v   (gensym "v"))
                           (x   (string->symbol x))
                           (lp  (gensym "lp")))
                       `(,(C 'let/ecx) break-ret
                         (,(G 'let) ((,v ,(exp vs arg)))
                           (,(G 'let) ,lp ((,x 0))
                                (,(G 'if) (< ,x ,v)
                                    (,(G 'begin)
                                      (,(C 'let/ecx) continue-ret
                                       (,(C 'with-sp) ((continue (continue-ret))
                                                       (break    (break-ret)))
                                        ,code2))
                                      (,lp (+ ,x 1))))))))
                
                     (let ((v   (gensym "v"))
                           (x   (string->symbol x))
                           (lp  (gensym "lp")))
                       `(,(C 'let/ecx) break-ret
                         (,(G 'let) ((,v ,(exp vs arg)))
                           (,(G 'let) ,lp ((,x 0))
                                (,(G 'if) (< ,x ,v)
                                    (,(G 'begin)
                                      (,(C 'with-sp) ((break    (break-ret)))
                                       ,code2)
                                      (,lp (+ ,x 1))))))))))
                 
                ((arg1 arg2)
                 (let ((v1   (gensym "va"))
                       (v2   (gensym "vb"))
                       (x    (string->symbol x))
                       (lp  (gensym "lp")))
                   (if p
                       `(,(C 'let/ecx) break-ret
                         (,(G 'let) ((,v1 ,(exp vs arg1))
                                     (,v2 ,(exp vs arg2)))
                           (,(G 'let) ,lp ((,x ,v1))
                                (,(G 'if) (< ,x ,v2)
                                    (,(G 'begin)
                                      (,(C 'let/ecx) continue-ret
                                       (,(C 'with-sp) ((continue (continue-ret))
                                                       (break    (break-ret)))
                                        ,code2))
                                      (,lp (+ ,x 1)))))))
                       `(,(C 'let/ecx) break-ret
                         (,(G 'let) ((,v1 ,(exp vs arg1))
                                     (,v2 ,(exp vs arg2)))
                           (,(G 'let) ,lp ((,x ,v1))
                                (,(G 'if) (< ,x ,v2)
                                    (,(G 'begin)
                                      (,(C 'with-sp) ((break    (break-ret)))
                                       ,code2)
                                      (,lp (+ ,x 1))))))))))
                ((arg1 arg2 arg3)
                 (let ((v1   (gensym "va"))
                       (v2   (gensym "vb"))
                       (st   (gensym "vs"))
                       (x    (string->symbol x))
                       (lp  (gensym "lp")))
                   (if p
                       `(,(C 'let/ecx) break-ret
                         (,(G 'let) ((,v1 ,(exp vs arg1))
                                     (,st ,(exp vs arg3))  
                                     (,v2 ,(exp vs arg2)))
                           (,(G 'if) (> ,st 0)
                               (,(G 'let) ,lp ((,x ,v1))
                                    (,(G 'if) (< ,x ,v2)
                                        (,(G 'begin)
                                          (,(C 'let/ecx) continue-ret
                                           (,(C 'with-sp)
                                            ((continue (continue-ret))
                                             (break    (break-ret)))
                                            ,code2))
                                          (,lp (+ ,x ,st)))))
                               (,(G 'if) (< ,st 0)
                                   (,(G 'let) ,lp ((,x ,v1))
                                        (,(G 'if) (> ,x ,v2)
                                            (,(G 'begin)
                                              (,(C 'let/ecx) continue-ret
                                               (,(C 'with-sp)
                                                ((continue (continue-ret))
                                                 (break    (break-ret)))
                                                ,code2))
                                              (,lp (+ ,x ,st)))))
                                   (,(G 'error)
                                    "range with step 0 not allowed")))))
                       `(,(C 'let/ecx) break-ret
                         (,(G 'let) ((,v1 ,(exp vs arg1))
                                     (,st ,(exp vs arg3))
                                     (,v2 ,(exp vs arg2)))
                           (,(G 'if) (> ,st 0)
                               (,(G 'let) ,lp ((,x ,v1))
                                    (,(G 'if) (< ,x ,v2)
                                        (,(G 'begin)
                                          (,(C 'with-sp)
                                           ((break    (break-ret)))
                                           ,code2)
                                          (,lp (+ ,x ,st)))))
                               (,(G 'if) (< ,st 0)
                                         (,(G 'let) ,lp ((,x ,v1))
                                             (,(G 'if) (> ,x ,v2)
                                              (,(G 'begin)
                                               (,(C 'with-sp)
                                                ((break    (break-ret)))
                                                ,code2)
                                               (,lp (+ ,x ,st)))))
                                   (,(G '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   (match in
                        ((in)     (list (exp vs in)))
                        ((in ...) (list `(,(G 'list)
                                          ,@ (map (g vs exp) in)))))))
          (list (C 'cfor) es2 in2 code2 else2 p)))))))

 (#:sub
  ((_ l)
   (map (g vs exp) l)))

 (#:while
  ((_ test code . #f)
   (let* ((lp    (gensym "lp"))
          (code2 (exp vs code))
          (p     (is-ec #t code2 #t (list (C 'continue)))))
     (if p
         `(,(C 'let/ecx) break-ret
           (,(G 'let) ,lp ()
            (,(G 'if) (,(C 'boolit) ,(exp vs test))
                (,(G 'begin)
                  (,(C 'let/ecx) continue-ret
                   (,(C 'with-sp) ((continue (continue-ret))
                                   (break    (break-ret)))                    
                    ,code2))
                  (,lp)))))

         `(,(C 'let/ecx) break-ret
           (,(G 'let) ,lp ()
            (,(G 'if) (,(C 'boolit) ,(exp vs test))
                (,(G 'begin)
                  (,(C 'with-sp) ((break    (break-ret)))
                   ,code2)
                  (,lp))))))))
     
  ((_ test code . else)
   (let* ((lp    (gensym "lp"))
          (code2 (exp vs code))
          (p     (is-ec #t code2 #t (list (C 'continue)))))
     (if p
         `(,(C 'let/ecx) break-ret
           (,(G 'let) ,lp ()
            (,(G 'if) (,(C 'boolit) ,(exp vs test))
                (,(G 'begin)
                  (,(C 'let/ecx) ,(C 'continue-ret)
                   (,(C 'with-sp) ((continue (continue-ret))
                                   (break    (break-ret)))
                    ,code2))
                  (,lp))
                ,(exp vs else))))
         
         `(,(C 'let/ecx) break-ret
           (,(G 'let) ,lp ()
             (,(G 'if) (,(C 'boolit) ,(exp vs test))
                 (,(G 'begin)
                   (,(C 'with-sp) ((break (break-ret)))
                    ,code2)
                   (,lp))
                 ,(exp vs else))))))))

 (#:try
  ((_ x (or #f ()) #f . fin)
   (if fin
       `(,(T 'try) (,(G 'lambda) () ,(exp vs x))
         #:finally (,(G 'lambda) () ,(exp vs fin)))
       `(,(T 'try) (,(G '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) => (,(G 'lambda)
                                                 (,(exp vs as) . ,l)
                                                 ,(exp vs code)))
                   r))))
           (()
            (reverse r))))
     
     ,@(if else `((#:except #t ,(exp vs else))) '())
     ,@(if fin `(#:finally (,(G '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)
       (,(G 'let) ((,c ,(exp vs code)))
         (,(G 'let) ((,o (,(G 'if) (,(O 'pyclass?) ,c)
                       (,c)
                       ,c)))
           (,(O 'set) ,o (,(G 'quote) __cause__) ,(exp vs from))
           ,o))))))
             
      
 (#:yield
  ((_ (#:from x))
   (let ((y (gensym "y"))
         (f (gensym "f")))
     `(,(G 'begin)
        (fluid-set! ,(Y 'in-yield) #t)
        (,(F 'for) ((,y : ,(exp vs x))) ()
         (,(G 'let) ((,f (scm.yield ,y)))
           (,f))))))
   
  ((_ args)
   (let ((f (gensym "f")))
     `(,(G 'begin)
        (,(G 'fluid-set!) ,(Y 'in-yield) #t)
        (,(G 'let) ((,f (scm.yield ,@(gen-yargs vs args))))
          (,f)))))

    
  ((_ f args)
   (let ((f (gen-yield (exp vs f)))
         (g (gensym "f")))
     `(,(G 'begin)
        (set! ,(C 'inhibit-finally) #t)
        (,(G '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))
          (cd.doc (with-fluids ((is-class? #f)
                                (*doc*     #f)
                                (return    r))
                    (let ((cd (wth (exp ns code))))
                      (cons cd (get-doc)))))
          (cd     (car cd.doc))
          (doc    (cdr cd.doc))
          (docv   (gensym "fv"))
          (docer  (lambda (x) `(,(G 'let) ((,docv ,x))
                                (,(C 'set) ,docv (,(G 'quote) __doc__) ,doc)
                                ,docv))))
     (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))
     
     (if c?
         (if y?
             `(set! ,f
                ,(docer
                  `(,(C 'def-decor) ,decor
                    (,(C 'def-wrap) ,y? ,f ,ab
                     (,(D 'lam) ,aa
                      (,(C 'with-return) ,r
                       ,(mk `(,(G 'let) ,(map (lambda (x) (list x #f)) ls)
                              (,(C 'with-self) ,c? ,aa
                               ,cd)))))))))
             
             `(set! ,f
                ,(docer
                  `(,(C 'def-decor) ,decor
                    (,(D 'lam) ,aa
                     (,(C 'with-return) ,r
                      ,(mk `(,(G 'let) ,(map (lambda (x) (list x #f)) ls)
                             (,(C 'with-self) ,c? ,aa
                              ,cd)))))))))
            
         (if y?
             `(set! ,f
                ,(docer
                  `(,(C 'def-decor) ,decor
                    (,(C 'def-wrap) ,y? ,f ,ab
                     (,(D 'lam) ,aa
                      (,(C 'with-return) ,r 
                       (,(G 'let) ,(map (lambda (x) (list x #f)) ls)
                        (,(C 'with-self) ,c? ,aa
                         ,(mk cd)))))))))
             `(set! ,f
                  ,(docer
                    `(,(C 'def-decor) ,decor
                      (,(D 'lam) ,aa
                       (,(C 'with-return) ,r 
                        (,(G 'let) ,(map (lambda (x) (list x #f)) ls)
                         (,(C 'with-self) ,c? ,aa
                          ,(mk cd)))))))))))))

 (#:global
  ((_ . _)
   `(,cvalues)))

 (#:starexpr
  ((_ _ _ id . _)
   `(#:star ,(exp vs id))))
 
 (#:list
  ((_ x (and e (#:cfor . _)))
   (let ((l (gensym "l")))
     `(,(G 'let) ((,l (,(L 'to-pylist) (,(G 'quote) ()))))
        ,(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) `(,(G 'quote) ()))
                            (((#:starexpr  #:power #f (#:list . l) . _) . _)
                             (lp l))
                            (((#:starexpr  #:power #f (#:tuple . l) . _) . _)
                             (lp l))
                            (((#:starexpr . l) . _)
                             `(,(L 'to-list) ,(exp vs l)))
                            ((x . l)
                            `(,(G 'cons) ,(exp vs x) ,(lp l))))))))
 (#:tuple
  ((_ x (and e (#:cfor . _)))
   (exp vs (list #:comp x e)))
  
  ((_ . l)
   (let lp ((l l))
     (match l
       (() `(,(G 'quote) ()))
       (((#:starexpr  #:power #f (#:list . l) . _) . _)
        (lp l))
       (((#:starexpr  #:power #f (#:tuple . l) . _) . _)
        (lp l))
       (((#:starexpr . l) . _)
        `(,(L 'to-list) ,(exp vs l)))
       ((x . l)
        `(,(G '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))))
  
  ((_ () e)
     (list (C `lam) `() (exp vs e))))
 
 (#:stmt
  ((_ l)
   (exp vs 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")))
     `(,(G '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)
             `(,(G 'begin)
                ,(make-set vs op (car l) (exp vs (car u)))
                (,cvalues))
             `(,(G 'begin)
                ,@(map (lambda (l u) (make-set vs op l u))
                       l
                       (map (g vs exp) u))
                (,cvalues))))
        
        ((and (= (length u) 1) (not op))         
         (let ((vars (map (lambda (x) (gensym "v")) l))
               (spec (gensym "special"))
               (q    (gensym "q"))
               (f    (gensym "f"))
               (a?   (is-special? vs l)))
           (if a?
               `(,(G 'begin)
                 (call-with-values (lambda () ,(exp vs (car u)))
                   (,(G 'letrec) ((,f
                                   (case-lambda
                                     ((,q)
                                      (,(G 'if) (pair? ,q)
                                       (,(G 'apply) ,f ,q)
                                       (,(G 'apply) ,f (,(L 'to-list) ,q))))
                                     (,spec                                  
                                      (,(C 'qset!) ,a? ,spec)))))
                    ,f))
                 (,cvalues))

               `(,(G 'begin)
                 (call-with-values (lambda () ,(exp vs (car u)))
                   (,(G 'letrec) ((,f
                                   (case-lambda
                                     ((,q)
                                      (,(G 'if) (pair? ,q)
                                       (,(G 'apply) ,f ,q)
                                       (,(G 'apply) ,f (,(L 'to-list) ,q))))
                                     (,vars                                   
                                      ,@(map (lambda (l v) (make-set vs op l v))
                                             l vars)))))
                    ,f))
                 (,cvalues)))))
        
        ((and (= (length l) 1) (not op))
         `(,(G 'begin)
            ,(make-set vs op (car l) `(,(G 'list) ,@(map (g vs exp) u)))
            (,cvalues)))))))
  
  ((_
    ((#: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)
   `(,(G 'if)
     (,(G 'not) (,(G 'and) ,@(map (lambda (x) `(,(C 'boolit) ,(exp vs x)))
                                     x)))
     (,(C 'raise) ,(C 'AssertionError) (,(G 'quote) ,f) ,n ,m))))


  
 (#:expr-stmt1
  ((_ a (#:assign b c . u))
   (let ((z (gensym "x")))
     `(,(G '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)
             `(,(G 'begin)
                ,(make-set vs op (car l) (exp vs (car u)))
                ,(exp vs (car l)))
             `(,(G 'begin)
                ,@(map (lambda (l u) (make-set vs op l u))
                       l
                       (map (g vs exp) u))
                (,cvalues ,@(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")))
           `(,(G 'begin)
              (call-with-values (lambda () ,(exp vs (car u)))
                (,(G 'letrec) ((,f
                          (case-lambda
                            ((,q)
                             (,(G 'if) (pair? ,q)
                                 (,(G 'apply) ,f ,q)
                                 (,(G 'apply) ,f (,(L 'to-list) ,q))))
                            (,vars
                             ,@(map (lambda (l v) (make-set vs op l v))
                                    l vars)))))
                  ,f))
              (,cvalues ,@(map (g exp vs) l)))))
        
        ((and (= (length l) 1) (not op))
         `(,(G 'begin)
            ,(make-set vs op (car l) `(,(G 'list) ,@(map (g vs exp) u)))
            (,cvalues ,(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")))
     `(,(G '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")))
     `(,(G '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")))
     `(,(G 'let) ((,dict (,(Se 'set))))
        ,(gen-sel vs e `((,(O 'ref) ,dict (,(G 'quote) add)) ,(exp vs k)))
        ,dict)))
  
  ((_  k ...)
   (let ((set (gensym "dict")))
     `(,(G 'let) ((,set (,(Se 'set))))
        ,@(map (lambda (k)
                 `((,(O 'ref) ,set (,(G 'quote) add)) ,(exp vs k)))
               k)
        ,set))))
                  
                           
 (#:comp
  ((_ x (and e (#:cfor . _)) . _)
   (let ((yield (gensym "yield")))
     `((,(Y 'make-generator) ()
        (lambda (,yield)
          ,(gen-sel vs e `(,yield ,(exp vs x))))))))
  
  ((_ 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")))
     `(,(G 'let) ((,m ,(exp vs y)))
       (,(G 'and) ,(tr-comp op (exp vs x) m)
        ,(exp vs `(#:comp (#:verb ,m) . ,l))))))))


(define (exp vs x)
  (match (pr 'exp 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  `(,(G 'quote) ()))
    (#:False #f)
    (#:pass  `(,cvalues))
    (#:break
     (C 'break))    
    (#:continue
     (C 'continue))
    (x x)))

(define (comp in x)
  (define (strit x)
    (if in
        x
        (with-output-to-string
          (lambda ()
            (let lp ((x x))
              (if (pair? x)
                  (begin
                    (format #t "~s~%" (car x))
                    (lp (cdr x)))))))))
  
  (define start
    (match x
      (((#:stmt
         (#:comma
          (#:expr-stmt
           ((#:test
             (#:power #f
                      (#:identifier "module" . _)
                      ((#:arglist arglist))
                      . #f) #f))
           (#:assign)))) . rest)

       (let ()
         (define args
           (map (lambda (x)
                  (exp '() x))
                arglist))
	 
	 (define name (string-join (map symbol->string args) "."))
	 
         `((define-module (language python module ,@args)
             #:pure
             #:use-module ((guile) #:select
                           (@ @@ pk let* lambda call-with-values case-lambda
                                    set! = * + - < <= > >= / pair? fluid-set!
                                    fluid-ref
                                    syntax-rules let-syntax abort-to-prompt))
             #:use-module (language python module python)
             #:use-module ((language python compile) #:select (pks))
             #:use-module (language python exceptions)
             #:use-module ((oop goops) #:select (<complex> <real> <fraction> <integer> <number>)))
           (,(G 'define) __doc__    #f)
	   (,(G 'define) __name__   ,name)
           (,(G 'define) __module__ (,(G 'quote)
                                     (language python module ,@args))))))
      (x '())))

  (fluid-set! ignore '())

  (strit
   (pr
    (if (fluid-ref (@@ (system base compile) %in-compile))
        (begin
          (if (fluid-ref (@@ (system base compile) %in-compile))
              (set! s/d (C 'qset!))
              (set! s/d (C 'define-)))
          
          (if (pair? start)
              (set! x (cdr x)))
          
          (let* ((globs (get-globals x))
                 (e.doc (with-fluids ((*doc* #f))
                          (let ((r (map (g globs exp) x)))
                            (cons r (get-doc)))))
                 (e     (car e.doc))
                 (doc   (cdr e.doc)))
          
            `(,@start
              (,(G 'define) ,fnm (,(G 'make-hash-table)))
              ,@(map (lambda (s)
                       (if (member s (fluid-ref ignore))
                           `(,cvalues)
                           `(,(C 'var) ,s)))
                     (cons '__doc__ globs))
              (,(G 'set!) __doc__ ,doc)
              ,@e
              (,(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))
                 (res   (gensym "res"))
                 (e     (map (g globs exp) x)))
            `(begin
               ,@start
              ,@(map (lambda (s)
                       (if (member s (fluid-ref ignore))
                           `(,cvalues)
                           `(,(C 'var) ,s))) globs)
              (,(C 'with-exit) ,@e))))))))
  
(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 with-sp
  (lambda (x)
    (syntax-case x ()
      ((_ ((x v)) code ...)
       (equal? (syntax->datum #'x) 'break)      
       #'(syntax-parameterize ((break (lambda (y) #'v))) code ...))
      
      ((_ ((x1 v1) (x2 v2)) code ...)
       (and (equal? (syntax->datum #'x1) 'break)
            (equal? (syntax->datum #'x2) 'continue))
       #'(syntax-parameterize ((break    (lambda (y) #'v1))
                               (continue (lambda (y) #'v2)))
            code ...))
      
      ((_ ((x2 v2) (x1 v1)) code ...)
       (and (equal? (syntax->datum #'x1) 'break)
            (equal? (syntax->datum #'x2) 'continue))
       #'(syntax-parameterize ((break    (lambda (y) #'v1))
                               (continue (lambda (y) #'v2)))
            code ...)))))

      
(define (is-ec ret x tail tags)
  (match x
    ((('@ ('guile) 'cond) (p a ... b) ...)
     (or
      (or-map (lambda (x) (or-map (lambda (x) (is-ec ret x #f tags)) x))
              a)
      (or-map (lambda (x) (is-ec ret x tail tags))
              b)))
        
    (((_ _ 'with-self) u v a ... b)
     (or
      (or-map (lambda (x) (is-ec ret x #f tags)) a)
      (is-ec ret b tail tags)))

    (('let-syntax v a ... b)
     (or
      (or-map (lambda (x) (is-ec ret x #f tags)) a)
      (is-ec ret b tail tags)))
        
    ((('@ ('guile) 'begin) a ... b)
     (or
      (or-map (lambda (x) (is-ec ret x #f tags)) a)
      (is-ec ret b tail tags)))
        
    ((('@ ('guile) 'let) lp ((y x) ...) a ... b) (=> next)
     (if (symbol? 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))
         (next)))
        
    ((('@ ('guile) 'let) ((y x) ...) a ... b)
     (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)
     (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)))

    ((('@ ('guile) 'define) . _)
     #f)

    ((('@ ('guile) 'if) p a b)
     (or
      (is-ec ret p #f   tags)
      (is-ec ret a tail tags)
      (is-ec ret b tail tags)))
        
    ((('@ ('guile) 'if) p a)
     (or
      (is-ec ret #'p #f   tags)
      (is-ec ret #'a tail tags)))

    (('@@ _ _)
     (if (member x tags)
         #t
         #f))

        
    ((a ...)
     (or-map (lambda (x) (is-ec ret x #f tags)) a))

    (x #f)))

(define-syntax with-return
  (lambda (x)
    (define (analyze ret x)
      (syntax-case x (let-syntax let* @ @@)
        ((cond- (p a ... b) ...)
         (equal? (syntax->datum #'cond-)
                 '(@ (guile) cond))
         (with-syntax (((bb ...) (map (lambda (x) (analyze ret x)) #'(b ...))))
           #'(cond (p a ... bb) ...)))
        
        (((_ _ with-self-) u v a ... b)         
         (equal? (syntax->datum #'with-self-)
                 'with-self)
         #`(with-self u v a ... #,(analyze ret #'b)))
        
        ((let-syntax v a ... b)
         #`(let-syntax v a ... #,(analyze ret #'b)))
        
        (((@ (guile) begin-) a ... b)
         (equal? (syntax->datum #'begin-)
                 'begin)
         #`(begin a ... #,(analyze ret #'b)))
        
        (((@ (guile) let-) lp v a ... b)
         (and
          (equal? (syntax->datum #'let-)
                  'let)
          (symbol? (syntax->datum #'lp)))
         #`(let lp v a ... #,(analyze ret #'b)))
        
        (((@ (guile) let-) v a ... b)
         (equal? (syntax->datum #'let-)
                 'let)
         #`(let v a ... #,(analyze ret #'b)))
        
        (((@ (guile) if-) p a b)
         (equal? (syntax->datum #'if-)
                 'if)
         #`(if p #,(analyze ret #'a) #,(analyze ret #'b)))
        
        (((@ (guile) if-) p a)
         (equal? (syntax->datum #'if-)
                 'if)
         #`(if p #,(analyze ret #'a)))
        
        ((return a b ...)
         (equal? (syntax->datum #'return) (syntax->datum ret))
         (if (eq? #'(b ...) '())
             #'a
             #`(values a b ...)))
        
        ((return)
         (equal? (syntax->datum #'return) (syntax->datum ret))
         #`(values))
        
        (x #'x)))
  
    (define (is-ec ret x tail)
      (syntax-case x (let-syntax let* @@ @)
        (((@ (guile) cond) (p a ... b) ...)
         (equal? (syntax->datum #'cond)
                 'cond)
         (or
          (or-map (lambda (x) (is-ec ret x #f))
                  #'(a ... ...))
          (or-map (lambda (x) (is-ec ret x tail))
                  #'(b ...))))
        
        (((_ _ with-self) u v a ... b)
         (equal? (syntax->datum #'with-self)
                 'with-self)
         (or
          (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
          (is-ec ret #'b tail)))

        ((let-syntax v a ... b)
         #t
         (or
          (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
          (is-ec ret #'b tail)))
        
        (((@ (guile) begin) a ... b)
         (equal? (syntax->datum #'begin)
                 'begin)
         (or
          (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
          (is-ec ret #'b tail)))
        
        (((@ (guile) let) lp ((y x) ...) a ... b)
         (and
          (equal? (syntax->datum #'let)
                  'let)
          (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)))
        
        (((@ (guile) let) ((y x) ...) a ... b)
         (equal? (syntax->datum #'let)
                 'let)
         (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)))

        (((@ (guile) define) . _)         
         (equal? (syntax->datum #'define)
                 'define)
         #f)

        (((@ (guile) if) p a b)
         (equal? (syntax->datum #'if)
                 'if)
         (or
          (is-ec ret #'p #f)
          (is-ec ret #'a tail)
          (is-ec ret #'b tail)))
        
        (((@ (guile) if) p a)
         (equal? (syntax->datum #'if)
                 'if)         
         (or
          (is-ec ret #'p #f)
          (is-ec ret #'a tail)))

        ((return 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/ecx ret l)
             code))))))

(define void (list 'void))

(define-syntax var
  (lambda (x)
    (syntax-case x (cons quote)
      ((_ '())
       #'(values))
      ((_ (cons x v))
       #'(begin (var x) (var v)))
      ((_ v)
       (begin
         (dont-warn (syntax->datum #'v))
         #'(if (module-defined? (current-module) 'v)
               (values)
               (define! 'v void)))))))

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

(define (gentemp stx) (datum->syntax stx (gensym "x")))

(define-syntax mmatch
  (syntax-rules ()
    ((_ (a . aa) (b . bb) . code)
     (match a (b (mmatch aa bb . code))))
    ((_ () () . code)
     (begin . code))))

(define (mutewarn x y) (list x y))

(define-syntax clambda
  (lambda (x)
    (syntax-case x ()
      ((_ (x ...) code ...)
       (with-syntax ((n (length #'(x ...)))
                     ((y ...) (generate-temporaries #'(x ...))))
         #'(let ((f (lambda (y ... . u)
                      (mmatch (y ...) (x ...) code ...))))
             (if (> n 1)                
                 (case-lambda
                   ((c)
                    (if (pair? c)
                        (let ((cc (cdr c)))
                          (if (pair? cc)
                              (apply f c)			      
                              (apply f (mutewarn c cc))))
                        (py-apply f (* c))))
                   (q (apply f q)))
                 f)))))))

(define (gen-temp x)
  (syntax-case x ()
    ((x ...) (map gen-temp #'(x ...)))
    (x       (car (generate-temporaries (list #'x))))))

(define (replace_ stx l)
  (let lp ((l l))
    (syntax-case l ()
      ((a . l) (cons (lp #'a) (lp #'l)))
      (x
       (if (equal? (syntax->datum #'x) '_)
	   (datum->syntax stx (gensym "_"))
	   #'x)))))

(define-syntax with-syntax*
  (syntax-rules ()
    ((_ () code)     code)
    ((_ () . code) (begin . code))
    ((_ (x . l) . code)
     (with-syntax (x) (with-syntax* l . code)))))

(define-syntax cfor
  (lambda (xx)
    (syntax-case xx ()
      ((_ (x ...) in code next p)
       (or-map pair? #'(x ...))
       #'(for-adv  (x ...) in code next p))
     
      ((_ (x) (a) code #f #f)
       (with-syntax ((x (replace_ xx #'x)))
         #'(if (pair? a)
	       (let/ecx 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)
       (with-syntax ((x (replace_ xx #'x)))
          #'(if (pair? a)
		(let/ecx break-ret
                   (let lp ((l a))
		     (if (pair? l)
			 (begin
			   (let/ecx 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)
       (with-syntax ((x (replace_ xx #'x)))
          #'(if (pair? a)
		(let/ecx 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)
       (with-syntax ((x (replace_ xx #'x)))
          #'(if (pair? a)
		(let/ecx break-ret
		   (let lp ((l a))
		     (if (pair? l)
			 (let/ecx 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 (zz)
    (syntax-case zz ()
      ((_ (xy ...) (in) code #f #f)
       (with-syntax* ((inv      (gentemp #'in))
		      ((yy ...) (replace_ zz #'(xy ...)))
		      ((xx ...) (gen-temp #'(yy ...))))
	#'(let ((inv (wrap-in in)))
	    (clet (yy ...)
             (catch StopIteration
               (lambda ()
                 (let lp ()
                   (call-with-values (lambda () (next inv))
                     (clambda (xx ...)
                       (cset! yy xx) ... 
                       (with-sp ((break    (values))
                                 (continue (values)))
                                code
                                (lp))))))
               (lambda z (values)))))))

      ((_ (xy ...) (in ...) code #f #f)
       (with-syntax* (((inv ...) (generate-temporaries #'(in ...)))
		      ((yy  ...) (replace_ zz #'(xy ...)))
		      ((xx  ...) (gen-temp #'(yy ...))))
         #'(let ((inv (wrap-in in)) ...)
	     (clet (yy ...)
             (catch StopIteration
               (lambda ()
                 (let lp ()
                   (call-with-values (lambda () (values (next inv) ...))
                     (clambda (xx ...)
                       (cset! yy xx) ...
                       (with-sp ((break    (values))
                                 (continue (values)))
                                code
                                (lp))))))
               (lambda z (values)))))))

      ((_ (xy ...) (in) code #f #t)
       (with-syntax* ((inv       (gentemp #'in))
		      ((yy  ...) (replace_ zz #'(xy ...)))
		      ((xx  ...) (gen-temp #'(yy ...))))
	#'(let ((inv (wrap-in in)))
	    (clet (yy ...)
              (let lp ()
                (let/ecx break-ret
                  (catch StopIteration
                    (lambda ()
                      (call-with-values (lambda () (next inv))
                        (clambda (xx ...)
                          (cset! yy xx) ...
                          (let/ecx continue-ret
                            (with-sp ((break     (break-ret))
                                      (continue  (continue-ret)))
                                     code))
                          (lp))))
                    (lambda z (values)))))))))

      ((_ (xy ...) (in ...) code #f #t)
       (with-syntax* (((inv ...) (generate-temporaries #'(in ...)))
		      ((yy  ...) (replace_ zz #'(xy ...)))
		      ((xx  ...) (gen-temp #'(yy ...))))
	 #'(let ((inv (wrap-in in)) ...)
	     (clet (yy ...)
              (let lp ()
                (let/ecx break-ret
                  (catch StopIteration
                    (lambda ()
                      (call-with-values (lambda () (values (next inv) ...))
                        (clambda (xx ...)
                          (cset! yy xx) ...
                          (let/ecx 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 (zz)
    (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 zz ()
      ((_ (xy ...) (in) code else p)
       (with-syntax* ((inv (gentemp #'in))
		      ((yy ...) (replace_ zz #'(xy ...)))
		      ((xx ...) (gen-temp #'(yy ...))))
				  
           (if (syntax->datum #'p)
               #'(let ((inv (wrap-in in)))
                   (clet (yy ...)
                     (let/ecx break-ret
                       (catch StopIteration
                         (lambda ()
                           (let lp ()
                             (call-with-values (lambda () (next inv))
                               (clambda (xx ...)
                                 (cset! yy xx) ...
                                 (let/ecx continue-ret
                                   (with-sp ((break     (break-ret))
                                             (continue  (continue-ret)))
                                            code))
                                 (lp)))))
                         (lambda q else)))))
             
                   #'(let ((inv (wrap-in in)))
                       (clet (yy ...)
                             (let/ecx break-ret
                               (catch StopIteration
                                 (lambda ()
                                   (let lp ()
                                     (call-with-values (lambda () (next inv))
                                       (clambda (xx ...)
                                                (cset! yy xx) ...
                                         (with-sp ((break     (break-ret))
                                                   (continue  (values)))
                                                  code)
                                         (lp)))))
                                 (lambda e else))))))))
      
      ((_ (xy ...) (in ...) code else p)
       (with-syntax* (((inv ...) (generate-temporaries #'(in ...)))
		      ((yy  ...) (replace_ zz #'(xy ...)))
		      (get       (gen #'(inv ...) #'(yy ...)))
		      ((xx ...)  (gen-temp #'(yy ...))))
         (if (syntax->datum #'p)
             #'(clet (yy ...)
                 (let ((inv (wrap-in in)) ...)               
                   (let/ecz break-ret
                     (catch StopIteration
                       (lambda ()
                         (let lp ()
                           (call-with-values (lambda () get)
                             (clambda (xx ...)
                               (cset! yy xx) ...
                               (let/ecx continue-ret
                                 (with-sp ((break     (break-ret))
                                           (continue  (continue-ret)))
                                          code))
                               (lp)))))
                       (lambda q else)))))
             
                 #'(clet (yy ...)
                     (let ((inv (wrap-in in)) ...)
                       (let/ecx break-ret
                         (catch StopIteration
                           (lambda ()
                             (let lp ()
                               (call-with-values (lambda () get)
                                 (clambda (xx ...)
                                   (cset! yy xx) ...
                                   (with-sp ((break     (break-ret))
                                             (continue  (values)))
                                            code)
                                   (lp)))))
                           (lambda e else)))))))))))

(define-syntax cset!
  (syntax-rules ()
    ((_ (a . aa) (b . bb))
     (begin
       (cset! a  b)
       (cset! aa bb)))
    ((_ () ())
     (values))
    ((_ a b)
     (set! a b))))

(define-syntax clet
  (syntax-rules ()
    ((_ ((a . l) . u) . code)
     (clet (a l . u) . code))
    ((_ (() . u) . code)
     (clet u . code))    
    ((_ (a . u) . code)
     (let ((a #f))
       (clet u . code)))
    ((_ () . code)
     (begin . code))))
    
(define-syntax def-wrap
  (lambda (x)
    (syntax-case x ()
      ((_ #f f ab x)
       #'x)
      
      ((_ #t f ab code)
       #'(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/ecx 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 o k x)
  (if (eq? x miss)
      (raise (AttributeError (cons o k)))
      x))

(define-syntax ref-x
  (lambda (x)
    (syntax-case x (@)
      ((_ v)
       #'v)
      ((_ v (#:fastfkn-ref f tag) . l)
       #'(let ((vv v))
           (if (is-a? vv <p>)
               (ref-x v (#:identifier tag) . 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 ((@ x q) dict)) . l)
       (equal? (syntax->datum #'dict) '__dict__)
       #'(ref-x (py-dict v) . l))
            
      ((_ v (#:identifier x) . l)
       #'(ref-x (wr v 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 (#: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 v 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 (#:array-ref n ...) val)
     (pylist-set! v (list 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 eq? equal? 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))
    ((_ (eq?    x y)) (eq? x y))
    ((_ (equal? x y)) (equal? x y))

    ((_ ((@ (guile) eq?   ) x y))    (eq? x y))
    ((_ ((@ (guile) equal?) x y)) (equal? x y))
    ((_ ((@ (guile) and   ) x y))    (and (boolit x) (boolit y)))
    ((_ ((@ (guile) or    ) x y))    (or  (boolit x) (boolit y)))
    ((_ ((@ (guile) not   ) x  ))    (not (boolit x)))
    ((_ ((@ (guile) <     ) x y))    (<  x y))
    ((_ ((@ (guile) <=    ) x y))    (<= x y))
    ((_ ((@ (guile) >     ) x y))    (>  x y))
    ((_ ((@ (guile) >=    ) x y))    (>= x y))
    ((_ #t) #t)
    ((_ #f) #f)
    ((_ x ) (bool x))))

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

(define (pkkk x)
  (pk (syntax->datum x))
  x)

(define (get-q-n x)
  (syntax-case x ()
    ((cons a b)
     (+ 1 (get-q-n #'b)))
    ((q ())
     0)))

(define (take-n n v)
  (let lp ((i 0) (v (reverse v)) (r '()))
    (if (< i n)
        (if (pair? v)
            (lp (+ i 1) (cdr v) (cons (car v) r))
            (raise (ValueError "wrone number of values in values")))
        (cons
         (reverse v)
         r))))
        
(define-syntax qset!
  (lambda (x)
    (syntax-case x (@@ @)
      ((_ (cons (#:star x) y) v)
       (let ((n (get-q-n #'y)))
         #`(let* ((h.r (take-n #,n v))
                  (h   (car h.r))
                  (r   (cdr h.r)))
             (qset! x h)
             (qset0! y r))))
      
      ((_ (cons x y) v)
       (equal? (syntax->datum #'cons) '(@ (guile) cons))
       #'(let ((w (to-list v)))
           (qset!  x (car w))
           (qset0! y (cdr w))))
      
      ((_ ((@ (guile) q) ()) v)
       (equal? (syntax->datum #'q) 'quote)
       #'(if (not (null? v))
             (raise (ValueError "too many values to unpack"))
             (values)))

      ((_ ((@@ u li) x) v)
       (equal? (syntax->datum #'li) 'to-pylist)
       #'(let ((w (to-list v)))
	   (qset! x w)))
      
      ((_ (ref v a ...) w)
       #'(set-x v (a ...) w))
            
      ((_  x  v)
       #'(set! x v)))))

(define-syntax qset0!
  (lambda (x)
    (syntax-case x (@@ @)
      ((_ (cons (#:star x) y) v)
       (let ((n (get-q-n #'y)))
         #`(let* ((h.r (take-n v #,n))
                  (h   (car h.r))
                  (r   (cdr h.r)))
             (qset! x h)
             (qset0! y r))))

      ((_ (cons x y) v)
       (equal? (syntax->datum #'cons) '(@ (guile) cons))
       #'(let ((w v))
           (qset!  x (car w))
           (qset0! y (cdr w))))
      
      ((_ ((@ (guile) q) ()) v)
       (equal? (syntax->datum #'q) 'quote)
       #'(if (not (null? v))
             (raise (ValueError "too many values to unpack"))
             (values)))

      ((_ ((@@ u li) x) v)
       (equal? (syntax->datum #'li) 'to-pylist)
       #'(let ((w (to-list v)))
	   (qset! x w)))
      
      ((_ (ref v a ...) w)
       #'(set-x v (a ...) w))
            
      ((_  x  v)
       #'(set! x v)))))

(define-syntax define-
  (syntax-rules (cons quote)
    ((_ (cons x y) v)
     (let ((w v))
       (define- x (car w))
       (define- y (cdr w))))
    ((_ '() v) (values))
    ((_  x  v)
     (define! 'x v))))

(define-syntax pks
  (lambda (x)
    (pk (syntax->datum x))
    #f))