(import (scheme base)
        (only (csc gensym)
          gensym
          gensym?)
        (only (csc ir1)
          %call
          %constant
          %define-syntax
          %if
          %lambda
          %letrec
          %lexical-ref
          %lexical-set
          %library-define
          %library-ref
          %sequence
          call?
          constant-expression
          constant?
          define-syntax?
          if?
          lambda?
          letrec?
          lexical-ref-name
          lexical-ref?
          lexical-set-expression
          lexical-set?
          library-define?
          library-ref?
          make-constant
          make-lambda
          make-letrec
          make-lexical-ref
          make-library-ref
          make-sequence
          sequence?)
        (only (csc testing)
          assert-equal
          test)
        (csc macros))


(define transform-ir1
  (list
    (cons constant? %constant)
    (cons lexical-ref? %lexical-ref)
    (cons library-ref? %library-ref)
    (cons lexical-set? %lexical-set)
    (cons library-define? %library-define)
    (cons define-syntax? %define-syntax)
    (cons if? %if)
    (cons call? %call)
    (cons sequence? %sequence)
    (cons lambda? %lambda)
    (cons letrec? %letrec)
    (cons gensym? (lambda (x) 'gensym))))


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


(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)
    transform-ir1))


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


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


(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)
    transform-ir1))


(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)
    transform-ir1))


(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)
    transform-ir1))


(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)
    transform-ir1))


(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)
    transform-ir1))


(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)
    transform-ir1))


(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)
    transform-ir1))


(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)
    transform-ir1))


(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)
    transform-ir1))


(define (test-ref sym)
  (make-lexical-ref sym (gensym)))


(test builtin-lambda-rest
  (assert-equal
    (make-lambda (list
                   (test-ref 'a)
                   (test-ref 'b)
                   (test-ref 'c))
                 (test-ref 'd)
                 (make-sequence (make-constant #f) (make-constant 5)))
    (expand
      '(lambda
         (a b c . d) (quote 5))
      builtins-environment)
    transform-ir1))


(test builtin-case-lambda-defines
  (assert-equal
    (make-lambda (list (test-ref 'x)) #f
      (make-letrec #t '(a b) #f
        (list (make-constant 6)
              (test-ref 'a))
        (make-sequence (make-constant #f) (make-constant 7))))
    (expand
      '(lambda (x)
        (builtin-define a (quote 6))
        (builtin-define b a)
        (quote 7))
      builtins-environment)
    transform-ir1))