(import (scheme base)
        (only (csc ir1)
          constant-expression
          constant?
          lexical-ref-name
          lexical-ref?
          lexical-set-expression
          lexical-set-name
          lexical-set?
          library-ref-library
          library-ref-name
          library-ref-public?
          library-ref?
          library-set-expression
          library-set-library
          library-set-name
          library-set-public?
          library-set?
          make-constant
          void?)
        (only (csc testing)
          assert-equal
          test)
        (csc macros))


(define (ir1= x y)
  (cond
    ((and (void? x) (void? y)) #t)
    ((and (constant? x) (constant? y))
      (equal? (constant-expression x) (constant-expression y)))
    ((and (lexical-ref? x) (lexical-ref? y))
      (symbol=? (lexical-ref-name x) (lexical-ref-name y)))
    ((and (lexical-set? x) (lexical-set? y))
      (and
        (symbol=? (lexical-set-name x) (lexical-set-name y))
        (ir1= (lexical-set-expression x) (lexical-set-expression y))))
    ((and (library-ref? x) (library-ref? y))
      (and
        (equal? (library-ref-library x) (library-ref-library y))
        (symbol=? (library-ref-name x) (library-ref-name y))
        (boolean=? (library-ref-public? x) (library-ref-public? y))))
    ((and (library-set? x) (library-set? y))
      (and
        (equal? (library-set-library x) (library-set-library y))
        (symbol=? (library-set-name x) (library-set-name y))
        (boolean=? (library-set-public? x) (library-set-public? y))
        (ir1=? (library-set-expression x) (library-set-expression y))))
    ((and (toplevel-define? x) (toplevel-define? y))
      (and
        (symbol=? (toplevel-define-name x) (toplevel-define-name y))
        (ir1=? (toplevel-define-expression x) (toplevel-define-expression y))))
    ((and (if? x) (if? y))
      (and
        (ir1=? (if-test x) (if-test y))
        (ir1=? (if-consequent x) (if-consequent y))
        (ir1=? (if-alternate x) (if-alternate y))))
    ((and (call? x) (call? y))
      (and
        (ir1=? (call-procedure x) (call-procedure y))
        (apply (map ir1=? (call-arguments x) (call-arguments y))))
    ((and (sequence? x) (sequence? y))
      (and
        (ir1=? (sequence-head x) (sequence-head y))
        (ir1=? (sequence-tail x) (sequence-tail y))))
    ((and (lambda? x) (lambda? y))
      (ir1=? (lambda-body x) (lambda-body y)))
    ((and (lambda-case? x) (lambda-case? y))
      (and
        (equal? (lambda-case-arguments x) (lambda-case-arguments y))
        (eq? (lambda-case-rest x) (lambda-case-rest y))
        (ir1=? (lambda-case-body x) (lambda-case-body y))
        (or (and (not (lambda-case-alternate x))
                 (not (lambda-case-alternate y)))
            (ir1= (lambda-case-alternate x) (lambda-case-alternate y)))))
    ((and (letrec? x) (letrec? y))
      (and
        (boolean=? (letrec-in-order? x) (letrec-in-order? y))
        (map symbol=? (letrec-names x) (letrec-names y))


(test builtin-quote
  (assert-equal
    (make-constant '(test 1 2 3))
    (expand '(quote (test 1 2 3)) builtins-environment)))


(test builtin-syntax-rules-literal
  (assert-equal
    (make-constant 1)
    (expand
      '(builtin-let-syntax
         (foo
           (syntax-rules (a b)
             ((foo a)
               0)
             ((foo b)
               1)))
         (foo b))
      builtins-environment)))


(test builtin-syntax-rules-underscore
  (assert-equal
    (make-constant 0)
    (expand
      '(builtin-let-syntax
         (foo
           (syntax-rules ()
             ((foo _) 0)))
         (foo ignored))
      builtins-environment)))


(test builtin-syntax-rules-substitution
  (assert-equal
    (make-constant 5)
    (expand
      '(builtin-let-syntax
         (foo
           (syntax-rules ()
             ((foo x) x)))
         (foo 5))
      builtins-environment)))


(test builtin-syntax-rules-nil
  (assert-equal
    (make-constant 1)
    (expand
      '(builtin-let-syntax
         (foo
           (syntax-rules ()
             ((foo x) 0)
             ((foo) 1)))
         (foo))
      builtins-environment)))


(test builtin-syntax-rules-improper-list
  (assert-equal
    (make-constant 1)
    (expand
      '(builtin-let-syntax
         (foo
           (syntax-rules ()
             ((foo a . b) a)))
         (foo 1 2 3))
      builtins-environment)))


(test builtin-syntax-rules-quoted
  (assert-equal
    (make-constant 'a)
    (expand
      '(builtin-let-syntax
         (foo
           (syntax-rules ()
             ((foo x) (quote x))))
         (foo a))
      builtins-environment)))


(test builtin-syntax-rules-constant
  (assert-equal
    (make-constant 2)
    (expand
      '(builtin-let-syntax
         (foo
           (syntax-rules ()
             ((foo "abc") 0)
             ((foo "def") 1)
             ((foo "ghi") 2)))
         (foo "ghi"))
      builtins-environment)))


(test builtin-syntax-rules-ellipsis
  (assert-equal
    (make-constant 5)
    (expand
      '(builtin-let-syntax
         (foo
           (syntax-rules ()
             ((foo x ...) (x ...))))
         (foo quote 5))
      builtins-environment)))


(test builtin-syntax-rules-ellipsis-improper
  (assert-equal
    (make-constant 5)
    (expand
      '(builtin-let-syntax
         (foo
           (syntax-rules ()
             ((foo x ... . y) (x ... y))))
         (foo quote . 5))
      builtins-environment)))


(test builtin-syntax-rules-ellipsis-zip
  (assert-equal
    (make-constant '((1 . 3) (2 . 4)))
    (expand
      '(builtin-let-syntax
         (zip
           (syntax-rules ()
             ((zip (x ...) (y ...))
               (quote ((x . y) ...)))))
         (zip (1 2) (3 4)))
      builtins-environment)))


(test builtin-syntax-rules-ellipsis-nested
  (assert-equal
    (make-constant '(1 2 3 4 5))
    (expand
      '(builtin-let-syntax
         (append
           (syntax-rules ()
             ((append (x ...) ...)
               (quote (x ... ...)))))
         (append (1 2) (3 4) () (5)))
      builtins-environment)))


(test builtin-syntax-rules-ellipsis-custom
  (assert-equal
    (make-constant 5)
    (expand
      '(builtin-let-syntax
         (foo
           (syntax-rules ::: ()
             ((foo x :::) (x :::))))
         (foo quote 5))
      builtins-environment)))


(test builtin-lambda-simple
  (assert-equal
    (make-lambda