(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 (emit template-string . args)
  (apply format #t template-string args)
  (newline))

(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 (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 (emit-tag-check x mask tag si)
  (emit-expr x si)
  (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)
  (emit-expr y si)
  (emit "mov %rax, ~a(%rsp)" si)
  (emit-expr x (- si wordsize))
  (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)
  (case (primcall-op x)
    ((add1)
     (emit-expr (primcall-operand1 x) si)
     (emit "add $~a, %rax" (immediate-rep 1)))
    ((sub1)
     (emit-expr (primcall-operand1 x) si)
     (emit "sub $~a, %rax" (immediate-rep 1)))
    ((integer->char)
     (emit-expr (primcall-operand1 x) si)
     (emit "sal $~a, %rax" (- char-shift fixnum-shift))
     (emit "or $~a, %rax" char-tag))
    ((char->integer)
     (emit-expr (primcall-operand1 x) si)
     (emit "shr $~a, %rax" (- char-shift fixnum-shift)))
    ((zero?)
     (emit-expr (primcall-operand1 x) si)
     ;; 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)
     (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))
    ((char?)
     (emit-tag-check (primcall-operand1 x) char-mask char-tag si))
    ((boolean?)
     (emit-tag-check (primcall-operand1 x) boolean-mask boolean-tag si))
    ((+)
     (emit-expr (primcall-operand2 x) si)
     (emit "mov %rax, ~a(%rsp)" si)
     (emit-expr (primcall-operand1 x) (- si wordsize))
     (emit "add ~a(%rsp), %rax" si))
    ((-)
     (emit-expr (primcall-operand2 x) si)
     (emit "mov %rax, ~a(%rsp)" si)
     (emit-expr (primcall-operand1 x) (- si wordsize))
     (emit "sub ~a(%rsp), %rax" si))
    ((*)
     (emit-expr (primcall-operand2 x) si)
     (emit "mov %rax, ~a(%rsp)" si)
     (emit-expr (primcall-operand1 x) (- si wordsize))
     (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))
    ((<)
     (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "setl" si))
    ((<=)
     (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "setle" si))
    ((>)
     (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "setg" si))
    ((>=)
     (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "setge" si))
    ((eq?)
     (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "sete" si))
    ((char=?)
     (emit-comparison (primcall-operand1 x) (primcall-operand2 x) "sete" si))
    (else
     (error "unknown primcall op" (primcall-op x)))))


(define (emit-expr x si)
  (cond
   ((immediate? x)
    (emit "mov $~a, %rax" (immediate-rep x)))
   ((primcall? x)
    (emit-primitive-call x si))
   (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"))