;;-*-Lisp-*-


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; OTHER STUFF
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; get list of all goal files
(asm-file "goal_src/build/all_files.gc")

;; tell compiler about stuff defined/implemented in the runtime.
(asm-file "goal_src/kernel-defs.gc")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; BUILD SYSTEM
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro m (file)
  "Make: compile a file fully and save the result"
  `(asm-file ,file :color :write)
  )

(defmacro md (file &rest path)
  "Make Debug: make + print disassembly for a file"
  (if (null? path)
      `(asm-file ,file :color :write :disassemble)
      `(asm-file ,file :color :write :disassemble ,(first path))
      )
  )

(defmacro ml (file)
  "Make Load: make and load the file through the listener"
  `(asm-file ,file :color :load :write)
  )

(desfun make-build-command (file)
  `(asm-file ,file :color :write)
  )


(defmacro build-kernel ()
  "Build kernel and create the KERNEL CGO"
  `(begin
     ,@(apply make-build-command all-kernel-goal-files)
     (build-dgos "goal_src/build/kernel_dgos.gc")
     )
  )

(defmacro build-game ()
  "Build all game code and all game CGOs"
  `(begin
     (build-kernel)
     ,@(apply make-build-command all-goal-files)
     (build-dgos "goal_src/build/game_dgos.gc")
     )
  )

(defmacro build-data ()
  "Build all game data"
  `(begin
     (asm-data-file game-text "assets/game_text.txt")
     (asm-data-file game-count "assets/game_count.txt")
     (asm-data-file dir-tpages "assets/tpage-dir.txt")
     )
  )

(defmacro blg ()
  "Build engine and kernel CGOs (code only, no data for now) and load them in the listener
   Uses the blocking dgo-load."
  `(begin
     (build-game)
     (dgo-load "kernel" global #xf #x200000)
     (load-package "game" global)
     )
  )

(defmacro lg ()
  "Load an already built game."
  `(load-package "game" global)
  )

(defmacro tc ()
  "Typecheck against the all-types file"
  `(m "decompiler/config/all-types.gc")
  )

(defmacro e ()
  "Exit the compiler"
  `(:exit)
  )

(defmacro dbc ()
  "Put the compiler in debug mode"
  `(begin
    (set-config! print-ir #t)
    (set-config! print-regalloc #t)
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; CONDITIONAL COMPILATION
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro #when (clause &rest body)
  `(#cond (,clause ,@body))
  )

(defmacro #unless (clause &rest body)
  `(#cond ((not ,clause) ,@body))
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TARGET CONTROL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro lt (&rest args)
  "Listen to target. Opens a connection and flushes buffers"
  `(begin
     (listen-to-target ,@args)
     (:status)
     )
  )

(defmacro r (&rest args)
  "Reset the target state and reconnect."
  `(begin
     ;; connect, so we can send reset.  if we're already connected, does nothing
     (listen-to-target ,@args)
     ;; send a reset message, disconnecting us
     (reset-target)
     ;; establish connection again
     (listen-to-target ,@args)
     ;; flush buffers
     (:status)
     )
  )

(defmacro shutdown-target ()
  "Make the target exit. The runtime itself will exit and not restart automatically."
  `(begin
    (reset-target :shutdown)
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DEBUGGER MACROS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro db (&rest args)
  "Print bytes."
  `(:pm 1 ,@args)
  )

(defmacro dh (&rest args)
  "Print halfwords (16-bits)"
  `(:pm 2 ,@args)
  )

(defmacro dw (&rest args)
  "Print words (32-bits)"
  `(:pm 4 ,@args)
  )

(defmacro dd (&rest args)
  "Print doublewords (64-bits)"
  `(:pm 8 ,@args)
  )

(defmacro df (&rest args)
  "Print floats (32-bit)"
  `(:pm 4 ,@args :print-mode float)
  )

(defmacro segfault ()
  "Dereference the GOAL 0 pointer, which should be a segfault"
  `(-> (the (pointer int) 0))
  )

(defmacro fpe ()
  "Trigger a SIGFPE by doing integer division by zero"
  `(/ 0 0)
  )

(defmacro break! ()
  "A breakpoint. Todo - should we use int3 instead?"
  `(/ 0 0)
  )

(defmacro crash! ()
  "Cause a crash by attempting to deference 0x0"
  `(-> (the (pointer uint8) 0))
  )

;;;;;;;;;;;;;;;;;;;
;; GOAL Syntax
;;;;;;;;;;;;;;;;;;;
;; Bind vars in body
(defmacro let (bindings &rest body)
  `((lambda :inline-only #t ,(apply first bindings) ,@body)
    ,@(apply second bindings)))

;; Let, but recursive, allowing you to define variables in terms of others.
(defmacro let* (bindings &rest body)
  (if (null? bindings)
    `(begin ,@body)
    `((lambda :inline-only #t (,(caar bindings))
        (let* ,(cdr bindings) ,@body))
      ,(car (cdar bindings))
      )
    )
  )

;; Define a new function
(defmacro defun (name bindings &rest body)
  (if (and
        (> (length body) 1)      ;; more than one thing in function
        (string? (first body))   ;; first thing is a string
        )
    ;; then it's a docstring and we ignore it.
    `(define ,name (lambda :name ,name ,bindings ,@(cdr body)))
    ;; otherwise don't ignore it.
    `(define ,name (lambda :name ,name ,bindings ,@body))
    )
  )

;; the compiler can't figure out types of a recursive function without
;; first knowing the return type, so we use this form to forward declare
;; and define a function.
(defmacro defun-recursive (name return-type bindings &rest body)
  `(begin
    (define-extern ,name
        (function ,@(apply (lambda (x)
                             (if (pair? x)
                                 (second x)
                                 'object)
                             )
                           bindings)
                  ,return-type))
    (defun ,name ,bindings ,@body)
    )
  )

(defmacro defun-extern (function-name &rest type-info)
  `(define-extern ,function-name (function ,@type-info))
  )

(defmacro defun-debug (name bindings &rest body)
  "Define a function which is only present in debug mode. Otherwise the function becomes nothing"
  `(if *debug-segment*
       ,(if (and
             (> (length body) 1)      ;; more than one thing in function
             (string? (first body))   ;; first thing is a string
             )
           ;; then it's a docstring and we ignore it.
           `(define ,name (lambda :name ,name :segment debug ,bindings ,@(cdr body)))
           ;; otherwise don't ignore it.
           `(define ,name (lambda :name ,name :segment debug ,bindings ,@body))
           )

       ;; function not loaded, set function to the nothing function.
       ;; we don't typecheck this.
       (define :no-typecheck #t ,name nothing)
       )
  )

(defmacro define-perm (name type value)
  "Define 'permanent', meaning the original definition will not be blown away by a file reload.
   If the value of the symbol is unset (zero) or set to false, it will be defined.
   Otherwise, no effect, other than to inform the type system of the symbol type."
  `(begin
    (define-extern ,name ,type)
    (if (or (not ,name) (zero? ,name))
        (set! ,name ,value)
        )
    )
  )

(defmacro while (test &rest body)
  "While loop. The test is evaluated before body."
  (with-gensyms (reloop test-exit)
    `(begin
       (goto ,test-exit)
       (label ,reloop)
       ,@body
       (label ,test-exit)
       (when-goto ,test ,reloop)
       #f
       )
    )
  )

(defmacro until (test &rest body)
  "Until loop. The body is evaluated before the test."
  (with-gensyms (reloop)
    `(begin
       (label ,reloop)
       ,@body
       (when-goto (not ,test) ,reloop)
       )
    )
  )

(defmacro dotimes (var &rest body)
  "Loop like for (int i = 0; i < end; i++)"
  `(let (( ,(first var) 0))
     (while (< ,(first var) ,(second var))
            ,@body
            (1+! ,(first var))
            )
     ,@(cddr var)
     )
  )

(defmacro countdown (var &rest body)
  "Loop like for (int i = end; i-- > 0)"
  `(let ((,(first var) ,(second var)))
     (while (!= ,(first var) 0)
       (set! ,(first var) (- ,(first var) 1))
       ,@body
       )
     )
  )

;; Backup some values, and restore after executing body.
;; Non-dynamic (nonlocal jumps out of body will skip restore)
;; NOTE : GOAL protected defs in a FIFO manner (this is FILO/LIFO), this should be fixed at some point
(defmacro protect (defs &rest body)
  (if (null? defs)
    ;; nothing to backup, just insert body (base case)
    `(begin ,@body)

    ;; a unique name for the thing we are backing up
    (with-gensyms (backup)
                  ;; store the original value of the first def in backup
                  `(let ((,backup ,(first defs)))
                     ;; backup any other things which need backing up
                     (protect ,(cdr defs)
                              ;; execute the body
                              ,@body
                              )
                     ;; restore the first thing
                     (set! ,(first defs) ,backup)
                     )
                  )
    )
  )

(defmacro if (condition true-case &rest others)
  (if (> (length others) 1)
      (error "got too many arguments to if")
      #f
      )
  (if (null? others)
    `(cond (,condition ,true-case))
    `(cond (,condition ,true-case)
           (else ,(first others))
           )
    )
  )

(defmacro when (condition &rest body)
  `(if ,condition
       (begin ,@body)
       )
  )

(defmacro unless (condition &rest body)
  `(if (not ,condition)
     (begin ,@body)
     )
  )

(defmacro swhen (condition &rest body)
  "Same as when, but saves the branch condition onto a variable named bc"

  `(let ((bc ,condition))
      (if bc
          (begin ,@body)
          )
      )
  )

(defmacro return (val)
  `(return-from #f ,val)
  )


(defmacro empty ()
  "The decompiler may use (empty) as the body of a loop with nothing in it."
  `(none)
  )

(defmacro case (switch &rest cases)
  "A switch-case construct. switch is saved onto a local variable and compared against each case, sequentially.
   else can be used like the 'default' case, but it must be the last one."

  (with-gensyms (sw)
    ;; save the switch to a variable (only evaluated once)
    `(let ((sw ,switch))
        ;; build the cond construct with each case
        (cond ,@(apply
                  (lambda (x) `(
                      ;; each case is of format ((cond cond cond...) body)
                      ,@(let ((conditions (first x)) ;; list of conditions, OR just else
                              (body (rest x))) ;; the body

                        (cond
                          ;; if the condition is just 'else'
                          ( (eq? conditions 'else)
                            `(else ,@body)
                            )
                          ;; if the list is made up of a single condition
                          ( (= (length conditions) 1)
                            `((= sw ,(first conditions)) ,@body)
                            )
                          ;; otherwise it is made up of multiple conditions, or them together!
                          (#t
                            `((or ,@(apply (lambda (c) `(= sw ,c)) conditions)) ,@body)
                            )
                          )

                        )
                      )
                    )
                   cases)
                   )
        )
    )
  )

;;;;;;;;;;;;;;;;;;;
;; Math Macros
;;;;;;;;;;;;;;;;;;;

(defmacro 1+ (var)
  `(+ ,var 1)
  )

(defmacro +! (place amount)
  `(set! ,place (+ ,place ,amount))
  )

(defmacro 1+! (place)
  `(set! ,place (+ 1 ,place))
  )

(defmacro 1- (var)
  `(- ,var 1)
  )

(defmacro -! (place amount)
  `(set! ,place (- ,place ,amount))
  )

(defmacro 1-! (place)
  `(set! ,place (- 1 ,place))
  )

(defmacro *! (place amount)
  `(set! ,place (* ,place ,amount))
  )

(defmacro zero? (thing)
  `(eq? ,thing 0)
  )

(defmacro nonzero? (thing)
  `(neq? ,thing 0)
  )

(defmacro &+! (val amount)
  `(set! ,val (&+ ,val ,amount))
  )

(defmacro &- (a b)
  `(- (the-as int ,a) (the-as int ,b))
  )

(defmacro &-> (&rest args)
  `(& (-> ,@args))
  )

(defmacro logior! (place amount)
  `(set! ,place (logior ,place ,amount))
  )

(defmacro logxor! (place amount)
  `(set! ,place (logxor ,place ,amount))
  )

(defmacro lognor! (place amount)
  `(set! ,place (lognor ,place ,amount))
  )

(defmacro logand! (place amount)
  `(set! ,place (logand ,place ,amount))
  )

(defmacro deref (t addr &rest fields)
  `(-> (the-as (pointer ,t) ,addr) ,@fields)
  )

(defmacro &deref (t addr &rest fields)
  `(&-> (the-as (pointer ,t) ,addr) ,@fields)
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Bit Macros
;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro align16 (value)
  `(logand #xfffffff0 (+ (the-as integer ,value) 15))
  )

(defmacro align64 (value)
  `(logand -64 (&+ (the-as pointer ,value) 63))
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TYPE STUFF
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro basic? (obj)
  ;; todo, make this more efficient
  `(= 4 (logand (the integer ,obj) #b111))
  )

(defmacro pair? (obj)
  ;; todo, make this more efficient
  ;`(= 2 (logand (the integer ,obj) #b111))
  `(< (shl (the-as int ,obj) 62) 0)
  )

(defmacro not-pair? (obj)
  `(>= (shl (the-as int ,obj) 62) 0)
  )

(defmacro binteger? (obj)
  `(zero? (logand (the integer ,obj) #b111))
  )

(defmacro rtype-of (obj)
  `(cond ((binteger? ,obj) binteger)
         ((pair? ,obj) pair)
         (else (-> (the basic ,obj) type))
         )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PAIR STUFF
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defmacro cons (a b)
  `(new 'global 'pair ,a ,b)
  )

(defmacro list (&rest args)
  (if (null? args)
    (quote '())
    `(cons ,(car args) (list ,@(cdr args)))
    )
  )

(defmacro null? (arg)
  ;; todo, make this better
  `(eq? ,arg '())
  )

(defmacro caar (arg)
  `(car (car ,arg))
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; METHOD STUFF
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defmacro object-new (allocation type-to-make &rest sz)
  (if (null? sz)
    `(the ,(current-method-type) ((method-of-type object new) ,allocation ,type-to-make (the int (-> ,type-to-make size))))
    `(the ,(current-method-type) ((method-of-type object new) ,allocation ,type-to-make ,@sz))
    )
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TEST STUFF
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro expect-eq (a b &key (name "unknown"))
  `(if (!= ,a ,b)
       (format #t "Test Failed On Test ~D: ~A~%" *test-count* ,name)
       (+! *test-count* 1)
       )
  )

(defmacro expect-true (a)
  `(expect-eq ,a #t)
  )

(defmacro expect-false (a)
  `(expect-eq ,a #f)
  )

(defmacro start-test (test-name)
  `(begin
     (define *test-name* ,test-name)
     (define *test-count* 0)
     )
  )

(defmacro finish-test ()
  `(format #t "Test ~A: ~D Passes~%" *test-name* *test-count*)
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; (Fake) MIPS Macros
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; these are macros for MIPS instructions which we may want to keep in the source code for
;; readibility/curiosity/documentation, but will not translate into any actual instructions at all

;; A macro that generates a macro for the specified instruction
(defmacro fake-asm (asm-name &rest args)
  `(defmacro ,asm-name (,@args) `(none))
  )