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

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

(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 (primcall? x)
  (and (pair? x)
       (memq (first x)
             '(add1
               sub1
               integer->char
               char->integer
               zero?
               null?
               integer?
               char?
               boolean?))))

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

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

(define (emit-tag-check x mask tag)
  (emit-expr x)
  (emit "andl $~a, %eax" mask)
  (emit "cmpl $~a, %eax" tag)
  (emit "movl $0, %eax")
  (emit "sete %al")
  (emit "sall $~a, %eax" boolean-shift)
  (emit "orl $~a, %eax" boolean-tag))

(define (emit-expr x)
  (cond
   ((immediate? x)
    (emit "movl $~a, %eax" (immediate-rep x)))
   ((primcall? x)
    (case (primcall-op x)
      ((add1)
       (emit-expr (primcall-operand1 x))
       (emit "addl $~a, %eax" (immediate-rep 1)))
      ((sub1)
       (emit-expr (primcall-operand1 x))
       (emit "subl $~a, %eax" (immediate-rep 1)))
      ((integer->char)
       (emit-expr (primcall-operand1 x))
       (emit "sall $~a, %eax" (- char-shift fixnum-shift))
       (emit "orl $~a, %eax" char-tag))
      ((char->integer)
       (emit-expr (primcall-operand1 x))
       (emit "shr $~a, %eax" (- char-shift fixnum-shift)))
      ((zero?)
       (emit-expr (primcall-operand1 x))
       ;; Since the tag of fixnums is 0, we can skip an 'andl'
       ;; instruction that would apply the mask to the immediate
       ;; value.
       (emit "cmpl $0, %eax")
       (emit "movl $0, %eax")
       (emit "sete %al")
       (emit "sall $~a, %eax" boolean-shift)
       (emit "orl $~a, %eax" boolean-tag))
      ((null?)
       (emit-expr (primcall-operand1 x))
       (emit "cmpl $~a, %eax" empty-list)
       (emit "movl $0, %eax")
       (emit "sete %al")
       (emit "sall $~a, %eax" boolean-shift)
       (emit "orl $~a, %eax" boolean-tag))
      ((integer?)
       (emit-tag-check (primcall-operand1 x) fixnum-mask fixnum-tag))
      ((char?)
       (emit-tag-check (primcall-operand1 x) char-mask char-tag))
      ((boolean?)
       (emit-tag-check (primcall-operand1 x) boolean-mask boolean-tag))
      (else
       (error "unknown primcall op" (primcall-op x)))))
   (else
    (error "unknown expression" x))))

(define (compile-program x)
  (emit-expr x)
  (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"))