(use-modules (ice-9 format)
             (ice-9 popen)
             (ice-9 rdelim)
             (srfi srfi-1))

;; Assuming a 64 bit intel machine here.
(define wordsize 8)
(define fixnum-mask 3)
(define fixnum-shift 2)
(define fixnum-tag 0)
(define char-mask 255)
(define char-shift 8)
(define char-tag 15)
(define boolean-mask 127)
(define boolean-shift 7)
(define boolean-tag 31)
(define empty-list 47) ;; #b00101111

(define (immediate-rep x)
    (cond
     ((integer? x)
      (ash x fixnum-shift))
     ((char? x)
      (logior (ash (char->integer x) char-shift) char-tag))
     ((boolean? x)
      (logior (ash (if x 1 0) boolean-shift) boolean-tag))
     ((null? x)
      empty-list)))

(define (immediate? x)
  (or (integer? x)
      (char? x)
      (boolean? x)
      (null? x)))

(define (variable? x)
  (symbol? x))

(define (let? x)
  (and (pair? x)
       (eq? (first x) 'let)))

(define (primcall? x)
  (and (pair? x)
       (memq (first x)
             '(add1
               sub1
               integer->char
               char->integer
               zero?
               null?
               integer?
               char?
               boolean?
               + - *
               = < <= > >=
               eq? char=?))))

(define (primcall-op x)
  (first x))

(define (primcall-operand1 x)
  (second x))

(define (primcall-operand2 x)
  (third x))

(define (lookup name env)
  (or (assq-ref env name)
      (error "unbound variable:" name)))

(define (extend-env name si env)
  (cons (cons name si) env))

(define (bindings x)
  (second x))

(define (body x)
  (third x))

(define (emit template-string . args)
  (display "        ")
  (apply format #t template-string args)
  (newline))

(define (emit-tag-check x mask tag si env)
  (emit-expr x si env)
  (emit "and $~a, %rax" mask)
  (emit "cmp $~a, %rax" tag)
  (emit "mov $0, %rax")
  (emit "sete %al")
  (emit "sal $~a, %rax" boolean-shift)
  (emit "or $~a, %rax" boolean-tag))

(define (emit-comparison x y instruction si env)
  (emit-expr y si env)
  (emit "mov %rax, ~a(%rsp)" si)
  (emit-expr x (- si wordsize) env)
  (emit "cmp ~a(%rsp), %rax" si)
  (emit "mov $0, %rax")
  (emit "~a %al" instruction)
  (emit "sal $~a, %rax" boolean-shift)
  (emit "or $~a, %rax" boolean-tag))

(define (emit-primitive-call x si env)
  (case (primcall-op x)
    ((add1)
     (emit-expr (primcall-operand1 x) si env)
     (emit "add $~a, %rax" (immediate-rep 1)))
    ((sub1)
     (emit-expr (primcall-operand1 x) si env)
     (emit "sub $~a, %rax" (immediate-rep 1)))
    ((integer->char)
     (emit-expr (primcall-operand1 x) si env)
     (emit "sal $~a, %rax" (- char-shift fixnum-shift))
     (emit "or $~a, %rax" char-tag))
    ((char->integer)
     (emit-expr (primcall-operand1 x) si env)
     (emit "shr $~a, %rax" (- char-shift fixnum-shift)))
    ((zero?)
     (emit-expr (primcall-operand1 x) si env)
     ;; Since the tag of fixnums is 0, we can skip an 'andl'
     ;; instruction that would apply the mask to the immediate
     ;; value.
     (emit "cmp $0, %rax")
     (emit "mov $0, %rax")
     (emit "sete %al")
     (emit "sal $~a, %rax" boolean-shift)
     (emit "or $~a, %rax" boolean-tag))
    ((null?)
     (emit-expr (primcall-operand1 x) si env)
     (emit "cmp $~a, %rax" empty-list)
     (emit "mov $0, %rax")
     (emit "sete %al")
     (emit "sal $~a, %rax" boolean-shift)
     (emit "or $~a, %rax" boolean-tag))
    ((integer?)
     (emit-tag-check (primcall-operand1 x) fixnum-mask fixnum-tag si env))
    ((char?)
     (emit-tag-check (primcall-operand1 x) char-mask char-tag si env))
    ((boolean?)
     (emit-tag-check (primcall-operand1 x) boolean-mask boolean-tag si env))
    ((+)
     (emit-expr (primcall-operand2 x) si env)
     (emit "mov %rax, ~a(%rsp)" si)
     (emit-expr (primcall-operand1 x) (- si wordsize) env)
     (emit "add ~a(%rsp), %rax" si))
    ((-)
     (emit-expr (primcall-operand2 x) si env)
     (emit "mov %rax, ~a(%rsp)" si)
     (emit-expr (primcall-operand1 x) (- si wordsize) env)
     (emit "sub ~a(%rsp), %rax" si))
    ((*)
     (emit-expr (primcall-operand2 x) si env)
     (emit "mov %rax, ~a(%rsp)" si)
     (emit-expr (primcall-operand1 x) (- si wordsize) env)
     (emit "imul ~a(%rsp), %rax" si)
     ;; When two fixnums (which have 2 tag bits) are multiplied, the
     ;; relevant bits for the result are now 4 bytes to the left, so
     ;; we have to shift back 2 bytes.
     (emit "shr $~a, %rax" fixnum-shift))
    ((=)
     (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "sete" si env))
    ((<)
     (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "setl" si env))
    ((<=)
     (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "setle" si env))
    ((>)
     (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "setg" si env))
    ((>=)
     (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "setge" si env)
    ((eq?)
     (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "sete" si env)))
    ((char=?)
     (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "sete" si env))
    (else
     (error "unknown primcall op" (primcall-op x)))))

(define (emit-let bindings body si env)
  (define (lhs b)
    (first b))
  (define (rhs b)
    (second b))
  (let loop ((b* bindings) (new-env env) (si si))
    (if (null? b*)
        (emit-expr body si new-env)
        (let ((b (first b*)))
          (emit-expr (rhs b) si env)
          (emit "mov %rax, ~a(%rsp)" si)
          (loop (cdr b*)
                (extend-env (lhs b) si new-env)
                (- si wordsize))))))

(define (emit-expr x si env)
  (cond
   ((immediate? x)
    (emit "mov $~a, %rax" (immediate-rep x)))
   ((variable? x)
    (emit "mov ~a(%rsp), %rax" (lookup x env)))
   ((let? x)
    (emit-let (bindings x) (body x) si env))
   ((primcall? x)
    (emit-primitive-call x si env))
   (else
    (error "unknown expression" x))))

(define (compile-program x)
  (emit-expr x (- wordsize) '())
  (emit "ret"))

(define (compile-and-run x)
  (with-output-to-file "scheme_entry.S"
    (lambda ()
      (display ".text
.p2align 4
.globl	scheme_entry
.type	scheme_entry, @function
scheme_entry:
")
      (compile-program x)))
  (and (zero? (system* "gcc" "-c" "scheme_entry.S"))
       (zero? (system* "gcc" "-c" "test.c"))
       (zero? (system* "gcc" "-o" "test" "scheme_entry.o" "test.o"))
       (let* ((pipe (open-pipe* OPEN_READ "./test"))
              (output (read-line pipe)))
         (close pipe)
         output)))

(define (test-case x expected-output)
  (let ((result (compile-and-run x)))
    (if (string=? result expected-output)
        #t
        (begin
          (display "expected: ")
          (display expected-output)
          (display ", got: ")
          (display result)
          (newline)
          #f))))

(begin
  (test-case 1 "1")
  (test-case #\b "b")
  (test-case #t "#t")
  (test-case #f "#f")
  (test-case '(add1 3) "4")
  (test-case '(sub1 3) "2")
  (test-case '(integer->char 98) "b")
  (test-case '(char->integer #\b) "98")
  (test-case '(zero? 1) "#f")
  (test-case '(zero? 0) "#t")
  (test-case '(null? 1) "#f")
  (test-case '(null? #\b) "#f")
  (test-case '(null? #t) "#f")
  (test-case '(null? #f) "#f")
  (test-case '(null? ()) "#t")
  (test-case '(integer? #\b) "#f")
  (test-case '(integer? #f) "#f")
  (test-case '(integer? 1) "#t")
  (test-case '(char? 1) "#f")
  (test-case '(char? #f) "#f")
  (test-case '(char? #\b) "#t")
  (test-case '(boolean? 1) "#f")
  (test-case '(boolean? #\b) "#f")
  (test-case '(boolean? #f) "#t")
  (test-case '(boolean? #t) "#t")
  (test-case '(+ 1 2) "3")
  (test-case '(- 3 1) "2")
  (test-case '(* 2 3) "6")
  (test-case '(= 1 2) "#f")
  (test-case '(= 1 1) "#t")
  (test-case '(< 2 1) "#f")
  (test-case '(< 1 2) "#t")
  (test-case '(<= 2 1) "#f")
  (test-case '(<= 1 2) "#t")
  (test-case '(<= 2 2) "#t")
  (test-case '(> 1 2) "#f")
  (test-case '(> 2 1) "#t")
  (test-case '(>= 1 2) "#f")
  (test-case '(>= 2 1) "#t")
  (test-case '(>= 2 2) "#t")
  (test-case '(char=? #\a #\b) "#f")
  (test-case '(char=? #\b #\b) "#t")
  (test-case '(let ((x 1)) x) "1")
  (test-case '(let ((x 1) (y 2)) (+ x y)) "3"))