forms.scm

(define (tagged-list? x tag)
  (if (and (list? x) (not (null? x)))
    (eq? (car x) tag)
    #f))

(define (immediate? x)
  (cond
    ((fixnum? x) #t)
    ((char? x) #t)
    ((boolean? x) #t)
    ((null? x) #t)
    (else #f)))

(define (list-primcall? x) (tagged-list? x 'list))
(define (vector-primcall? x) (tagged-list? x 'vector))

(define (or? x) (tagged-list? x 'or))
(define (and? x) (tagged-list? x 'and))

(define (primcall-operator x) (car x))
(define (primcall-operand1 x) (cadr x))
(define (primcall-operand2 x) (caddr x))
(define (primcall-operand3 x) (cadddr x))
(define (primcall? x)
  (if (list? x)
    (let ((op (primcall-operator x)))
      (or
        (eq? op 'add1)
        (eq? op 'sub1)
        (eq? op 'bit-or)
        (eq? op 'bit-and)
        (eq? op 'shift-left)
        (eq? op 'shift-right)
        (eq? op '+)
        (eq? op '-)
        (eq? op '*)
        (eq? op '/)
        (eq? op '<)
        (eq? op '<=)
        (eq? op '>)
        (eq? op '>=)
        (eq? op 'eq?)
        (eq? op 'equal?)
        (eq? op 'bin-and)
        (eq? op 'bin-or)
        (eq? op 'not)
        (eq? op 'cons)
        (eq? op 'car)
        (eq? op 'cdr)
        (eq? op 'list-ref)
	(eq? op 'vector-init)
	(eq? op 'vector-ref)
	(eq? op 'vector-set!)
	(eq? op 'string-length)
	(eq? op 'string-ref)
	(eq? op 'string-append)
	(eq? op 'string->symbol)
	(eq? op 'fixnum->string)
	(eq? op 'symbol->string)
	(eq? op 'char->string)
	(eq? op 'any->string)
	(eq? op 'char->fixnum)
	(eq? op 'boolean->fixnum)
	(eq? op 'list-ref)
	(eq? op 'boolean?)
	(eq? op 'null?)
	(eq? op 'list?)
	(eq? op 'fixnum?)
	(eq? op 'char?)
	(eq? op 'pair?)
	(eq? op 'string?)
	(eq? op 'symbol?)
	(eq? op 'display)
	(eq? op 'newline)
	(eq? op 'open-input-file)
	(eq? op 'open-output-file)
	(eq? op 'open-i/o-file)
	(eq? op 'eof-object?)
	(eq? op 'read-char)
	(eq? op 'argc)
	(eq? op 'argv)
	(eq? op 'exit)))
    #f))

(define (if? x) (tagged-list? x 'if))
(define (if-test x) (cadr x))
(define (if-conseq x) (caddr x))
(define (if-altern x) (cadddr x))
(define (make-if test conseq altern)
  (list 'if test conseq altern))

(define (make-body x) (cons x '()))

(define (let? x) (tagged-list? x 'let))
(define (let*? x) (tagged-list? x 'let*))
(define (let-bindings x) (cadr x))
(define (let-binding-var x) (car x))
(define (let-binding-val x) (cadr x))
(define (let-bindings-vars x)
  (map let-binding-var (let-bindings x)))
(define (let-bindings-vals x)
  (map let-binding-val (let-bindings x)))
(define (let-body x) (cddr x))
(define (make-let* bindings body)
  (if (null? bindings)
    (car body)
    (cons 'let* (cons bindings body))))
(define (make-let bindings body)
  (if (null? bindings)
    (car body)
    (cons 'let (cons bindings body))))

(define (begin? x) (tagged-list? x 'begin))
(define (begin-body x) (cdr x))
(define (make-begin body)
  (cond
    ((null? body) (error "begin body must not be empty"))
    ((null? (cdr body)) (car body))
    (else (cons 'begin body))))

(define (cond? x) (tagged-list? x 'cond))
(define (cond-clauses x) (cdr x))
(define (cond-clause-test x) (car x))
(define (cond-clause-body x) (cdr x))

(define (function? x) (tagged-list? x 'function))
(define (function-name x) (cadr x))
(define (function-args x) (caddr x))
(define (function-free-vars x) (cadddr x))
(define (function-body x) (caddddr x))
(define (make-function name args free-vars body)
  (cons 'function (cons name (cons args (cons free-vars body)))))

(define (function-name->ll-name x)
  (string-append "function_" x))

(define (lambda? x) (tagged-list? x 'lambda))
(define (lambda-args x) (cadr x))
(define (lambda-body x) (cddr x))
(define (make-lambda args body)
  (cons 'lambda (cons args body)))

(define (closure? x) (tagged-list? x 'closure))
(define (closure-function x) (cadr x))
(define (closure-arity x) (caddr x))
(define (closure-free-vars x) (cadddr x))
(define (make-closure name arity free-vars)
  (list 'closure name arity free-vars))

(define (args-signature n)
  (cond
    ((eq? n 0) "")
    ((eq? n 1) "i64")
    (else (string-append "i64, "
			 (args-signature (- n 1))))))

(define (args-string arg-vars)
  (cond
    ((null? arg-vars) "")
    ((eq? (length arg-vars) 1) (format "i64 ~A" (list (car arg-vars))))
    (else (string-append (format "i64 ~A, " (list (car arg-vars)))
			 (args-string (cdr arg-vars))))))

(define (var? x) (symbol? x))

(define (ll-var-name x) (list->string (drop (string->list x 1) 1)))
(define (local-ll-var? x) (eq? (string-ref x 0) #\%))
(define (global-ll-var? x) (eq? (string-ref x 0) #\@))
(define (make-ll-local-var str) (string-append "%" str))
(define (make-ll-global-var str) (string-append "@" str))

(define (myquote? x) (tagged-list? x 'myquote))
(define (myquote-content x) (cadr x))
(define (make-myquote content) (list 'myquote content))
(define (myquote x) (make-myquote x))

(define (quasimyquote? x) (tagged-list? x 'quasimyquote))
(define (quasimyquote-content x) (cadr x))
(define (make-quasimyquote content) (list 'quasimyquote content))
(define (quasimyquote x) (make-quasimyquote x))

(define (unmyquote? x) (tagged-list? x 'unmyquote))
(define (unmyquote-content x) (cadr x))
(define (make-unmyquote content) (list 'unmyquote content))
(define (unmyquote x) (make-unmyquote x))

(define (set-car!? x) (tagged-list? x 'set-car!))
(define (set-car!-id x) (cadr x))
(define (set-car!-expr x) (cddr x))

(define (set-cdr!? x) (tagged-list? x 'set-cdr!))
(define (set-cdr!-id x) (cadr x))
(define (set-cdr!-expr x) (cddr x))

(define (define? x) (tagged-list? x 'define))
(define (define-id x) (cadr x))
(define (define-function? x)
  (and (define? x) (list? (define-id x))))
(define (define-function-name x) (car (define-id x)))
(define (define-function-args x) (cdr (define-id x)))
(define (define-var? x)
  (and (define? x) (symbol? (define-id x))))
(define (define-body x) (cddr x))
(define (make-define id body)
  (cons 'define (cons id body)))
(define (make-define-function-id name args)
  (cons name args))
(define (make-define-function name args body)
  (make-define (make-define-function-id name args) body))
(define (make-define-var name body)
  (make-define name body))

(define (set!? x) (tagged-list? x 'set!))
(define (set!-var x) (cadr x))
(define (set!-val x) (caddr x))
(define (make-set! var val) (list 'set! var val))