;;============================================================================

;;; File: "_t-univ-1.scm"

;;; Copyright (c) 2011-2016 by Marc Feeley, All Rights Reserved.
;;; Copyright (c) 2012 by Eric Thivierge, All Rights Reserved.

(include "generic.scm")

(include-adt "_envadt.scm")
(include-adt "_gvmadt.scm")
(include-adt "_ptreeadt.scm")
(include-adt "_sourceadt.scm")
(include-adt "_univadt.scm")

;;----------------------------------------------------------------------------

(define deb #t)
(set! deb #f)
(define (tt tag . stuff) (if deb (list "/*{" tag "*/" stuff "/*}*/") stuff));;;;;;;;;;;;;;;;;;;;

(define univ-enable-jump-destination-inlining? #f)
(set! univ-enable-jump-destination-inlining? #t)

(define univ-dyn-load? #f)
(set! univ-dyn-load? #f)

(define (univ-get-semantics-changing-option ctx name)
  (let ((x (assq name (ctx-semantics-changing-options ctx))))
    (and x (pair? (cdr x)) (cadr x))))

(define (univ-module-representation ctx)
  (or (univ-get-semantics-changing-option ctx 'repr-module)
      (case (target-name (ctx-target ctx))
        ((java)
         'class)
        (else
         'global))))

(define (univ-procedure-representation ctx)
  (or (univ-get-semantics-changing-option ctx 'repr-procedure)
      (case (target-name (ctx-target ctx))
        ((java)
         'class)
        ((php)
         (if (univ-php-pre53? ctx)
             'class
             'host))
        (else
         'host))))

(define (univ-frame-representation ctx)
  (or (univ-get-semantics-changing-option ctx 'repr-frame)
      (case (target-name (ctx-target ctx))
        ((java)
         'class)
        (else
         'host))))

(define (univ-null-representation ctx)
  (or (univ-get-semantics-changing-option ctx 'repr-null)
      (case (target-name (ctx-target ctx))
        ((js)
         'host)
        (else
         'class))))

(define (univ-void-representation ctx)
  (or (univ-get-semantics-changing-option ctx 'repr-void)
      'host))

(define (univ-eof-representation ctx)
  'class)

(define (univ-absent-representation ctx)
  'class)

(define (univ-unbound-representation ctx)
  'class)

(define (univ-optional-representation ctx)
  'class)

(define (univ-key-representation ctx)
  'class)

(define (univ-rest-representation ctx)
  'class)

(define (univ-boolean-representation ctx)
  (or (univ-get-semantics-changing-option ctx 'repr-boolean)
      (case (target-name (ctx-target ctx))
        ((java)
         'class)
        (else
         'host))))

(define (univ-char-representation ctx)
  'class)

(define (univ-fixnum-representation ctx)
  (or (univ-get-semantics-changing-option ctx 'repr-fixnum)
      (case (target-name (ctx-target ctx))
        ((java)
         'class)
        (else
         'host))))

(define (univ-flonum-representation ctx)
  (or (univ-get-semantics-changing-option ctx 'repr-flonum)
      'class))

(define (univ-vector-representation ctx)
  (or (univ-get-semantics-changing-option ctx 'repr-vector)
      (case (target-name (ctx-target ctx))
        ((php java)
         'class)
        (else
         'host))))

(define (univ-values-representation ctx)
  (or (univ-get-semantics-changing-option ctx 'repr-values)
      'class))

(define (univ-u8vector-representation ctx)
  'class)

(define (univ-u16vector-representation ctx)
  'class)

(define (univ-u32vector-representation ctx)
  'class)

(define (univ-u64vector-representation ctx)
  'class)

(define (univ-s8vector-representation ctx)
  'class)

(define (univ-s16vector-representation ctx)
  'class)

(define (univ-s32vector-representation ctx)
  'class)

(define (univ-s64vector-representation ctx)
  'class)

(define (univ-f32vector-representation ctx)
  'class)

(define (univ-f64vector-representation ctx)
  'class)

(define (univ-structure-representation ctx)
  'class)

(define (univ-string-representation ctx)
  (or (univ-get-semantics-changing-option ctx 'repr-string)
      'class))

(define (univ-symbol-representation ctx)
  (or (univ-get-semantics-changing-option ctx 'repr-symbol)
      'class))

(define (univ-keyword-representation ctx)
  'class)

(define (univ-tostr-method-name ctx)
  (case (target-name (ctx-target ctx))

    ((js java)
     'toString)

    ((php)
     '__toString)

    ((python)
     '__str__)

    ((ruby)
     'to_s)

    (else
     (compiler-internal-error
      "univ-tostr-method-name, unknown target"))))

(define (univ-proc-name-attrib ctx)
  (case (target-name (ctx-target ctx))

    ((js)
     '_name) ;; avoid clash with builtin "name" attribute of functions

    (else
     'name)))

(define (univ-ns-prefix sem-changing-options)
  (let ((x (assq 'namespace sem-changing-options)))
    (or (and x (pair? (cdr x)) (cadr x))
        "g_")))

(define (univ-ns-prefix-class sem-changing-options)
  (let ((ns (univ-ns-prefix sem-changing-options)))
    (if (= (string-length ns) 0)
        ns
        (let ((lst (string->list ns)))
          (list->string (cons (char-upcase (car lst)) (cdr lst)))))))

(define univ-thread-cont-slot 5)
(define univ-thread-denv-slot 6)

(define (univ-php-pre53? ctx)
  (assq 'pre53 (ctx-semantics-changing-options ctx)))

(define (univ-python-pre3? ctx)
  (assq 'pre3 (ctx-semantics-changing-options ctx)))

(define (univ-java-pre7? ctx)
  (assq 'pre7 (ctx-semantics-changing-options ctx)))

(define (univ-always-return-jump? ctx)
  (assq 'always-return-jump (ctx-semantics-preserving-options ctx)))

(define (univ-never-return-jump? ctx)
  (assq 'never-return-jump (ctx-semantics-preserving-options ctx)))

(define (univ-stack-resizable? ctx)
  (case (target-name (ctx-target ctx))
    ((java) #f)
    (else   #t)))

(define univ-tag-bits 2)
(define univ-word-bits 32)

(define univ-fixnum-max+1
  (arithmetic-shift 1 (- univ-word-bits (+ 1 univ-tag-bits))))

(define univ-fixnum-max (- univ-fixnum-max+1 1))
(define univ-fixnum-min (- -1 univ-fixnum-max))
(define univ-fixnum-max*2+1 (+ (* univ-fixnum-max 2) 1))

;;;----------------------------------------------------------------------------
;;
;; "Universal" back-end.

;; Initialization/finalization of back-end.

(define (univ-setup
         target-language
         file-extensions
         semantics-changing-options
         semantics-preserving-options)

  (define common-semantics-changing-options
    '((repr-module    symbol)
      (repr-procedure symbol)
      (repr-frame     symbol)
      (repr-null      symbol)
      (repr-void      symbol)
      (repr-boolean   symbol)
      (repr-fixnum    symbol)
      (repr-flonum    symbol)
      (repr-vector    symbol)
      (repr-values    symbol)
      (repr-string    symbol)
      (repr-symbol    symbol)
      (namespace      string)))

  (define common-semantics-preserving-options
    '((always-return-jump)
      (never-return-jump)))

  (let* ((sem-changing-options
          (append common-semantics-changing-options
                  semantics-changing-options))
         (targ
          (make-target 11
                       target-language
                       file-extensions
                       (append sem-changing-options
                               common-semantics-preserving-options
                               semantics-preserving-options)
                       0)))

    (define (begin! info-port)

      (target-dump-set!
       targ
       (lambda (procs output c-intf module-descr unique-name options)
         (let* ((sem-changing-opts
                 (append-lists
                  (map (lambda (o)
                         (let ((x (assq (car o) options)))
                           (if x (list x) '())))
                       sem-changing-options)))
                (sem-preserving-opts
                 (append-lists
                  (map (lambda (o)
                         (let ((x (assq (car o) sem-changing-options)))
                           (if x '() (list o))))
                       options))))
           (univ-dump targ procs output c-intf module-descr unique-name sem-changing-opts sem-preserving-opts))))

      (target-link-info-set!
       targ
       (lambda (file)
         (univ-link-info targ file)))

      (target-link-set!
       targ
       (lambda (extension? inputs output warnings?)
         (univ-link targ extension? inputs output warnings?)))

      (target-nb-regs-set! targ univ-nb-gvm-regs)

      (target-prim-info-set!
       targ
       (lambda (name)
         (univ-prim-info targ name)))

      (target-label-info-set!
       targ
       (lambda (nb-parms closed?)
         (univ-label-info targ nb-parms closed?)))

      (target-jump-info-set!
       targ
       (lambda (nb-args)
         (univ-jump-info targ nb-args)))

      (target-frame-constraints-set!
       targ
       (make-frame-constraints univ-frame-reserve univ-frame-alignment))

      (target-proc-result-set!
       targ
       (make-reg 1))

      (target-task-return-set!
       targ
       (make-reg 0))

      (target-switch-testable?-set!
       targ
       (lambda (obj)
         (univ-switch-testable? targ obj)))

      (target-eq-testable?-set!
       targ
       (lambda (obj)
         (univ-eq-testable? targ obj)))

      (target-object-type-set!
       targ
       (lambda (obj)
         (univ-object-type targ obj)))

      #f)

    (define (end!)
      #f)

    (target-begin!-set! targ begin!)
    (target-end!-set! targ end!)
    (target-add targ)))

(univ-setup 'js     '((".js"   . JavaScript))  '()        '())
(univ-setup 'python '((".py"   . Python))      '((pre3))  '())
(univ-setup 'ruby   '((".rb"   . Ruby))        '()        '())
(univ-setup 'php    '((".php"  . PHP))         '((pre53)) '())

(univ-setup 'java   '((".java" . Java))        '((pre7))  '())
;;(univ-setup 'c      '((".c"    . C))           '()       '())
;;(univ-setup 'c++    '((".cc"   . C++))         '()       '())
;;(univ-setup 'objc   '((".m"    . Objective-C)) '()       '())

;;;----------------------------------------------------------------------------

;; Generation of textual target code.

(define (univ-indent . rest)
  (cons '$$indent$$ rest))

(define (univ-constant val)
  (univ-box val val))

(define (univ-box boxed unboxed)
  (list '$$box$$ boxed unboxed))

(define (univ-box? x)
  (and (pair? x)
       (eq? (car x) '$$box$$)))

(define (univ-unbox x)
  (and (univ-box? x)
       (cddr x)))

(define (univ-display x port)

  (define indent-level 0)
  (define after-newline? #t)

  (define (indent)
    (if after-newline?
        (begin
          (display (make-string (* 2 indent-level) #\space) port)
          (set! after-newline? #f))))

  (define (disp x)

    (cond ((string? x)
           (let loop1 ((i 0))
             (let loop2 ((j i))

               (define (display-substring limit)
                 (if (< i limit)
                     (begin
                       (if (or (> (- limit i) 1)
                               (not (char=? (string-ref x (- limit 1))
                                            #\newline)))
                           (indent))
                       (if (and (= i 0) (= limit (string-length x)))
                           (display x port)
                           (display (substring x i limit) port)))))

               (if (< j (string-length x))

                   (let ((c (string-ref x j))
                         (j+1 (+ j 1)))
                       (if (char=? c #\newline)
                           (begin
                             (display-substring j+1)
                             (set! after-newline? #t)
                             (loop1 j+1))
                           (loop2 j+1)))

                   (display-substring j)))))

          ((symbol? x)
           (disp (symbol->string x)))

          ((char? x)
           (disp (string x)))

          ((null? x))

          ((pair? x)
           (case (car x)
             (($$indent$$)
              (set! indent-level (+ indent-level 1))
              (disp (cdr x))
              (set! indent-level (- indent-level 1)))
             (($$box$$)
              (disp (cadr x)))
             (else
              (disp (car x))
              (disp (cdr x)))))

          ((vector? x)
           (disp (vector->list x)))

          (else
           (indent)
           (display x port))))

   (disp x))

;;;----------------------------------------------------------------------------

;; ***** PROCEDURE CALLING CONVENTION

(define univ-nb-gvm-regs 5)
(define univ-nb-arg-regs 3)

(define (univ-label-info targ nb-parms closed?)

;; After a GVM "entry-point" or "closure-entry-point" label, the following
;; is true:
;;
;;  * return address is in GVM register 0
;;
;;  * if nb-parms <= nb-arg-regs
;;
;;      then parameter N is in GVM register N
;;
;;      else parameter N is in
;;               GVM register N-F, if N > F
;;               GVM stack slot N, if N <= F
;;           where F = nb-parms - nb-arg-regs
;;
;;  * for a "closure-entry-point" GVM register nb-arg-regs+1 contains
;;    a pointer to the closure object
;;
;;  * other GVM registers contain an unspecified value

  (let ((nb-stacked (max 0 (- nb-parms univ-nb-arg-regs))))

    (define (location-of-parms i)
      (if (> i nb-parms)
          '()
          (cons (cons i
                      (if (> i nb-stacked)
                          (make-reg (- i nb-stacked))
                          (make-stk i)))
                (location-of-parms (+ i 1)))))

    (let ((x (cons (cons 'return 0) (location-of-parms 1))))
      (make-pcontext nb-stacked
                     (if closed?
                         (cons (cons 'closure-env
                                     (make-reg (+ univ-nb-arg-regs 1)))
                               x)
                         x)))))

(define (univ-jump-info targ nb-args)

;; After a GVM "jump" instruction with argument count, the following
;; is true:
;;
;;  * the return address is in GVM register 0
;;
;;  * if nb-args <= nb-arg-regs
;;
;;      then argument N is in GVM register N
;;
;;      else argument N is in
;;               GVM register N-F, if N > F
;;               GVM stack slot N, if N <= F
;;           where F = nb-args - nb-arg-regs
;;
;;  * GVM register nb-arg-regs+1 contains a pointer to the closure object
;;    if a closure is being jumped to
;;
;;  * other GVM registers contain an unspecified value

  (let ((nb-stacked (max 0 (- nb-args univ-nb-arg-regs))))

    (define (location-of-args i)
      (if (> i nb-args)
          '()
          (cons (cons i
                      (if (> i nb-stacked)
                          (make-reg (- i nb-stacked))
                          (make-stk i)))
                (location-of-args (+ i 1)))))

    (make-pcontext nb-stacked
                   (cons (cons 'return (make-reg 0))
                         (location-of-args 1)))))

;; The frame constraints are defined by the parameters
;; univ-frame-reserve and univ-frame-alignment.

(define univ-frame-reserve 0) ;; no extra slots reserved
(define univ-frame-alignment 1) ;; no alignment constraint

;; ***** PRIMITIVE PROCEDURE DATABASE

(define (univ-prim-info targ name)
  (univ-prim-info* name))

(define (univ-prim-info* name)
  (table-ref univ-prim-proc-table name #f))

(define univ-prim-proc-table (make-table))

(define (univ-prim-proc-add! x)
  (let ((name (string->canonical-symbol (car x))))
    (table-set! univ-prim-proc-table
                name
                (apply make-proc-obj (car x) #f #t #f (cdr x)))))

(for-each univ-prim-proc-add! prim-procs)

(univ-prim-proc-add! '("##inline-host-statement" 1 #t 0 0 (#f) extended))
(univ-prim-proc-add! '("##inline-host-expression" 1 #t 0 0 (#f) extended))
(univ-prim-proc-add! '("##inline-host-declaration" (1) #t 0 0 (#f) extended))

(define (univ-switch-testable? targ obj)
  ;;(pretty-print (list 'univ-switch-testable? 'targ obj))
  #f);;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (univ-eq-testable? targ obj)
  ;;(pretty-print (list 'univ-eq-testable? 'targ obj))
  #f);;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (univ-object-type targ obj)
  ;;(pretty-print (list 'univ-object-type 'targ obj))
  'bignum);;;;;;;;;;;;;;;;;;;;;;;;;

(define (univ-emit-popcount! ctx arg)

  (define (popcount arg acc len)
    (if (>= len univ-word-bits)
        (^ acc
           (^assign arg (^bitand arg (^int #x0000003F))))
        (popcount
         arg
         (^ acc
            (case len
             ((1)
              (^assign arg (^- arg
                               (^parens (^bitand (^parens (^>> arg (^int 1)))
                                                 (^int #x55555555))))))
             ((2)
              (^assign arg (^+ (^parens (^bitand arg (^int #x33333333)))
                               (^parens (^bitand (^parens (^>> arg (^int 2)))
                                                 (^int #x33333333))))))
             ((4)
              (^assign arg (^bitand (^parens (^+ arg (^parens (^>> arg (^int 4)))))
                                    (^int #x0F0F0F0F))))
             (else
              (^assign arg (^+ arg (^parens (^>> arg len)))))))
         (* len 2))))

  (popcount arg
            (^assign arg (^bitand arg (^int univ-fixnum-max*2+1)))
            1))

(define (univ-emit-map ctx fn array)
  (case (target-name (ctx-target ctx))

    ((js)
     (^ array ".map( " fn " )"))

    ((php)
     (^ "array_map( '" fn "', " array ")"))

    ((python)
     (^ "map( "fn ", " array " )"))

    ((ruby)
     (^ array ".map { |x| " fn "(x) } " ))

    (else
     (compiler-internal-error
      "univ-emit-map, unknown target"))))

(define (univ-emit-call-with-arg-array ctx fn array)
  (case (target-name (ctx-target ctx))

    ((js)
     (^ fn ".apply( null, " array " )"))

    ((php)
     (^ "call_user_func_array( " fn ", " array " )"))

    ((python)
     (^ fn "( *" array " )"))

    ((ruby)
     (^ fn ".( *" array " )"))

    (else
     (compiler-internal-error
      "univ-emit-call-with-arg-array, unknown target"))))

(define (univ-emit-var-declaration ctx type name #!optional (init #f))
  (case (target-name (ctx-target ctx))

    ((js)
     (^ "var " name (if init (^ " = " init) (^)) ";\n"))

    ((python ruby)
     (^ name " = " (or init (^obj #f)) "\n"))

    ((php)
     (^ name " = " (or init (^obj #f)) ";\n"))

    ((java)
     (^ (^decl type name) (if init (^ " = " init) (^)) ";\n"))

    (else
     (compiler-internal-error
      "univ-emit-var-declaration, unknown target"))))

(define (univ-emit-expr-statement ctx expr)
  (case (target-name (ctx-target ctx))

    ((js php java)
     (^ expr ";\n"))

    ((python ruby)
     (^ expr "\n"))

    (else
     (compiler-internal-error
      "univ-emit-expr-statement, unknown target"))))

(define (univ-emit-if ctx test true #!optional (false #f))
  (case (target-name (ctx-target ctx))

    ((js php java)
     (^ "if (" test ") {\n"
        (univ-indent true)
        (if false
            (^ "} else {\n"
               (univ-indent false))
            (^))
        "}\n"))

    ((python)
     (^ "if " test ":\n"
        (univ-indent true)
        (if false
            (^ "else:\n"
                  (univ-indent false))
            (^))))

    ((ruby)
     (^ "if " test "\n"
        (univ-indent true)
        (if false
            (^ "else\n"
               (univ-indent false))
            (^))
        "end\n"))

    (else
     (compiler-internal-error
      "univ-emit-if, unknown target"))))

(define (univ-emit-if-expr ctx expr1 expr2 expr3)
  (case (target-name (ctx-target ctx))

    ((js ruby java)
     (^ expr1 " ? " expr2 " : " expr3))

    ((php)
     (^parens (^ expr1 " ? " expr2 " : " expr3)))

    ((python)
     (^ expr2 " if " expr1 " else " expr3))

    (else
     (compiler-internal-error
      "univ-emit-if-expr, unknown target"))))

(define (univ-emit-while ctx test body)
  (case (target-name (ctx-target ctx))

    ((js php java)
     (^ "while (" test ") {\n"
        (univ-indent body)
        "}\n"))

    ((python)
     (^ "while " test ":\n"
        (univ-indent body)))

    ((ruby)
     (^ "while " test "\n"
        (univ-indent body)
        "end\n"))

    (else
     (compiler-internal-error
      "univ-emit-while, unknown target"))))

(define (univ-emit-eq? ctx expr1 expr2)
  (case (target-name (ctx-target ctx))

    ((js php)
     (^ expr1 " === " expr2))

    ((python)
     (^ expr1 " is " expr2))

    ((ruby)
     (^ expr1 ".equal?(" expr2 ")"))

    ((java)
     (^ expr1 " == " expr2))

    (else
     (compiler-internal-error
      "univ-emit-eq?, unknown target"))))

(define (univ-emit-+ ctx expr1 #!optional (expr2 #f))
  (case (target-name (ctx-target ctx))

    ((js php python ruby java)
     (if expr2
         (^ expr1 " + " expr2)
         (^ "+ " expr1)))

    (else
     (compiler-internal-error
      "univ-emit-+, unknown target"))))

(define (univ-emit-- ctx expr1 #!optional (expr2 #f))
  (case (target-name (ctx-target ctx))

    ((js php python ruby java)
     (if expr2
         (^ expr1 " - " expr2)
         (^ "- " expr1)))

    (else
     (compiler-internal-error
      "univ-emit--, unknown target"))))

(define (univ-emit-* ctx expr1 expr2)
  (case (target-name (ctx-target ctx))

    ((js php python ruby java)
     (^ expr1 " * " expr2))

    (else
     (compiler-internal-error
      "univ-emit-*, unknown target"))))

(define (univ-emit-/ ctx expr1 expr2)
  (case (target-name (ctx-target ctx))

    ((js php python ruby java)
     (^ expr1 " / " expr2))

    (else
     (compiler-internal-error
      "univ-emit-/, unknown target"))))

(define (univ-wrap ctx expr)
  (case (target-name (ctx-target ctx))

    ((js java)
     (^>> (^<< (^parens expr)
               (^int univ-tag-bits))
          (^int univ-tag-bits)))

    ((python)
     (^>> (^member (^call-prim
                    "ctypes.c_int32"
                    (^<< (^parens expr)
                         (^int univ-tag-bits)))
                   'value)
          (^int univ-tag-bits)))

    ((ruby php)
     (^- (^parens (^bitand (^parens (^+ (^parens expr)
                                        (^int univ-fixnum-max+1)))
                           (^int univ-fixnum-max*2+1)))
         (^int univ-fixnum-max+1)))

    (else
     (compiler-internal-error
      "univ-wrap, unknown target"))))

(define (univ-wrap+ ctx expr1 expr2)
  (univ-wrap ctx (^+ expr1 expr2)))

(define (univ-wrap- ctx expr1 #!optional (expr2 #f))
  (univ-wrap ctx (if expr2
                     (^- expr1 expr2)
                     (^- expr1))))

(define (univ-wrap* ctx expr1 expr2)
  (case (target-name (ctx-target ctx))

    ((js)
     (univ-wrap ctx
                (^+ (^* (^parens (^bitand expr1 #xffff))
                        expr2)
                    (^* (^parens (^bitand expr1 #xffff0000))
                        (^parens (^bitand expr2 #xffff))))))

    ((php python ruby java)
     (univ-wrap ctx (^* expr1 expr2)))

    (else
     (compiler-internal-error
      "univ-wrap*, unknown target"))))

(define (univ-wrap/ ctx expr1 expr2)
  (case (target-name (ctx-target ctx))
   ((python php)
    ;; Needed because php and python always round down (should round toward 0).
    (univ-wrap ctx (^float-toint (^/ expr1 (^float-fromint expr2)))))
   (else (univ-wrap ctx (^/ expr1 expr2)))))

(define (univ-emit-<< ctx expr1 expr2)
  (case (target-name (ctx-target ctx))

    ((js php python ruby java)
     (^ expr1 " << " expr2))

    (else
     (compiler-internal-error
      "univ-emit-<<, unknown target"))))

(define (univ-emit->> ctx expr1 expr2)
  (case (target-name (ctx-target ctx))

    ((js php python ruby java)
     (^ expr1 " >> " expr2))

    (else
     (compiler-internal-error
      "univ-emit->>, unknown target"))))

(define (univ-emit->>> ctx expr1 expr2)
  (case (target-name (ctx-target ctx))

    ((js java)
     (^ expr1 " >>> " expr2))

    (else
     (compiler-internal-error
      "univ-emit->>>, unknown target"))))

(define (univ-emit-bitnot ctx expr)
  (case (target-name (ctx-target ctx))

    ((js php python ruby java)
     (^ "~ " expr))

    (else
     (compiler-internal-error
      "univ-emit-bitnot, unknown target"))))

(define (univ-emit-bitand ctx expr1 expr2)
  (case (target-name (ctx-target ctx))

    ((js php python ruby java)
     (^ expr1 " & " expr2))

    (else
     (compiler-internal-error
      "univ-emit-bitand, unknown target"))))

(define (univ-emit-bitior ctx expr1 expr2)
  (case (target-name (ctx-target ctx))

    ((js php python ruby java)
     (^ expr1 " | " expr2))

    (else
     (compiler-internal-error
      "univ-emit-bitior, unknown target"))))

(define (univ-emit-bitxor ctx expr1 expr2)
  (case (target-name (ctx-target ctx))

    ((js php python ruby java)
     (^ expr1 " ^ " expr2))

    (else
     (compiler-internal-error
      "univ-emit-bitxor, unknown target"))))

(define (univ-emit-= ctx expr1 expr2)
  (case (target-name (ctx-target ctx))

    ((js)
     (^ expr1 " === " expr2))

    ((python ruby php java)
     (^ expr1 " == " expr2))

    (else
     (compiler-internal-error
      "univ-emit-=, unknown target"))))

(define (univ-emit-!= ctx expr1 expr2)
  (case (target-name (ctx-target ctx))

    ((js)
     (^ expr1 " !== " expr2))

    ((python ruby php java)
     (^ expr1 " != " expr2))

    (else
     (compiler-internal-error
      "univ-emit-!=, unknown target"))))

(define (univ-emit-< ctx expr1 expr2)
  (univ-emit-comparison ctx " < " expr1 expr2))

(define (univ-emit-<= ctx expr1 expr2)
  (univ-emit-comparison ctx " <= " expr1 expr2))

(define (univ-emit-> ctx expr1 expr2)
  (univ-emit-comparison ctx " > " expr1 expr2))

(define (univ-emit->= ctx expr1 expr2)
  (univ-emit-comparison ctx " >= " expr1 expr2))

(define (univ-emit-comparison ctx comp expr1 expr2)
  (case (target-name (ctx-target ctx))

    ((js python ruby php java)
     (^ expr1 comp expr2))

    (else
     (compiler-internal-error
      "univ-emit-comparison, unknown target"))))

(define (univ-emit-not ctx expr)
  (case (target-name (ctx-target ctx))

    ((js php ruby java)
     (^ "!" expr))

    ((python)
     (^ "not " expr))

    (else
     (compiler-internal-error
      "univ-emit-not, unknown target"))))

(define (univ-emit-&& ctx expr1 expr2)
  (case (target-name (ctx-target ctx))

    ((js ruby php java)
     (^ expr1 " && " expr2))

    ((python)
     (^ expr1 " and " expr2))

    (else
     (compiler-internal-error
      "univ-emit-&&, unknown target"))))

(define (univ-emit-and ctx expr1 expr2)
  (case (target-name (ctx-target ctx))

    ((js ruby java)
     (^ expr1 " && " expr2))

    ((python)
     (^ expr1 " and " expr2))

    ((php)
     (^ expr1 " ? " expr2 " : false"))

    (else
     (compiler-internal-error
      "univ-emit-and, unknown target"))))

(define (univ-emit-or ctx expr1 expr2)
  (case (target-name (ctx-target ctx))

    ((js ruby php java)
     (^ expr1 " || " expr2)) ;; TODO: PHP || operator always yields a boolean

    ((python)
     (^ expr1 " or " expr2))

    (else
     (compiler-internal-error
      "univ-emit-or, unknown target"))))

(define (univ-emit-concat ctx expr1 expr2)
  (case (target-name (ctx-target ctx))

    ((js python ruby java)
     (^ expr1 " + " expr2))

    ((php)
     (^ expr1 " . " expr2))

    (else
     (compiler-internal-error
      "univ-emit-concat, unknown target"))))

(define (univ-emit-tostr ctx expr)
  (case (target-name (ctx-target ctx))

    ((js java)
     (^ expr ".toString()"))

    ((python)
     (^ "str(" expr ")"))

    ((php)
     (^ "(string)" expr))

    ((ruby)
     (^ expr ".to_s"))

    (else
     (compiler-internal-error
      "univ-emit-tostr, unknown target"))))

(define (univ-emit-cast ctx type expr)
  (^parens (^ (^parens type) (^parens expr))))

(define (univ-emit-cast* ctx type-name expr)
  (case (target-name (ctx-target ctx))
    ((java)
     (^cast (^type type-name) expr))
    (else
     expr)))

(define (univ-emit-cast*-scmobj ctx expr)
  (^cast* 'scmobj expr))

(define (univ-emit-cast*-jumpable ctx expr)
  (^cast* 'jumpable expr))

(define (univ-emit-seq ctx expr1 expr2)
  (case (target-name (ctx-target ctx))

    ((js java)
     (^parens (^ expr1 " , " expr2)))

    ((ruby)
     (^parens (^ expr1 " ; " expr2)))

    (else
     (compiler-internal-error
      "univ-emit-seq, unknown target"))))

(define (univ-emit-parens ctx expr)
  (case (target-name (ctx-target ctx))

    ((js ruby php python java)
     (^ "(" expr ")"))

    (else
     (compiler-internal-error
      "univ-emit-parens, unknown target"))))

(define (univ-emit-parens-php ctx expr)
  (if (eq? (target-name (ctx-target ctx)) 'php)
      (^parens expr)
      expr))

(define (univ-emit-local-var ctx name)
  (case (target-name (ctx-target ctx))

    ((js python ruby java)
     name)

    ((php)
     (^ "$" name))

    (else
     (compiler-internal-error
      "univ-emit-local-var, unknown target"))))

(define (univ-emit-global-var ctx name)
  (case (target-name (ctx-target ctx))

    ((js python java)
     name)

    ((php ruby)
     (^ "$" name))

    (else
     (compiler-internal-error
      "univ-emit-global-var, unknown target"))))

(define (univ-emit-global-function ctx name)
  (case (target-name (ctx-target ctx))

    ((js python java)
     name)

    ((php ruby) name);;TODO: added
#;
    ((php ruby)
     (^ "$" name))

    (else
     (compiler-internal-error
      "univ-emit-global-function, unknown target"))))

(define (univ-emit-this-mod-field ctx name)
  (^mod-field (ctx-module-name ctx) name))

(define (univ-emit-this-mod-method ctx name)
  (^mod-method (ctx-module-name ctx) name))

(define (univ-emit-this-mod-jumpable ctx name)
  (^mod-jumpable (ctx-module-name ctx) name))

(define (univ-emit-mod-member ctx mod-name name)
  (if (and (case (target-name (ctx-target ctx))
             ((js)
              #f)
             ((python)
              (not (eq? (univ-module-representation ctx) 'class)))
             (else
              #t))
           (eq? (ctx-module-name ctx) mod-name)) ;; optimize access to self
      name
      (case (target-name (ctx-target ctx))

        ((js python ruby java)
         (^member (^prefix-class mod-name) name))

        ((php)
         (^ (^prefix-class mod-name) "::" name))

        (else
         (compiler-internal-error
          "univ-emit-mod-member, unknown target")))))

(define (univ-emit-mod-field ctx mod-name name)
  (case (univ-module-representation ctx)

    ((class)
     (tt"000"(univ-emit-mod-member ctx mod-name name)))

    (else
     (tt"111"(^global-var (^prefix name))))))

(define (univ-emit-mod-method ctx mod-name name)
  (case (univ-module-representation ctx)

    ((class)
     (tt"222"(univ-emit-mod-member ctx mod-name name)))

    (else
     (tt"333"(^global-function (^prefix name))))))

(define (univ-emit-mod-jumpable ctx mod-name name)
  (if (eq? (univ-procedure-representation ctx) 'class)
      (let ((x (^mod-field mod-name name)))
        (use-global ctx x)
        x)
      (univ-method-reference
       ctx
       (^mod-method mod-name name))))

(define (univ-emit-mod-class ctx mod-name name)
  (case (univ-module-representation ctx)

    ((class)
     (tt"444"(univ-emit-mod-member ctx mod-name name)))

    (else
     (tt"555"(^prefix-class name)))))

(define (univ-emit-rts-method ctx name)
  (case (univ-module-representation ctx)

    ((class)
     (tt"666"name))

    (else
     (tt"777"(^global-function (^prefix name))))))

(define (univ-emit-rts-method-ref ctx name)
  (case (univ-module-representation ctx)

    ((class)
     (tt"66"(univ-emit-mod-member ctx (univ-rts-module-name ctx) name)))

    (else
     (tt"77"(^global-function (^prefix name))))))

(define (univ-emit-rts-method-use ctx name)
  (univ-use-rtlib ctx name)
  (univ-emit-rts-method-ref ctx name))

(define (univ-emit-rts-field ctx name)
  (case (univ-module-representation ctx)

    ((class)
     (tt"888"name))

    (else
     (tt"999"(^global-var (^prefix name))))))

(define (univ-emit-rts-field-ref ctx name)
  (case (univ-module-representation ctx)

    ((class)
     (tt"88"(univ-emit-mod-member ctx (univ-rts-module-name ctx) name)))

    (else
     (tt"99"(^global-var (^prefix name))))))

(define (univ-emit-rts-field-use ctx name)
  (univ-use-rtlib ctx name)
  (let ((x (univ-emit-rts-field-ref ctx name)))
    (use-global ctx x)
    x))

(define (univ-emit-rts-jumpable-use ctx name)
  (univ-use-rtlib ctx name)
  (^mod-jumpable (univ-rts-module-name ctx) name))

(define (univ-emit-rts-class ctx name)
  (let ((real-name (univ-rts-type-alias ctx name)))
    (case (univ-module-representation ctx)

      ((class)
       (tt"0"(univ-emit-mod-member ctx (univ-rts-module-name ctx) real-name)))

      (else
       (tt"1"(^prefix-class real-name))))))

(define (univ-emit-rts-class-ref ctx name)
  (let ((real-name (univ-rts-type-alias ctx name)))
    (case (univ-module-representation ctx)

      ((class)
       (tt"00"(univ-emit-mod-member ctx (univ-rts-module-name ctx) real-name)))

      (else
       (tt"11"(^prefix-class real-name))))))

(define (univ-emit-rts-class-use ctx name)
  (univ-use-rtlib ctx name)
  (univ-emit-rts-class-ref ctx name))

(define (univ-rts-module-name ctx)
  (case (target-name (ctx-target ctx))

    ((js php python ruby java)
     "RTS")

    (else
     (compiler-internal-error
      "univ-rts-module-name, unknown target"))))

(define (univ-emit-prefix ctx name)
  (case (univ-module-representation ctx)

    ((class)
     name)

    (else
     (^ (ctx-ns-prefix ctx) name))))

(define (univ-emit-prefix-class ctx name)
  (case (univ-module-representation ctx)

;    ((class)
;     name)

    (else
     (^ (ctx-ns-prefix-class ctx) name))))

(define (univ-emit-assign-expr ctx loc expr)
  (^ loc " = " expr))

(define (univ-emit-assign ctx loc expr)
  (^expr-statement
   (^assign-expr loc expr)))

(define (univ-emit-inc-by ctx loc expr #!optional (embed #f))

  (define (embed-read x)
    (if embed
        (embed x)
        (^)))

  (define (embed-expr x parens?)
    (if embed
        (embed (if parens? (^parens x) x))
        (^expr-statement x)))

  (define (inc-general loc expr)
    (if (and (number? expr) (< expr 0))
        (^ loc " -= " (- expr))
        (^ loc " += " expr)))

  (if (equal? expr 0)

      (embed-read loc)

      (case (target-name (ctx-target ctx))

        ((js php java)
         (cond ((equal? expr 1)
                (embed-expr (^ "++" loc) #f))
               ((equal? expr -1)
                (embed-expr (^ "--" loc) #f))
               (else
                (embed-expr (inc-general loc expr)
                            (eq? (target-name (ctx-target ctx)) 'php)))))

        ((python)
         (^ (^expr-statement (inc-general loc expr))
            (embed-read loc)))

        ((ruby)
         (embed-expr (inc-general loc expr) #t))

        (else
         (compiler-internal-error
          "univ-emit-inc-by, unknown target")))))

(define (univ-emit-alias ctx expr)
  (case (target-name (ctx-target ctx))

    ((js python ruby java)
     expr)

    ((php)
     (^ "&" expr))

    (else
     (compiler-internal-error
      "univ-emit-alias, unknown target"))))

(define (univ-emit-unalias ctx expr)
  (case (target-name (ctx-target ctx))

    ((js python ruby java)
     (^))

    ((php)
     (^expr-statement
      (^ "unset(" expr ")")))

    (else
     (compiler-internal-error
      "univ-emit-unalias, unknown target"))))

(define (univ-emit-array? ctx expr)
  (case (target-name (ctx-target ctx))

    ((js ruby)
     (^instanceof "Array" expr))

    ((php)
     (^call-prim "is_array" expr))

    ((python)
     (^instanceof "list" expr))

    ((java)
     (^ expr ".getClass().isArray()"))

    (else
     (compiler-internal-error
      "univ-emit-array?, unknown target"))))

(define (univ-emit-array-length ctx expr)
  (case (target-name (ctx-target ctx))

    ((js ruby java)
     (^ expr ".length"))

    ((php)
     (^ "count(" expr ")"))

    ((python)
     (^ "len(" expr ")"))

    (else
     (compiler-internal-error
      "univ-emit-array-length, unknown target"))))

(define (univ-emit-array-shrink! ctx expr1 expr2)
  (case (target-name (ctx-target ctx))

    ((js)
     (^assign (^ expr1 ".length") expr2))

    ((php)
     (^expr-statement
      (^call-prim 'array_splice expr1 expr2)))

    ((python)
     (^expr-statement
      (^ expr1 "[" expr2 ":] = []")))

    ((ruby)
     (^expr-statement
      (^ expr1 ".slice!(" expr2 "," expr1 ".length)")))

    ((java)
     ;; assumes expr1 is an lvalue, and creates a copy of the array
     (^assign expr1 (^subarray expr1 0 expr2)))

    (else
     (compiler-internal-error
      "univ-emit-array-shrink!, unknown target"))))

(define (univ-emit-array-shrink-possibly-copy! ctx expr1 expr2)
  (case (target-name (ctx-target ctx))

    ((js)
     (^seq
      (^assign-expr (^member expr1 'length) expr2)
      expr1))

    ((php)
     (^call-prim 'array_splice expr1 (^int 0) expr2))

    ((python java)
     (^subarray expr1 (^int 0) expr2))

    ((ruby)
     (^seq
      (^call-prim (^member expr1 'slice!) expr2 (^member expr1 'length))
      expr1))

    (else
     (compiler-internal-error
      "univ-emit-array-shrink-possibly-copy!, unknown target"))))

(define (univ-emit-move-array-to-array ctx array1 srcpos array2 destpos len)
  (case (target-name (ctx-target ctx))

    ((java)
     (^expr-statement
      (^call-prim
       (^member 'System 'arraycopy)
       array1
       srcpos
       array2
       destpos
       len)))

    (else
     (compiler-internal-error
      "univ-emit-move-array-to-array, unknown target"))))

(define (univ-emit-copy-array-to-extensible-array ctx expr len)
  (case (target-name (ctx-target ctx))

    ((js php ruby java)
     (^subarray expr 0 len))

    ((python)
     (^ "dict(zip(range(" len ")," expr "))"))

    (else
     (compiler-internal-error
      "univ-emit-array-to-extensible-array, unknown target"))))

(define (univ-emit-extensible-array-to-array! ctx var len)
  (case (target-name (ctx-target ctx))

    ((js php ruby java)
     (^))

    ((python)
     (^assign var (^ "[" var "[i] for i in range(" len ")]")))

    (else
     (compiler-internal-error
      "univ-emit-extensible-array-to-array!, unknown target"))))

(define (univ-emit-extensible-subarray ctx expr start len)
   (case (target-name (ctx-target ctx))

    ((js ruby php java) (^subarray expr start len))

    ((python)
     (^ "[" expr "[i] for i in range("
                  (if (eq? start 0)
                      len
                      (^ start ", " (^+ start len)))
                ")]"))
    (else
     (compiler-internal-error
      "univ-emit-extensible-subarray, unknown target"))))

(define (univ-emit-subarray ctx expr1 expr2 expr3)
  (case (target-name (ctx-target ctx))

    ((js)
     (^call-prim (^member expr1 'slice)
                 expr2
                 (if (equal? expr2 0) expr3 (^+ expr2 expr3))))

    ((php)
     (^call-prim 'array_slice expr1 expr2 expr3))

    ((python)
     (^ expr1 "[" expr2 ":" (if (equal? expr2 0) expr3 (^+ expr2 expr3)) "]"))

    ((ruby)
     (^call-prim (^member expr1 'slice)
                 expr2
                 (if (equal? expr2 0) expr3 (^+ expr2 expr3))))

    ((java)
     (^call-prim (^member 'Arrays 'copyOfRange)
                 expr1
                 expr2
                 (if (equal? expr2 0) expr3 (^+ expr2 expr3))))

    (else
     (compiler-internal-error
      "univ-emit-subarray, unknown target"))))

(define (univ-emit-array-index ctx expr1 expr2)
  (^ expr1 "[" expr2 "]"))

(define (univ-emit-prop-index ctx expr1 expr2 expr3)
  (if expr3
      (^if-expr (^prop-index-exists? expr1 expr2)
                (^prop-index expr1 expr2)
                expr3)
      (^ expr1 "[" expr2 "]")))

(define (univ-emit-prop-index-exists? ctx expr1 expr2)
  (case (target-name (ctx-target ctx))

    ((js)
     (^ expr1 ".hasOwnProperty(" expr2 ")"))

    ((php)
     (^ "array_key_exists(" expr2 "," expr1 ")"))

    ((python)
     (^ expr2 " in " expr1))

    ((ruby)
     (^ expr1 ".has_key?(" expr2 ")"))

    (else
     (compiler-internal-error
      "univ-emit-prop-index-exists?, unknown target"))))

(define (univ-emit-get ctx obj name)
  (case (target-name (ctx-target ctx))

    ((js python ruby)
     (^prop-index obj (^str name)))

    ((php)
     (^call-prim
      (^rts-method-use 'get)
      obj
      (^str name)))

    (else
     (compiler-internal-error
      "univ-emit-get, unknown target"))))

(define (univ-emit-set ctx obj name val)
  (case (target-name (ctx-target ctx))

    ((js python ruby)
     (^assign-expr (^prop-index obj (^str name)) val))

    ((php)
     (^call-prim
      (^rts-method-use 'set)
      obj
      (^str name)
      val))

    (else
     (compiler-internal-error
      "univ-emit-set, unknown target"))))


;; ***** DUMPING OF A COMPILATION MODULE

(define (univ-dump targ procs output c-intf module-descr unique-name sem-changing-options sem-preserving-options)
  (let ((code
         (univ-dump-code targ procs output c-intf module-descr unique-name sem-changing-options sem-preserving-options)))
    (call-with-output-file
        output
      (lambda (port)
        (univ-display code port)))
    #f))

(define (univ-dump-code targ procs output c-intf module-descr unique-name sem-changing-options sem-preserving-options)
  (let* ((module-name-str
          (symbol->string (vector-ref module-descr 0)))

         (module-name
          (scheme-id->c-id module-name-str))

         (module-proc
          (list-ref procs 0))

         (ctx
          (make-ctx
           targ
           sem-changing-options
           sem-preserving-options
           module-name
           (univ-ns-prefix sem-changing-options)
           (univ-ns-prefix-class sem-changing-options)
           "zzz" ;;;;;;;;;;;;;;;;;
           (make-objs-used)
           (make-resource-set)
           (make-table)
           (queue-empty)))

         (defs-procs
           (univ-dump-procs ctx procs))

         (code-module
          (univ-defs->code
           ctx
           (^prefix-class module-name)
           (univ-defs-combine
            (univ-objs-defs ctx)
            (univ-defs-combine
             defs-procs
             (univ-module-register ctx module-descr)))))

         (code-decls
          (queue->list (ctx-decls ctx)))

         (rtlib-features
          (resource-set-stack (ctx-rtlib-features-used ctx))))

    (^ (univ-link-info-header
        ctx
        module-name-str
        (list (list module-name-str))
        rtlib-features
        (ctx-glo-used ctx)
        #f)
       code-decls
       code-module
       (univ-link-info-footer ctx))))

(define (univ-module-register ctx module-descr)
  (univ-add-init
   (univ-make-empty-defs)
   (lambda (ctx)
     (^expr-statement
      (^call-prim (^rts-method-use 'module_register)
                  (^obj module-descr))))))

(define (univ-defs->code ctx root-name defs)
  (univ-emit-defs
   ctx
   (case (univ-module-representation ctx)

     ((class)
      (let ((class-fields
             (reverse (univ-defs-fields defs)))
            (instance-fields
             '())
            (class-methods
             (reverse (univ-defs-methods defs)))
            (instance-methods
             '())
            (class-classes
             (reverse (univ-defs-classes defs)))
            (inits
             (reverse (univ-defs-inits defs))))
        (univ-add-class
         (univ-make-empty-defs)
         (univ-class
          root-name ;; root-name
          '()       ;; properties
          #f        ;; extends
          class-fields
          '() ;; instance-fields
          class-methods
          '() ;; instance-methods
          class-classes
          #f ;; constructor
          inits))))

     (else
      defs))))

(define (univ-link-info-header ctx name mods-and-flags rtlib-features-used glo-used module-meta-info)
  (let ((glos (table->list glo-used)))
    (^ (univ-link-info-prefix (target-name (ctx-target ctx)))
       (object->string
        (list (compiler-version)
              (list (target-name (ctx-target ctx))
                    (ctx-semantics-changing-options ctx))
              name
              mods-and-flags
              rtlib-features-used
              (map car (keep (lambda (x) (not (eq? (cdr x) 'wr))) glos))
              (map car (keep (lambda (x) (not (eq? (cdr x) 'rd))) glos))
              (map car (keep (lambda (x) (eq? (cdr x) 'rdwr)) glos))
              module-meta-info))
       "\n\n"
       (univ-external-libs ctx))))

(define (univ-link-info-footer ctx)
  (univ-source-file-footer (target-name (ctx-target ctx))))

(define (univ-link-info targ file)
  (let ((in (open-input-file* file)))
    (and in
         (let* ((pref
                 (univ-link-info-prefix (target-name targ)))
                (info
                 (let loop ((i 0))
                   (if (< i (string-length pref))
                       (let ((c (read-char in)))
                         (if (or (eof-object? c)
                                 (not (char=? c (string-ref pref i))))
                             #f
                             (loop (+ i 1))))
                       (read in)))))
           (close-input-port in)
           (and (pair? info)
                (pair? (cdr info))
                (pair? (cadr info))
                (equal? (car info) (compiler-version))
                (equal? (car (cadr info)) (target-name targ))
                info)))))

(define (univ-link-semantics-changing-options inputs warnings?)

  (define (sem-changing-opts x)
    (let ((info (caddr x)))
      (cadr (list-ref info 1))))

  (let* ((rev-inputs (reverse inputs))
         (first (car rev-inputs)))
    (if warnings?
        (let loop ((lst (cdr rev-inputs)))
          (if (pair? lst)
              (let ((input (car inputs)))
                (if (not (equal? (sem-changing-opts first)
                                 (sem-changing-opts input)))
                    (compiler-user-warning #f "inconsistent semantics changing options for files" (car first) (car input)))
                (loop (cdr lst))))))
    (sem-changing-opts first)))

(define (univ-link-mods-and-flags inputs)

  (define (m-and-f x)
    (let ((info (caddr x)))
      (list-ref info 3)))

  (let ((rev-inputs (reverse inputs)))
    (let loop ((lst rev-inputs) (mods-and-flags '()))
      (if (pair? lst)
          (let ((info (caddr (car lst))))
            (loop (cdr lst)
                  (append (list-ref info 3) mods-and-flags)))
          mods-and-flags))))

(define (univ-link-features-used ctx inputs warnings?)

  (for-each (lambda (x)
              (let ((info (caddr x)))
                (for-each (lambda (feature)
                            (univ-use-rtlib ctx feature))
                          (list-ref info 4))
                (for-each (lambda (name)
                            (univ-glo-use ctx name 'rd))
                          (list-ref info 5))
                (for-each (lambda (name)
                            (univ-glo-use ctx name 'wr))
                          (list-ref info 6))
                (for-each (lambda (name)
                            (univ-glo-use ctx name 'rd)
                            (univ-glo-use ctx name 'wr))
                          (list-ref info 7))))
            (reverse inputs))

  (if warnings?

      (let ((undefs (make-table)))

        (for-each (lambda (x)
                    (let ((info (caddr x))
                          (t (ctx-glo-used ctx)))
                      (for-each (lambda (name)
                                  (let ((dir (table-ref t name 'rd)))
                                    (if (eq? dir 'rd)
                                        (let ((files (table-ref undefs name '())))
                                          (table-set! undefs name (cons (car x) files))))))
                                (list-ref info 5))))
                  (reverse inputs))

        (for-each (lambda (x)
                    (let ((name (car x))
                          (files (cdr x)))
                      (display "*** WARNING -- \"")
                      (display (symbol->string name))
                      (display "\" is not defined,")
                      (newline)
                      (display "***            referenced in: ")
                      (write files)
                      (newline)))
                  (table->list undefs))))

  (if (and warnings? univ-all-warnings)

      (let ((unrefs (make-table)))

        (for-each (lambda (x)
                    (let ((info (caddr x))
                          (t (ctx-glo-used ctx)))
                      (for-each (lambda (name)
                                  (let ((dir (table-ref t name 'wr)))
                                    (if (eq? dir 'wr)
                                        (let ((files (table-ref unrefs name '())))
                                          (table-set! unrefs name (cons (car x) files))))))
                                (list-ref info 6))))
                  (reverse inputs))

        (for-each (lambda (x)
                    (let ((name (car x))
                          (files (cdr x)))
                      (display "*** WARNING -- \"")
                      (display (symbol->string name))
                      (display "\" is defined but not referenced,")
                      (newline)
                      (display "***            defined in: ")
                      (write files)
                      (newline)))
                  (table->list unrefs)))))

(define univ-all-warnings #t)
(set! univ-all-warnings #f)

(define (univ-link targ extension? inputs output warnings?)
  (let* ((root
          (path-strip-extension output))

         (name
          (path-strip-directory root))

         (sem-changing-options
          (univ-link-semantics-changing-options inputs warnings?))

         (mods-and-flags
          (univ-link-mods-and-flags inputs))

         (ctx
          (make-ctx
           targ
           sem-changing-options
           '() ;; semantics-preserving-options
           ""  ;; module-name filled in later
           (univ-ns-prefix sem-changing-options)
           (univ-ns-prefix-class sem-changing-options)
           "zzz" ;;;;;;;;;;;;
           (make-objs-used)
           (make-resource-set)
           (make-table)
           (queue-empty)))

         (_
          (ctx-module-name-set! ctx (univ-rts-module-name ctx)))

         (rtlib-init
          (univ-rtlib-init ctx mods-and-flags))

         (_
          (univ-link-features-used ctx inputs warnings?))

         (features-used
          (resource-set-stack (ctx-rtlib-features-used ctx)))

         (code-entry
          (case (target-name targ)
            ((java)
             (univ-defs->code
              ctx
              name
              (univ-entry-defs ctx mods-and-flags)))
            (else
             (^))))

         (code-rtlib
          (univ-defs->code
           ctx
           (^prefix-class (univ-rts-module-name ctx))
           (univ-rtlib-defs ctx rtlib-init)))

         (code-decls
          (queue->list (ctx-decls ctx)))

         (code
          (^ (univ-link-info-header
              ctx
              name
              mods-and-flags
              features-used
              (ctx-glo-used ctx)
              #f)
             code-entry
             code-rtlib
             code-decls
             (univ-link-info-footer ctx))))

      (call-with-output-file
          output
        (lambda (port)
          (univ-display code port)))))

;;TODO: add constants
#;
(define (univ-module-header ctx)
  (^ (^var-declaration 'scmobj (gvm-state-cst ctx) (^extensible-array-literal 'scmobj '()))
     "\n"))

(define (univ-objs-defs ctx)
  (let* ((objs-used (ctx-objs-used ctx))
         (stack (reverse (objs-used-stack objs-used)))
         (table (objs-used-table objs-used)))
    (let loop ((lst stack) (defs (univ-make-empty-defs)))
      (if (pair? lst)
          (loop (cdr lst)
                (let ((obj (car lst)))
                  (if (proc-obj? obj)
                      defs
                      (let ((state (table-ref table obj)))
                        (if (or (> (vector-ref state 0) 1) ;; use a variable?
                                (eq? (target-name (ctx-target ctx)) 'python)) ;; Python can't handle deep nestings
                            (let ((cst
                                   (vector-ref state 2))
                                  (val
                                   (car (vector-ref state 1))))
                              ;;(pp (list cst obj));;;;;;;;;;;;;;;
                              (set-car! (vector-ref state 1)
                                        (^this-mod-field cst))
                              (univ-add-field
                               defs
                               (univ-field cst 'scmobj val '(public))))
                            defs)))))
          defs))))

(define (univ-obj-use ctx obj force-var? gen-expr)

  (define (use-cst cst)
    (if (not (eq? (univ-module-representation ctx) 'class))
        (use-global ctx (^this-mod-field cst))))

  (let* ((objs-used (ctx-objs-used ctx))
         (table (objs-used-table objs-used))
         (state (table-ref table obj #f)))
    (if state ;; don't add to table if obj was added before

        (begin
          (use-cst (vector-ref state 2))
          (vector-set! state 0 (+ (vector-ref state 0) 1)) ;; increment reference count
          (vector-ref state 1))

        (let* ((code
                (list #f))
               (cst
                (string->symbol
                 (string-append
                  "cst"
                  (number->string (table-length table))
                  (if (eq? (univ-module-representation ctx) 'class)
                      ""
                      (string-append "_" (ctx-module-name ctx))))))
               (state
                (vector (if force-var? 2 1) code cst)))
          (use-cst cst)
          (table-set! table obj state)
          (set-car! code (gen-expr))
          (let ((stack (objs-used-stack objs-used)))
            (objs-used-stack-set! objs-used (cons obj stack)))
          code))))

(define (make-objs-used)
  (vector '()
          (make-table test: eq?)))

(define (objs-used-stack ou)        (vector-ref ou 0))
(define (objs-used-stack-set! ou x) (vector-set! ou 0 x))

(define (objs-used-table ou)        (vector-ref ou 1))
(define (objs-used-table-set! ou x) (vector-set! ou 1 x))

(define (univ-dump-procs global-ctx procs)

  (let ((proc-seen (queue-empty))
        (proc-left (queue-empty)))

    (define (scan-obj obj)
      (if (and (proc-obj? obj)
               (proc-obj-code obj)
               (not (memq obj (queue->list proc-seen))))
          (begin
            (queue-put! proc-seen obj)
            (queue-put! proc-left obj))))

    (define (dump-proc p)

      (define ctrlpts
        (make-stretchable-vector #f))

      (define ctrlpts-init
        (list #f))

      (define (scan-bbs ctx bbs)
        (let* ((bb-done (make-stretchable-vector #f))
               (bb-todo (queue-empty)))

          (define (todo-lbl-num! n)
            (queue-put! bb-todo (lbl-num->bb n bbs)))

          (define (scan-bb ctx bb)
            (if (stretchable-vector-ref bb-done (bb-lbl-num bb))
                (univ-make-empty-defs)
                (begin
                  (stretchable-vector-set! bb-done (bb-lbl-num bb) #t)
                  (scan-bb-all ctx bb))))

          (define (scan-bb-all ctx bb)
            (scan-gvm-label
             ctx
             (bb-label-instr bb)
             (lambda (ctx)
               (scan-bb-all-except-label ctx bb))))

          (define (scan-bb-all-except-label ctx bb)
            (let loop ((lst (bb-non-branch-instrs bb))
                       (rev-res '()))
              (if (pair? lst)
                  (loop (cdr lst)
                        (cons (scan-gvm-instr ctx (car lst))
                              rev-res))
                  (reverse
                   (cons (scan-gvm-instr ctx (bb-branch-instr bb))
                         rev-res)))))

          (define (scan-gvm-label ctx gvm-instr proc)

            (define (frame-info gvm-instr)
              (let* ((frame
                      (gvm-instr-frame gvm-instr))
                     (fs
                      (frame-size frame))
                     (vars
                      (reverse (frame-slots frame)))
                     (link
                      (pos-in-list ret-var vars)))
                (vector fs link)))

            (with-stack-base-offset
             ctx
             (- (frame-size (gvm-instr-frame gvm-instr)))
             (lambda (ctx)
               (let* ((id
                       (gvm-bb-use ctx (label-lbl-num gvm-instr) (ctx-ns ctx)))
                      (header
                       (case (label-type gvm-instr)

                         ((simple)
                          (^ "\n"))

                         ((entry)
                          (if (label-entry-rest? gvm-instr)
                              (^ " "
                                 (univ-emit-comment
                                  ctx
                                  (if (label-entry-closed? gvm-instr)
                                      "closure-entry-point (+rest)\n"
                                      "entry-point (+rest)\n")))
                              (^ " "
                                 (univ-emit-comment
                                  ctx
                                  (if (label-entry-closed? gvm-instr)
                                      "closure-entry-point\n"
                                      "entry-point\n")))))

                         ((return)
                          (^ " "
                             (univ-emit-comment ctx "return-point\n")))

                         ((task-entry)
                          (^ " "
                             (univ-emit-comment ctx "task-entry-point\n")))

                         ((task-return)
                          (^ " "
                             (univ-emit-comment ctx "task-return-point\n")))

                         (else
                          (compiler-internal-error
                           "scan-gvm-label, unknown label type"))))
                      (gen-body
                       (lambda (ctx)
                         (^ (case (label-type gvm-instr)

                              ((entry)
                               (univ-label-entry ctx
                                                 gvm-instr
                                                 (^mod-jumpable
                                                  (ctx-module-name ctx)
                                                  id)))

                              (else
                               (^)))

                            (proc ctx))))
                      (entry
                       (bbs-entry-lbl-num bbs))
                      (lbl-num
                       (label-lbl-num gvm-instr)))

                 (univ-jumpable-declaration-defs

                  ctx

                  ;; global?
                  #t

                  ;; name
                  id

                  ;; jumpable-type
                  (case (label-type gvm-instr)
                    ((entry)  (if (= lbl-num entry)
                                  'parententrypt
                                  'entrypt))
                    ((return) 'returnpt)
                    (else     'ctrlpt))

                  ;; params
                  '()

                  ;; attribs
                  (if (memq (label-type gvm-instr) '(entry return))

                      (append

                       (let ((ctrlpt-id
                              (stretchable-vector-length ctrlpts)))
                         (stretchable-vector-set!
                          ctrlpts
                          ctrlpt-id
                          lbl-num)
                         (list (univ-field 'id
                                           'int
                                           (^int ctrlpt-id)
                                           '(inherited))
                               (univ-field 'parent
                                           'parententrypt
                                           (let ((entry? (= lbl-num entry)))
                                             (cond ((and entry?
                                                         (univ-parent-entry-point-has-null-parent? ctx))
                                                    (^null))
                                                   ((and entry?
                                                         (eq? (univ-procedure-representation ctx) 'class))
                                                    (^this))
                                                   (else
                                                    (let ((the-ns (ctx-ns ctx)))
                                                      (lambda (ctx2)
                                                        (let ((ns (ctx-ns ctx2)))
                                                          (ctx-ns-set! ctx2 the-ns)
                                                          (let ((x (univ-ctrlpt-reference
                                                                    ctx2
                                                                    entry)))
                                                            (ctx-ns-set! ctx2 ns)
                                                            x)))))))
                                           '(inherited))))

                       (if (eq? (label-type gvm-instr) 'return)

                           (let ((info (frame-info gvm-instr)))
                             (list (univ-field 'fs
                                               'int
                                               (^int (vector-ref info 0))
                                               '(inherited))
                                   (univ-field 'link
                                               'int
                                               (^int (+ (vector-ref info 1) 1))
                                               '(inherited))))

                           (append
                            (list (univ-field
                                   'nfree
                                   'int
                                   (if (label-entry-closed? gvm-instr)
                                       (let* ((frame (gvm-instr-frame gvm-instr))
                                              (nfree (length (frame-closed frame))))
                                         (^int nfree))
                                       (^int -1))
                                   '(inherited)))
                            (if (= lbl-num entry)
                                (list (univ-field (univ-proc-name-attrib ctx)
                                                  'symbol
                                                  (lambda (ctx)
                                                    (univ-prm-name ctx (proc-obj-name p)))
                                                  '(inherited))
                                      (univ-field 'ctrlpts
                                                  '(array ctrlpt)
                                                  ctrlpts-init
                                                  '(inherited))
                                      (univ-field 'info
                                                  'scmobj
                                                  (^obj #f) ;; TODO
                                                  '(inherited)))
                                '()))))

                      '())

                  ;; body
                  (univ-emit-fn-body ctx header gen-body))))))

          (define (unwind-stack? gvm-instr)
            (let ((node (comment-get (gvm-instr-comment gvm-instr) 'node)))
              (and node (not (intrs-enabled? (node-env node))) 'unwind)))

          (define (scan-gvm-instr ctx gvm-instr)

            ;; TODO: combine with scan-gvm-opnd
            (define (scan-opnd gvm-opnd)
              (cond ((not gvm-opnd))
                    ((lbl? gvm-opnd)
                     (todo-lbl-num! (lbl-num gvm-opnd)))
                    ((obj? gvm-opnd)
                     (scan-obj (obj-val gvm-opnd)))
                    ((clo? gvm-opnd)
                     (scan-opnd (clo-base gvm-opnd)))))

            ;;(write-gvm-instr gvm-instr ##stderr-port)(newline ##stderr-port);;;;;;;;;;;;;;;;;;

            ;; TODO: combine with scan-gvm-opnd
            (case (gvm-instr-type gvm-instr)

              ((apply)
               (for-each scan-opnd (apply-opnds gvm-instr))
               (if (apply-loc gvm-instr)
                   (scan-opnd (apply-loc gvm-instr))))

              ((copy)
               (scan-opnd (copy-opnd gvm-instr))
               (scan-opnd (copy-loc gvm-instr)))

              ((close)
               (for-each (lambda (parms)
                           (scan-opnd (closure-parms-loc parms))
                           (scan-opnd (make-lbl (closure-parms-lbl parms)))
                           (for-each scan-opnd (closure-parms-opnds parms)))
                         (close-parms gvm-instr)))

              ((ifjump)
               (for-each scan-opnd (ifjump-opnds gvm-instr)))

              ((switch)
               (scan-opnd (switch-opnd gvm-instr))
               (for-each (lambda (c) (scan-obj (switch-case-obj c)))
                         (switch-cases gvm-instr)))

              ((jump)
               (scan-opnd (jump-opnd gvm-instr))))

            (case (gvm-instr-type gvm-instr)

              ((apply)
               (let ((loc (apply-loc gvm-instr))
                     (prim (apply-prim gvm-instr))
                     (opnds (apply-opnds gvm-instr)))
                 (let ((proc (proc-obj-inline prim)))
                   (if (not proc)

                       (compiler-internal-error
                        "scan-gvm-instr, unknown 'prim'" prim)

                       (proc
                        ctx
                        (lambda (result)
                          (cond (loc ;; result is needed?
                                 (^setloc loc (or result (^void-obj))))
                                ;; if result is not needed, don't generate expression
                                ;;(result
                                ;; (^expr-statement result))
                                (else
                                 (^))))
                        opnds)))))

              ((copy)
               (let ((loc (copy-loc gvm-instr))
                     (opnd (copy-opnd gvm-instr)))
                 (if opnd
                     (begin
                       (scan-gvm-opnd ctx loc);;;;;;;;;;;;;;;; needed?
                       (scan-gvm-opnd ctx opnd)
                       (^setloc loc (^getopnd opnd)))
                     (^))))

              ((close)
               (let ()

                 (define (alloc lst rev-loc-names)
                   (if (pair? lst)

                       (let* ((parms (car lst))
                              (lbl (closure-parms-lbl parms))
                              (loc (closure-parms-loc parms))
                              (opnds (closure-parms-opnds parms)))
                         (univ-closure-alloc
                          ctx
                          lbl
                          (map (lambda (opnd)
                                 (cond ((assv opnd rev-loc-names) => cdr)
                                       ((memv opnd (map closure-parms-loc lst))
                                        (^null))
                                       (else
                                        (^getopnd opnd))))
                               opnds)
                          (lambda (name)
                            (alloc (cdr lst)
                                   (cons (cons loc name)
                                         rev-loc-names)))))

                       (init (close-parms gvm-instr) (reverse rev-loc-names))))

                 (define (init lst loc-names)
                   (if (pair? lst)

                       (let* ((parms (car lst))
                              (loc (closure-parms-loc parms))
                              (opnds (closure-parms-opnds parms))
                              (loc-name (assv loc loc-names)))
                         (let loop ((i 1) ;; 0
                                    (opnds opnds) ;; (cons (make-lbl lbl) opnds)
                                    (rev-code '()))
                           (if (pair? opnds)
                               (let ((opnd (car opnds)))
                                 (loop (+ i 1)
                                       (cdr opnds)
                                       (cons (if (and (assv opnd loc-names)
                                                      (memv opnd (map closure-parms-loc lst)))
                                                 (^setclo
                                                  (cdr loc-name)
                                                  i
                                                  (cdr (assv opnd loc-names)))
                                                 (^))
                                             rev-code)))
                               (^ (reverse rev-code)
                                  (init (cdr lst) loc-names)))))

                       (map
                        (lambda (loc-name)
                          (let* ((loc (car loc-name))
                                 (name (cdr loc-name)))
                            (^setloc loc name)))
                        loc-names)))

                 (alloc (close-parms gvm-instr) '())))

              ((ifjump)
               (let ((test (ifjump-test gvm-instr))
                     (opnds (ifjump-opnds gvm-instr))
                     (true (ifjump-true gvm-instr))
                     (false (ifjump-false gvm-instr))
                     (fs (frame-size (gvm-instr-frame gvm-instr)))
                     (poll? (or (ifjump-poll? gvm-instr)
                                (unwind-stack? gvm-instr))))

                 (let ((proc (proc-obj-test test)))
                   (if (not proc)

                       (compiler-internal-error
                        "scan-gvm-instr, unknown 'test'" test)

                       (proc
                        ctx
                        (lambda (result)
                          (^if result
                               (jump-to-label ctx true fs poll?)
                               (jump-to-label ctx false fs poll?)))
                        opnds)))))

              ((switch)
               ;; TODO
               ;; (switch-opnd gvm-instr)
               ;; (switch-cases gvm-instr)
               ;; (switch-poll? gvm-instr)
               ;; (switch-default gvm-instr)
               (univ-throw ctx "\"switch GVM instruction unimplemented\""))

              ((jump)
               ;; TODO
               ;; (jump-safe? gvm-instr)
               ;; test: (jump-poll? gvm-instr)

               (let ((nb-args (jump-nb-args gvm-instr))
                     (safe? (jump-safe? gvm-instr))
                     (opnd (jump-opnd gvm-instr))
                     (fs (frame-size (gvm-instr-frame gvm-instr)))
                     (poll? (or (ifjump-poll? gvm-instr)
                                (unwind-stack? gvm-instr))))

                 (or (and (obj? opnd)
                          (proc-obj? (obj-val opnd))
                          nb-args
                          (let* ((proc (obj-val opnd))
                                 (jump-inliner (proc-obj-jump-inline proc)))
                            (and jump-inliner
                                 (jump-inliner ctx nb-args poll? safe? fs))))

                     (^ (if nb-args
                            (^setnargs nb-args)
                            (^))

                        (or (and (lbl? opnd)
                                 (jump-to-label ctx (lbl-num opnd) fs poll?))

                            (with-stack-pointer-adjust
                             ctx
                             (+ fs
                                (ctx-stack-base-offset ctx))
                             (lambda (ctx)
                               (^return-poll
                                (if (jump-safe? gvm-instr)
                                    (if (glo? opnd)
                                        (^call-prim
                                         (^rts-method-use 'check_procedure_glo)
                                         (scan-gvm-opnd ctx opnd)
                                         (^obj (glo-name opnd)))
                                        (^call-prim
                                         (^rts-method-use 'check_procedure)
                                         (scan-gvm-opnd ctx opnd)))
                                    (let ((o (scan-gvm-opnd ctx opnd)))
                                      (if (or (lbl? opnd) (obj? opnd))
                                          o
                                          (^cast*-jumpable o))))
                                poll?
                                (and

                                 ;; avoid call optimization on globals
                                 ;; because some VMs, such as V8 and PyPy,
                                 ;; use a counterproductive speculative
                                 ;; optimization (which slows
                                 ;; down fib by an order of magnitude!)
                                 (not (reg? opnd))

                                 (case (target-name (ctx-target ctx))
                                   ((php)
                                    ;; avoid call optimization on PHP
                                    ;; because it generates syntactically
                                    ;; incorrect code (PHP grammar issue)
                                    #f)
                                   (else
                                    #t)))))))))))

              (else
               (compiler-internal-error
                "scan-gvm-instr, unknown 'gvm-instr':"
                gvm-instr))))

          (define (jump-to-label ctx n jump-fs poll?)
            (with-stack-pointer-adjust
             ctx
             (+ jump-fs
                (ctx-stack-base-offset ctx))
             (lambda (ctx)

               (define (cont)
                 (cond ((and (ctx-allow-jump-destination-inlining? ctx)
                             (let* ((bb (lbl-num->bb n bbs))
                                    (label-instr (bb-label-instr bb)))
                               (and (eq? (label-type label-instr) 'simple)
                                    (or (= (length (bb-precedents bb)) 1)
                                        (= (length (bb-non-branch-instrs bb)) 0))))) ;; very short destination bb?
                        (let* ((bb (lbl-num->bb n bbs))
                               (label-instr (bb-label-instr bb))
                               (label-fs (frame-size (gvm-instr-frame label-instr))))
                          (with-stack-base-offset
                           ctx
                           (- label-fs)
                           (lambda (ctx)
                             (with-allow-jump-destination-inlining?
                              ctx
                              (= (length (bb-precedents bb)) 1) ;; #f
                              (lambda (ctx)
                                (scan-bb-all-except-label ctx bb)))))))

                       (else
                        (^return-jump
                         (scan-gvm-opnd ctx (make-lbl n))))))

               (univ-emit-poll-or-continue ctx (scan-gvm-opnd ctx (make-lbl n)) poll? cont))))

          (define (scan-gvm-opnd ctx gvm-opnd)
            (if (lbl? gvm-opnd)
                (todo-lbl-num! (lbl-num gvm-opnd)))
            (^getopnd gvm-opnd));;;;;;;;;;;;;;;;;;;;;;;scan-gvm-loc ?

          (todo-lbl-num! (bbs-entry-lbl-num bbs))

          (let* ((bbs-defs
                  (let loop ((defs (univ-make-empty-defs)))
                    (if (queue-empty? bb-todo)
                        defs
                        (loop (univ-defs-combine
                               defs
                               (scan-bb ctx (queue-get! bb-todo)))))))
                 (init1
                  (let* ((lbl
                          (make-lbl (bbs-entry-lbl-num bbs)))
                         (entry-id
                          (gvm-lbl-use ctx lbl))
                         (ctrlpts-array
                          (^array-literal
                           (univ-ctrlpt-reference-type ctx)
                           (map (lambda (n)
                                  (univ-ctrlpt-reference ctx n))
                                (stretchable-vector->list ctrlpts)))))
                    (if (eq? (univ-ctrlpt-reference-type ctx) 'str)

                        (begin
                          (set-car! ctrlpts-init ctrlpts-array)
                          (lambda (ctx) (^)))

                        (begin
                          (set-car! ctrlpts-init (^null))
                          (lambda (ctx)
                            (^ "\n"
                               (univ-with-ctrlpt-attribs
                                ctx
                                #f
                                entry-id
                                (lambda ()
                                  (univ-set-ctrlpt-attrib
                                   ctx
                                   entry-id
                                   'ctrlpts
                                   ctrlpts-array)))))))))
                 (init2
                  (lambda (ctx)
                    (let ((name (string->symbol (proc-obj-name p))))
                      (^ "\n"
                         (^setpeps name (^obj p))
                         (if (proc-obj-primitive? p)
                             (^setglo name (^obj p))
                             (^)))))))
            (univ-add-init (univ-add-init bbs-defs init1) init2))))

      (let ((ctx (make-ctx
                  (ctx-target global-ctx)
                  (ctx-semantics-changing-options global-ctx)
                  (ctx-semantics-preserving-options global-ctx)
                  (ctx-module-name global-ctx)
                  (ctx-ns-prefix global-ctx)
                  (ctx-ns-prefix-class global-ctx)
                  (scheme-id->c-id (proc-obj-name p))
                  (ctx-objs-used global-ctx)
                  (ctx-rtlib-features-used global-ctx)
                  (ctx-glo-used global-ctx)
                  (ctx-decls global-ctx))))
        (let ((x (proc-obj-code p)))
          (if (bbs? x)
              (scan-bbs ctx x)
              (univ-make-empty-defs)))))

    (for-each scan-obj procs)

    (let loop ((defs (univ-make-empty-defs)))
      (if (queue-empty? proc-left)
          defs
          (loop (univ-defs-combine defs (dump-proc (queue-get! proc-left))))))))

(define (univ-label-entry ctx gvm-instr id)
  (let* ((nb-parms (label-entry-nb-parms gvm-instr))
         (opts (label-entry-opts gvm-instr))
         (keys (label-entry-keys gvm-instr))
         (rest? (label-entry-rest? gvm-instr))
         (closed? (label-entry-closed? gvm-instr))
         (nb-parms-except-rest
          (- nb-parms (if rest? 1 0)))
         (nb-keys
          (if keys (length keys) 0))
         (nb-req-and-opt
          (- nb-parms-except-rest nb-keys))
         (nb-opts
          (length opts))
         (nb-req
          (- nb-req-and-opt nb-opts))
         (defaults
           (append opts (map cdr (or keys '())))))

    (define (dispatch-on-nb-args nb-args)
      (if (> nb-args (- nb-req-and-opt (if rest? 0 1)))

          (if keys
              (compiler-internal-error
               "univ-label-entry, keyword parameters not supported")
              (^if (if rest?
                       (^not (^call-prim
                              (^rts-method-use 'build_rest)
                              nb-parms-except-rest))
                       (^!= (^getnargs)
                            nb-parms-except-rest))
                   (^return-call-prim
                    (^rts-method-use 'wrong_nargs)
                    (if closed?
                        (^cast*-jumpable (^getreg (+ univ-nb-arg-regs 1)))
                        id))))

          (let ((nb-stacked (max 0 (- nb-args univ-nb-arg-regs)))
                (nb-stacked* (max 0 (- nb-parms univ-nb-arg-regs))))

            (define (setup-parameter i)
              (if (<= i nb-parms)
                  (let* ((rest (setup-parameter (+ i 1)))
                         (src-reg (- i nb-stacked))
                         (src (cond ((<= i nb-args)
                                     (^getreg src-reg))
                                    ((and rest? (= i nb-parms))
                                     (^obj '()))
                                    (else
                                     (^obj
                                      (obj-val (list-ref defaults (- i nb-req 1))))))))
                    (if (<= i nb-stacked*)
                        (^ (^push src)
                           rest)
                        (if (and (<= i nb-args) (= nb-stacked nb-stacked*))
                            rest
                            (let ((dst-reg (- i nb-stacked*)))
                              (^ (^setreg dst-reg src)
                                 rest)))))
                  (^)))

            (let ((x (setup-parameter (+ nb-stacked 1))))
              (^if (^= (^getnargs)
                       nb-args)
                   x
                   (dispatch-on-nb-args (+ nb-args 1)))))))

    (dispatch-on-nb-args nb-req)))

(define closure-count 0)

(define (univ-separated-list sep lst)
  (if (pair? lst)
      (if (pair? (cdr lst))
          (list (car lst) sep (univ-separated-list sep (cdr lst)))
          (car lst))
      '()))

(define (univ-map-index f lst)

  (define (mp f lst i)
    (if (pair? lst)
        (cons (f (car lst) i)
              (mp f (cdr lst) (+ i 1)))
        '()))

  (mp f lst 0))

(define (univ-gensym ctx name)
  (let ((count (ctx-serial-num ctx)))
    (ctx-serial-num-set! ctx (+ count 1))
    (string->symbol
     (string-append
      (symbol->string name)
      (number->string count)))))

(define (univ-closure-alloc ctx lbl exprs cont)
  (let ((closure-var (^local-var (univ-gensym ctx 'closure))))
    (^ (^var-declaration
        'closure
        closure-var
        (^call-prim
         (^rts-method-use 'closure_alloc)
         (^array-literal
          'scmobj
          (cons (gvm-lbl-use ctx (make-lbl lbl))
                exprs))))
       (cont closure-var))))

(define (make-ctx
         target
         semantics-changing-options
         semantics-preserving-options
         module-name
         ns-prefix
         ns-prefix-class
         ns
         objs-used
         rtlib-features-used
         glo-used
         decls)
  (vector target
          semantics-changing-options
          semantics-preserving-options
          module-name
          ns-prefix
          ns-prefix-class
          ns
          0
          0
          univ-enable-jump-destination-inlining?
          (make-resource-set)
          (make-resource-set)
          (make-resource-set)
          objs-used
          rtlib-features-used
          glo-used
          decls))

(define (ctx-target ctx)                   (vector-ref ctx 0))
(define (ctx-target-set! ctx x)            (vector-set! ctx 0 x))

(define (ctx-semantics-changing-options ctx)        (vector-ref ctx 1))
(define (ctx-semantics-changing-options-set! ctx x) (vector-set! ctx 1 x))

(define (ctx-semantics-preserving-options ctx)        (vector-ref ctx 2))
(define (ctx-semantics-preserving-options-set! ctx x) (vector-set! ctx 2 x))

(define (ctx-module-name ctx)              (vector-ref ctx 3))
(define (ctx-module-name-set! ctx x)       (vector-set! ctx 3 x))

(define (ctx-ns-prefix ctx)                (vector-ref ctx 4))
(define (ctx-ns-prefix-set! ctx x)         (vector-set! ctx 4 x))

(define (ctx-ns-prefix-class ctx)          (vector-ref ctx 5))
(define (ctx-ns-prefix-class-set! ctx x)   (vector-set! ctx 5 x))

(define (ctx-ns ctx)                       (vector-ref ctx 6))
(define (ctx-ns-set! ctx x)                (vector-set! ctx 6 x))

(define (ctx-stack-base-offset ctx)        (vector-ref ctx 7))
(define (ctx-stack-base-offset-set! ctx x) (vector-set! ctx 7 x))

(define (ctx-serial-num ctx)               (vector-ref ctx 8))
(define (ctx-serial-num-set! ctx x)        (vector-set! ctx 8 x))

(define (ctx-allow-jump-destination-inlining? ctx)        (vector-ref ctx 9))
(define (ctx-allow-jump-destination-inlining?-set! ctx x) (vector-set! ctx 9 x))

(define (ctx-resources-used-rd ctx)        (vector-ref ctx 10))
(define (ctx-resources-used-rd-set! ctx x) (vector-set! ctx 10 x))

(define (ctx-resources-used-wr ctx)        (vector-ref ctx 11))
(define (ctx-resources-used-wr-set! ctx x) (vector-set! ctx 11 x))

(define (ctx-globals-used ctx)             (vector-ref ctx 12))
(define (ctx-globals-used-set! ctx x)      (vector-set! ctx 12 x))

(define (ctx-objs-used ctx)                (vector-ref ctx 13))
(define (ctx-objs-used-set! ctx x)         (vector-set! ctx 13 x))

(define (ctx-rtlib-features-used ctx)        (vector-ref ctx 14))
(define (ctx-rtlib-features-used-set! ctx x) (vector-set! ctx 14 x))

(define (ctx-glo-used ctx)                 (vector-ref ctx 15))
(define (ctx-glo-used-set! ctx x)          (vector-set! ctx 15 x))

(define (ctx-decls ctx)                    (vector-ref ctx 16))
(define (ctx-decls-set! ctx x)             (vector-set! ctx 16 x))

(define (with-stack-base-offset ctx n proc)
  (let ((save (ctx-stack-base-offset ctx)))
    (ctx-stack-base-offset-set! ctx n)
    (let ((result (proc ctx)))
      (ctx-stack-base-offset-set! ctx save)
      result)))

(define (with-stack-pointer-adjust ctx n proc)
  (^ (if (equal? n 0)
         (^)
         (^inc-by (gvm-state-sp-use ctx 'rdwr)
                  n))
     (with-stack-base-offset
      ctx
      (- (ctx-stack-base-offset ctx) n)
      proc)))

(define (with-allow-jump-destination-inlining? ctx allow? proc)
  (let ((save (ctx-allow-jump-destination-inlining? ctx)))
    (ctx-allow-jump-destination-inlining?-set! ctx allow?)
    (let ((result (proc ctx)))
      (ctx-allow-jump-destination-inlining?-set! ctx save)
      result)))

(define (with-new-resources-used ctx proc)
  (let ((save-rsrc-rd (ctx-resources-used-rd ctx))
        (save-rsrc-wr (ctx-resources-used-wr ctx))
        (save-glob-rd (ctx-globals-used ctx)))
    (ctx-resources-used-rd-set! ctx (make-resource-set))
    (ctx-resources-used-wr-set! ctx (make-resource-set))
    (ctx-globals-used-set! ctx (make-resource-set))
    (let ((result (proc ctx)))
      (ctx-resources-used-rd-set! ctx save-rsrc-rd)
      (ctx-resources-used-wr-set! ctx save-rsrc-wr)
      (ctx-globals-used-set! ctx save-glob-rd)
      result)))

(define (make-resource-set)
  (cons (make-table) '()))

(define (resource-set-add! set element)
  (let ((t (car set)))
    (if (not (table-ref t element #f))
        (begin
          (table-set! t element #t)
          (set-cdr! set (cons element (cdr set)))))))

(define (resource-set-member? set element)
  (table-ref (car set) element #f))

(define (resource-set-stack set)
  (cdr set))

(define (resource-set-pop set)
  (let ((s (cdr set)))
    (if (pair? s)
        (begin
          (set-cdr! set (cdr s))
          (car s))
        #f)))

(define (use-resource-rd ctx resource)
  (resource-set-add! (ctx-resources-used-rd ctx) resource))

(define (use-resource-wr ctx resource)
  (resource-set-add! (ctx-resources-used-wr ctx) resource))

(define (use-global ctx global)
  (resource-set-add! (ctx-globals-used ctx) global))

(define (univ-use-rtlib ctx feature)
  ;;(pp (list 'use-rtlib feature));;;;;;;;;;;;
  (resource-set-add! (ctx-rtlib-features-used ctx) feature)
  (symbol->string feature))

(define (use-resource ctx dir resource)
  (if (or (eq? dir 'rd) (eq? dir 'rdwr))
      (use-resource-rd ctx resource))
  (if (or (eq? dir 'wr) (eq? dir 'rdwr))
      (use-resource-wr ctx resource)))

(define (gvm-state-pollcount ctx)
  (^rts-field-use 'pollcount))

(define (gvm-state-nargs ctx)
  (^rts-field-use 'nargs))

(define (gvm-state-reg ctx num)
  (^rts-field-use (string->symbol (string-append "r" (number->string num)))))

(define (gvm-state-stack ctx)
  (^rts-field-use 'stack))

(define (gvm-state-sp ctx)
  (^rts-field-use 'sp))

(define (gvm-state-peps ctx)
  (^rts-field-use 'peps))

(define (gvm-state-glo ctx)
  (^rts-field-use 'glo))

(define (gvm-state-pollcount-use ctx dir)
  (use-resource ctx dir 'pollcount)
  (gvm-state-pollcount ctx))

(define (gvm-state-nargs-use ctx dir)
  (use-resource ctx dir 'nargs)
  (gvm-state-nargs ctx))

(define (gvm-state-reg-use ctx dir num)
  (use-resource ctx dir num)
  (gvm-state-reg ctx num))

(define (gvm-state-stack-use ctx dir)
  (use-resource ctx dir 'stack)
  (gvm-state-stack ctx))

(define (gvm-state-sp-use ctx dir)
  (use-resource ctx dir 'sp)
  (gvm-state-sp ctx))

(define (gvm-state-peps-use ctx dir)
  (use-resource ctx dir 'peps)
  (gvm-state-peps ctx))

(define (gvm-state-glo-use ctx dir)
  (use-resource ctx dir 'glo)
  (gvm-state-glo ctx))

(define (univ-emit-tos ctx)
  (^array-index
   (gvm-state-stack-use ctx 'rd)
   (gvm-state-sp-use ctx 'rd)))

(define (univ-emit-pop ctx receiver)
  (^ (receiver (^tos))
     (^inc-by (gvm-state-sp-use ctx 'rdwr)
              -1)))

(define (univ-emit-push ctx val)
  (^inc-by (gvm-state-sp-use ctx 'rdwr)
           1
           (lambda (x)
             (^assign
              (^array-index
               (gvm-state-stack-use ctx 'rd)
               x)
              val))))

(define (univ-emit-getnargs ctx)
  (gvm-state-nargs-use ctx 'rd))

(define (univ-emit-setnargs ctx nb-args)
  (^assign
   (gvm-state-nargs-use ctx 'wr)
   nb-args))

(define (univ-emit-getreg ctx num)
  (gvm-state-reg-use ctx 'rd num))

(define (univ-emit-setreg ctx num val)
  (^assign
   (gvm-state-reg-use ctx 'wr num)
   val))

(define (univ-stk-slot-from-tos ctx offset)
  (^array-index
   (gvm-state-stack-use ctx 'rd)
   (^- (gvm-state-sp-use ctx 'rd)
       offset)))

(define (univ-stk-location ctx offset)
  (^array-index
   (gvm-state-stack-use ctx 'rd)
   (^ (gvm-state-sp-use ctx 'rd)
      (cond ((= offset 0)
             (^))
            ((< offset 0)
             (^ offset))
            (else
             (^ "+" offset))))))

(define (univ-emit-getstk ctx offset)
  (univ-stk-location ctx offset))

(define (univ-emit-setstk ctx offset val)
  (^assign
   (univ-stk-location ctx offset)
   val))

(define (univ-clo-slots ctx closure)
  (case (univ-procedure-representation ctx)

    ((class)
     (^member (^cast* 'closure closure) 'slots))

    (else
     (case (target-name (ctx-target ctx))
       ((php)
        ;;(^member (^cast* 'closure closure) 'slots)
        (^member closure 'slots))
       (else
        (^jump closure (^bool #t)))))))

(define (univ-emit-getclo ctx closure index)
  (^closure-ref closure index))

(define (univ-emit-setclo ctx closure index val)
  (^closure-set! closure index val))

(define (univ-glo-dependency ctx name dir)
  (univ-glo-use ctx name dir)
  (gvm-state-glo-use ctx 'rd)
  (if (member name
              '(println
                real-time-milliseconds))
      (begin
        (univ-glo-use ctx name 'wr) ;; automatically defined primitives
        (univ-use-rtlib
         ctx
         (string->symbol (string-append "glo-" (symbol->string name)))))))

(define (univ-glo-use ctx name dir)
  (let* ((t (ctx-glo-used ctx))
         (x (table-ref t name #f)))
    (table-set! t name (if (or (not x) (eq? dir x)) dir 'rdwr))))

(define (univ-emit-getpeps ctx name)
  (^dict-get (gvm-state-peps-use ctx 'rd)
             (^str (symbol->string name))))

(define (univ-emit-setpeps ctx name val)
  (^dict-set (gvm-state-peps-use ctx 'rd)
             (^str (symbol->string name))
             val))

(define (univ-emit-getglo ctx name)
  (univ-glo-dependency ctx name 'rd)
  (^dict-get (gvm-state-glo-use ctx 'rd)
             (^str (symbol->string name))))

(define (univ-emit-setglo ctx name val)
  (univ-glo-dependency ctx name 'wr)
  (^dict-set (gvm-state-glo-use ctx 'rd)
             (^str (symbol->string name))
             val))

(define (univ-emit-glo-var-ref ctx sym)
  (^dict-get (gvm-state-glo-use ctx 'rd)
             (^symbol-unbox sym)))

(define (univ-emit-glo-var-primitive-ref ctx sym)
  (^dict-get (gvm-state-peps-use ctx 'rd)
             (^symbol-unbox sym)))

(define (univ-emit-glo-var-set! ctx sym val)
  (^dict-set (gvm-state-glo-use ctx 'rd)
             (^symbol-unbox sym)
             val))

(define (univ-emit-glo-var-primitive-set! ctx sym val)
  (^dict-set (gvm-state-peps-use ctx 'rd)
             (^symbol-unbox sym)
             val))

(define (univ-emit-getopnd ctx gvm-opnd)

  (cond ((reg? gvm-opnd)
         (^getreg (reg-num gvm-opnd)))

        ((stk? gvm-opnd)
         (^getstk (+ (stk-num gvm-opnd) (ctx-stack-base-offset ctx))))

        ((glo? gvm-opnd)
         (^getglo (glo-name gvm-opnd)))

        ((clo? gvm-opnd)
         (^getclo (^getopnd (clo-base gvm-opnd))
                  (clo-index gvm-opnd)))

        ((lbl? gvm-opnd)
         (gvm-lbl-use ctx gvm-opnd))

        ((obj? gvm-opnd)
         (^obj (obj-val gvm-opnd)))

        (else
         (compiler-internal-error
          "univ-emit-getopnd, unknown 'gvm-opnd':"
          gvm-opnd))))

(define (univ-emit-getopnds ctx gvm-opnds)
  (map (lambda (gvm-opnd) (univ-emit-getopnd ctx gvm-opnd))
       gvm-opnds))

(define (univ-emit-setloc ctx gvm-loc val)

  (cond ((reg? gvm-loc)
         (^setreg (reg-num gvm-loc)
                  val))

        ((stk? gvm-loc)
         (^setstk (+ (stk-num gvm-loc) (ctx-stack-base-offset ctx))
                  val))

        ((glo? gvm-loc)
         (^setglo (glo-name gvm-loc)
                  val))

        ((clo? gvm-loc)
         (^setclo (^getopnd (clo-base gvm-loc))
                  (clo-index gvm-loc)
                  val))

        (else
         (compiler-internal-error
          "univ-emit-setloc, unknown 'gvm-loc':"
          gvm-loc))))

(define (univ-emit-obj ctx obj)

  (define (emit-obj obj force-var?)

    (cond ((or (false-object? obj)
               (boolean? obj))
           (^boolean-obj obj))

          ((number? obj)
           (cond ((not (real? obj)) ;; non-real complex number
                  (univ-obj-use
                   ctx
                   obj
                   force-var?
                   (lambda ()
                     (^cpxnum-make (emit-obj (real-part obj) #f)
                                   (emit-obj (imag-part obj) #f)))))

                 ((not (exact? obj)) ;; floating-point number
                  (^flonum-box (^float obj)))

                 ((not (integer? obj)) ;; non-integer rational number
                  (univ-obj-use
                   ctx
                   obj
                   force-var?
                   (lambda ()
                     (^ratnum-make (emit-obj (numerator obj) #f)
                                   (emit-obj (denominator obj) #f)))))

                 (else ;; exact integer
                  (if (and (>= obj univ-fixnum-min)
                           (<= obj univ-fixnum-max))

                      (^fixnum-box (^int obj))

                      (univ-obj-use
                       ctx
                       obj
                       force-var?
                       (lambda ()
                         (^new (^type 'bignum)
                               (^array-literal
                                'bigdigit
                                (univ-bignum->digits obj)))))))))

          ((char? obj)
           (^char-obj obj force-var?))

          ((string? obj)
           (^string-obj obj force-var?))

          ((symbol-object? obj)
           (^symbol-obj obj force-var?))

          ((keyword-object? obj)
           (^keyword-obj obj force-var?))

          ((null? obj)
           (^null-obj))

          ((void-object? obj)
           (^void-obj))

          ((end-of-file-object? obj)
           (^eof))

          ((absent-object? obj)
           (^absent))

          ((unbound1-object? obj)
           (^unbound1))

          ((unbound2-object? obj)
           (^unbound2))

          ((optional-object? obj)
           (^optional))

          ((key-object? obj)
           (^key))

          ((rest-object? obj)
           (^rest))

          ((proc-obj? obj)
           (let ((name (proc-obj-name obj)))
             (if (proc-obj-code obj) ;; procedure defined in this module?
                 (^this-mod-jumpable (gvm-proc-use ctx name))
                 (^getpeps (string->symbol name)))))

          ((pair? obj)
           (univ-obj-use
            ctx
            obj
            force-var?
            (lambda ()
              (^cons (emit-obj (car obj) #f)
                     (emit-obj (cdr obj) #f)))))

          ((vector-object? obj)
           (univ-obj-use
            ctx
            obj
            force-var?
            (lambda ()
              (^vector-box
               (^array-literal
                'scmobj
                (map (lambda (x) (emit-obj x #f))
                     (vector->list obj)))))))

          ((u8vect? obj)
           (univ-obj-use
            ctx
            obj
            force-var?
            (lambda ()
              (^u8vector-box
               (^array-literal
                'u8
                (map (lambda (x) (^int x))
                     (u8vect->list obj)))))))

          ((u16vect? obj)
           (univ-obj-use
            ctx
            obj
            force-var?
            (lambda ()
              (^u16vector-box
               (^array-literal
                'u16
                (map (lambda (x) (^int x))
                     (u16vect->list obj)))))))

          ((u32vect? obj)
           (univ-obj-use
            ctx
            obj
            force-var?
            (lambda ()
              (^u32vector-box
               (^array-literal
                'u32
                (map (lambda (x) (emit-obj x #f))
                     (u32vect->list obj)))))))

          ((u64vect? obj)
           (univ-obj-use
            ctx
            obj
            force-var?
            (lambda ()
              (^u64vector-box
               (^array-literal
                'u64
                (map (lambda (x) (emit-obj x #f))
                     (u64vect->list obj)))))))

          ((s8vect? obj)
           (univ-obj-use
            ctx
            obj
            force-var?
            (lambda ()
              (^s8vector-box
               (^array-literal
                's8
                (map (lambda (x) (^int x))
                     (s8vect->list obj)))))))

          ((s16vect? obj)
           (univ-obj-use
            ctx
            obj
            force-var?
            (lambda ()
              (^s16vector-box
               (^array-literal
                's16
                (map (lambda (x) (^int x))
                     (s16vect->list obj)))))))

          ((s32vect? obj)
           (univ-obj-use
            ctx
            obj
            force-var?
            (lambda ()
              (^s32vector-box
               (^array-literal
                's32
                (map (lambda (x) (emit-obj x #f))
                     (s32vect->list obj)))))))

          ((s64vect? obj)
           (univ-obj-use
            ctx
            obj
            force-var?
            (lambda ()
              (^s64vector-box
               (^array-literal
                's64
                (map (lambda (x) (emit-obj x #f))
                     (s64vect->list obj)))))))

          ((f32vect? obj)
           (univ-obj-use
            ctx
            obj
            force-var?
            (lambda ()
              (^f32vector-box
               (^array-literal
                'f32
                (map (lambda (x) (^cast* 'f32 (^float x)))
                     (f32vect->list obj)))))))

          ((f64vect? obj)
           (univ-obj-use
            ctx
            obj
            force-var?
            (lambda ()
              (^f64vector-box
               (^array-literal
                'f64
                (map (lambda (x) (^float x))
                     (f64vect->list obj)))))))

          ((structure-object? obj)
           (univ-obj-use
            ctx
            obj
            force-var?
            (lambda ()
              (let* ((slots
                      (##vector-copy obj));;TODO: replace call of ##vector-copy
                     (cyclic?
                      (eq? (vector-ref slots 0) obj)))
                (^structure-box
                 (^array-literal
                  'scmobj
                  (cons (if cyclic? ;; the root type descriptor is cyclic
                            (^null) ;; handle this specially
                            (emit-obj (vector-ref slots 0) #f))
                        (map (lambda (x) (emit-obj x #f))
                             (cdr (vector->list slots))))))))))

          (else
           (compiler-user-warning #f "UNIMPLEMENTED OBJECT:" obj)
           (^str
            (string-append
             "UNIMPLEMENTED OBJECT: "
             (object->string obj))))))

  (emit-obj obj #t))

(define univ-adigit-width 14)

(define (univ-bignum->digits obj)

  (define (dig n len rest)
    (cond ((= len 1)
           (cons n rest))
          (else
           (let* ((hi-len (quotient len 2))
                  (lo-len (- len hi-len))
                  (lo-len-bits (* univ-adigit-width lo-len)))
             (let* ((hi (arithmetic-shift n (- lo-len-bits)))
                    (lo (- n (arithmetic-shift hi lo-len-bits))))
               (dig lo
                    lo-len
                    (dig hi
                         hi-len
                         rest)))))))

  (let* ((width (integer-length obj))
         (len (+ (quotient width univ-adigit-width) 1)))
    (dig (if (< obj 0)
           (+ (arithmetic-shift 1 (* univ-adigit-width len)) obj)
           obj)
         len
         '())))

(define (univ-emit-array-literal ctx type elems)
  (case (target-name (ctx-target ctx))

    ((js python ruby)
     (^ "[" (univ-separated-list "," elems) "]"))

    ((php)
     (^apply "array" elems))

    ((java)
     (^ "new " (^type (list 'array type)) "{" (univ-separated-list "," elems) "}"))

    (else
     (compiler-internal-error
      "univ-emit-array-literal, unknown target"))))

(define (univ-emit-extensible-array-literal ctx type elems)
  (case (target-name (ctx-target ctx))

    ((js ruby)
     (^ "[" (univ-separated-list "," elems) "]"))

    ((php)
     (^apply "array" elems))

    ((python)
     (let ((key-vals
            (let loop ((i 0) (lst elems) (rev-kv '()))
              (if (pair? lst)
                  (loop (+ i 1)
                        (cdr lst)
                        (cons (^ i ":" (car lst)) rev-kv))
                  (reverse rev-kv)))))
       (^ "{" (univ-separated-list "," key-vals) "}")))

    ((java)
     (^ "new " (^type (list 'array type)) "{" (univ-separated-list "," elems) "}"))

    (else
     (compiler-internal-error
      "univ-emit-extensible-array-literal, unknown target"))))

(define (univ-emit-make-stack ctx)
  (case (target-name (ctx-target ctx))

    ((js php python ruby)
     (^extensible-array-literal 'scmobj '()))

    ((java)
     (^new-array 'scmobj 10000));;TODO: fix size

    (else
     (compiler-internal-error
      "univ-emit-make-stack, unknown target"))))

(define (univ-emit-new-array ctx type len)
  (case (target-name (ctx-target ctx))

    ((js)
     (^new "Array" len))

    ((php)
     (^if-expr (^= len (^int 0)) ;; array_fill does not like len=0
               (^array-literal type '())
               (^call-prim
                "array_fill"
                (^int 0)
                len
                (^int 0))))

    ((python)
     (^* (^ "[" (^int 0) "]") len))

    ((ruby)
     (^call-prim (^member "Array" 'new) len))

    ((java)
     (^ "new " (^type type) "[" len "]"))

    (else
     (compiler-internal-error
      "univ-emit-new-array, unknown target"))))

(define (univ-emit-make-array ctx type return len init)
  (case (target-name (ctx-target ctx))

    ((js)
     ;; TODO: add for loop constructor
     (let ((elems (^local-var 'elems)))
       (^ (^var-declaration
           (list 'array type)
           elems
           (^new-array type len))
          "
          for (var i=0; i<" len "; i++) {
            " elems "[i] = " init ";
          }
          "
          (return elems))))

    ((php)
     (return
      (^if-expr (^= len (^int 0)) ;; array_fill does not like len=0
                (^array-literal type '())
                (^call-prim
                 "array_fill"
                 (^int 0)
                 len
                 init))))

    ((python)
     ;; TODO: add literal array constructor
     (return
      (^* (^ "[" init "]") len)))

    ((ruby)
     (return
      (^call-prim (^member "Array" 'new) len init)))

    ((java)
     ;; TODO: add for loop constructor
     (let ((elems (^local-var 'elems)))
       (^ (^var-declaration
           (list 'array type)
           elems
           (^new-array type len))
          "
          for (int i=0; i<" len "; i++) {
            " elems "[i] = " init ";
          }
          "
          (return elems))))

    (else
     (compiler-internal-error
      "univ-emit-make-array, unknown target"))))

;; =============================================================================

(define (gvm-lbl-use ctx lbl)
  (^this-mod-jumpable (gvm-lbl-use-aux ctx lbl)))

(define (gvm-lbl-use-aux ctx lbl)
  (gvm-bb-use ctx (lbl-num lbl) (ctx-ns ctx)))

(define (gvm-proc-use ctx name)
  (gvm-bb-use ctx 1 (scheme-id->c-id name)))

(define (gvm-bb-use ctx num ns)
  (let ((id (lbl->id ctx num ns)))
    ;;TODO: remove?
    ;;(use-global ctx (^mod-field "AAA" id))
    id))

(define (lbl->id ctx num ns)
  (^ univ-bb-prefix num "_" ns))

(define univ-bb-prefix "bb")
(define univ-capitalized-bb-prefix "Bb")

(define (univ-foldr-range lo hi rest fn)
  (if (<= lo hi)
      (univ-foldr-range
       lo
       (- hi 1)
       (fn hi rest)
       fn)
      rest))

(define (univ-pop-args-to-vars ctx nb-args)
  (let ((nb-stacked (max 0 (- nb-args univ-nb-arg-regs))))
    (univ-foldr-range
     1
     nb-args
     (^)
     (lambda (i rest)
       (^ rest
          (let ((x (- i nb-stacked)))
            (if (>= x 1)
                (^var-declaration
                 'scmobj
                 (^local-var (^ 'arg i))
                 (^getreg x))
                (^pop (lambda (expr)
                        (^var-declaration
                         'scmobj
                         (^local-var (^ 'arg i))
                         expr))))))))))

(define (univ-push-args ctx)
  (univ-foldr-range
   0
   (- univ-nb-arg-regs 1)
   (^)
   (lambda (i rest)
     (^if (^> (^getnargs) i)
          (^ (^push (^getreg (+ i 1)))
             rest)))))

(define (univ-pop-args-to-regs ctx lo)
  (univ-foldr-range
   0
   (- univ-nb-arg-regs 1)
   (^)
   (lambda (i rest)
     (let ((x
            (^ rest
               (^pop (lambda (expr)
                       (^setreg (+ i 1) expr))))))
       (if (< i lo)
           x
           (^if (^> (^getnargs) (- i lo))
                x))))))

(define (univ-min-fixnum ctx) 0)
(define (univ-max-fixnum ctx) 256)

;;;============================================================================
