;;-*-Lisp-*-
(in-package goal)

;; name: gcommon.gc
;; name in dgo: gcommon
;; dgos: KERNEL

;; DECOMP BEGINS

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Game constants
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; disable PS2 only code and enable PC-specific code
(defglobalconstant PC_PORT #t)
;; removes level loading d3mo mode changes when enabled
(defglobalconstant DEMO_HACK #f)

;; whether we're allowed to use more memory than the original game or not
(defglobalconstant BIG_MEMORY #t)
(defglobalconstant PC_BIG_MEMORY (and PC_PORT BIG_MEMORY))

;; redirects access to EE memory mapped registers through get-vm-ptr to valid addresses that
;; are monitored in the runtime for debugging.
(defglobalconstant USE_VM #t)

;; enables the with-profiler statements, which send profiling data from
;; GOAL code to the frame profiler in C++.
(defglobalconstant PC_PROFILER_ENABLE #t)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GOAL language constants
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; distance from a symbol pointer to a (pointer string)
;; this relies on the memory layout of the symbol table
;; this must match SYM_TO_STRING_OFFSET in goal_constants.h
(defconstant SYM_TO_STRING_OFFSET #xff37)

(defmacro symbol->string (sym)
  "Convert a symbol to a goal string."
  `(-> (the-as (pointer string) (+ SYM_TO_STRING_OFFSET (the-as int ,sym))))
  )

;; pointers larger than this are invalid by valid?
(defconstant END_OF_MEMORY #x8000000)

(defun identity ((arg0 object))
  "Return the input. Works for any 64-bit value."
  arg0
  )

(defun 1/ ((arg0 float))
  "Floating point reciprocal"
  (declare (inline))
  (/ 1.0 arg0)
  )

;; These functions exist a function objects that wrap the compiler's built-in operators.

(defun + ((arg0 int) (arg1 int))
  "Add two integers (64-bit)."
  (+ arg0 arg1)
  )

(defun - ((arg0 int) (arg1 int))
  "Subtract two integers (64-bit)."
  (- arg0 arg1)
  )

(defun * ((arg0 int) (arg1 int))
  "Multiply two integers (32-bit)"
  (* arg0 arg1)
  )

(defun / ((arg0 int) (arg1 int))
  "Divide two integers (32-bit, signed)"
  (/ arg0 arg1)
  )

(defun mod ((arg0 int) (arg1 int))
  "Integer mod (signed, 32-bit)"
  (mod arg0 arg1)
  )

(defun rem ((arg0 int) (arg1 int))
  "Integer mod (signed, 32-bit). Even though it's called rem, it behaves the same as mod."
  (mod arg0 arg1)
  )


(defun ash ((value int) (shift-amount int))
  "Arithmetic shift value by shift-amount.
  A positive shift-amount will shift to the left and a negative will shift to the right."
  ;; OpenGOAL does not support ash in the compiler, so we implement it here as an inline function.
  (declare (inline))
  (if (> shift-amount 0)
      (shl value shift-amount)
      (sar value (- shift-amount))
      )
  )

(defun abs ((a int))
  "Take the absolute value of a 64-bit signed integer"
  (declare (inline))
  ;; OpenGOAL doesn't support abs, so we implement it here.
  (if (> a 0)
      a
      (- a)
      )
  )

(defun min ((a int) (b int))
  "Compute minimum of two 64-bit signed integers."
  (declare (inline))
  ;; OpenGOAL doesn't support min, so we implement it here.
  (if (> a b) b a)
  )

(defun max ((a int) (b int))
  "Compute maximum of two 64-bit signed integer."
  (declare (inline))
  ;; OpenGOAL doesn't support max so we implement it here.
  (if (> a b) a b)
  )

(defun logior ((arg0 int) (arg1 int))
  "Logical or (64-bit)"
  (logior arg0 arg1)
  )

(defun logand ((arg0 int) (arg1 int))
  "Logical and (64-bit)"
  (logand arg0 arg1)
  )

(defun lognor ((a int) (b int))
  "Compute not or (64-bit)."
  ;; Note - MIPS has a 'nor' instruction, but x86 doesn't.
  ;; the OpenGOAL x86 compiler therefore doesn't have a nor operation,
  ;; so lognor is implemented by this inline function instead.
  (declare (inline))
  (lognot (logior a b))
  )

(defun logxor ((arg0 int) (arg1 int))
  "Logical exclusive or (64-bit)"
  (logxor arg0 arg1)
  )

(defun lognot ((arg0 int))
  "Logical not (64-bit)"
  (lognot arg0)
  )

(defun false-func ()
  "Return #f."
  #f
  )

(defun true-func ()
  "Return #t."
  #t
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; format
;;;;;;;;;;;;;;;;;;;;;;;;;;

;; The "format" function is implemented in C but is called _format.
;; This defines the format function to point to the same thing as _format.
(define format _format)

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; numeric types
;;;;;;;;;;;;;;;;;;;;;;;;;;

;; vec4s: 4 floats packed into a 128-bit integer register. This is rarely used.
(deftype vec4s (uint128)
  ((x float :offset   0 :size  32)
   (y float :offset  32 :size  32)
   (z float :offset  64 :size  32)
   (w float :offset  96 :size  32)
   )
  )

(defmethod print ((this vec4s))
  "Custom print for vec4s that prints the 4 values."
  (format #t "#<vector ~F ~F ~F ~F @ #x~X>"
          (-> this x)
          (-> this y)
          (-> this z)
          (-> this w)
          this)
  this
  )

;; vector: main 4-element floating point vector.
(deftype vector (structure)
  ((data  float    4)
   (x     float    :overlay-at (-> data 0))
   (y     float    :overlay-at (-> data 1))
   (z     float    :overlay-at (-> data 2))
   (w     float    :overlay-at (-> data 3))
   (quad  uint128  :overlay-at (-> data 0))
   )
  )

(defmacro print128 (value &key (stream #t))
  "Print a 128-bit value"
  `(let ((temp (new 'stack-no-clear 'array 'uint64 2)))
     (set! (-> (the (pointer uint128) temp)) ,value)
     (format ,stream "#x~16X~16X" (-> temp 1) (-> temp 0))
     )
  )

(defmacro make-u128 (upper lower)
  "Make a i128 from two 64-bit values."
  `(rlet ((result :class i128)
          (upper-xmm :class i128)
          (lower-xmm :class i128))
     (.mov upper-xmm ,upper)
     (.mov lower-xmm ,lower)
     (.pcpyld result upper-xmm lower-xmm)
     (the-as uint result)
     )
  )

;; bfloat: boxed float type. A floating point number with type information.
;; It's a heap allocated basic.
(deftype bfloat (basic)
  ((data float)
   )
  :method-count-assert 9
  :size-assert         #x8
  :flag-assert         #x900000008
  )

(defmethod print ((this bfloat))
  (format #t "~f" (-> this data))
  this
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Type System
;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmethod asize-of ((this type))
  "Get the size in memory of a type. The value calculated here is wrong."
  (the-as int (logand (the-as uint #xfffffff0) (+ (* (-> this allocated-length) 4) 43)))
  )

(defun basic-type? ((arg0 basic) (arg1 type))
  "Is the given basic an object of the given type?"
  (let ((v1-0 (-> arg0 type))
        (a0-1 object)
        )
    (until (= v1-0 a0-1)
      (if (= v1-0 arg1)
          (return #t)
          )
      (set! v1-0 (-> v1-0 parent))
      )
    )
  #f
  )

(defun type-type? ((arg0 type) (arg1 type))
  "Is the given type equal to, or a child of, the second type?"
  (let ((v1-0 object))
    (if (= arg1 v1-0)
        (return #t)
        )
    (until (or (= arg0 v1-0) (zero? arg0))
      (if (= arg0 arg1)
          (return #t)
          )
      (set! arg0 (-> arg0 parent))
      )
    )
  #f
  )

(defun type? ((arg0 object) (arg1 type))
  "Is the given object an object of the given type? Works for any boxed object (basic, symbol, binteger, pair)."
  (let ((v1-0 object)
        (a0-1 (rtype-of arg0))
        )
    (if (= arg1 v1-0)
        (return #t)
        )
    (until (or (= a0-1 v1-0) (zero? a0-1))
      (if (= a0-1 arg1)
          (return #t)
          )
      (set! a0-1 (-> a0-1 parent))
      )
    )
  #f
  )

(defun find-parent-method ((arg0 type) (arg1 int))
  "Go up the type tree and find the first parent type that has a different implementation for the given method."
  (local-vars (v0-0 function))
  (let ((v1-2 (-> arg0 method-table arg1)))
    (until (!= v0-0 v1-2)
      (if (= arg0 object)
          (return nothing)
          )
      (set! arg0 (-> arg0 parent))
      (set! v0-0 (-> arg0 method-table arg1))
      (if (zero? v0-0)
          (return nothing)
          )
      )
    )
  v0-0
  )

(defmacro call-parent-method (&rest args)
  "Find the first different implementation of the current method in a parent type and call it with these arguments."
  `((the (current-method-function-type) (find-parent-method (current-method-type) (current-method-id)))
    ,@args)
  )

(defun ref ((arg0 object) (arg1 int))
  "Get the n-th item in a linked list. No range checking."
  (dotimes (v1-0 arg1)
    (nop!)
    (nop!)
    (set! arg0 (cdr arg0))
    )
  (car arg0)
  )

(defmethod length ((this pair))
  "Get the length of a linked list."
  (local-vars (v0-0 int))
  (cond
    ((null? this)
     (set! v0-0 0)
     )
    (else
      (let ((v1-1 (cdr this)))
        (set! v0-0 1)
        (while (and (not (null? v1-1)) (pair? v1-1))
          (+! v0-0 1)
          (set! v1-1 (cdr v1-1))
          )
        )
      )
    )
  v0-0
  )

(defmethod asize-of ((this pair))
  "Get the size in memory of a pair."
  (the-as int (-> pair size))
  )

(defun last ((arg0 object))
  "Get the last object in a list."
  (let ((v0-0 arg0))
    (while (not (null? (cdr v0-0)))
      (nop!)
      (nop!)
      (set! v0-0 (cdr v0-0))
      )
    v0-0
    )
  )

(defun member ((arg0 object) (arg1 object))
  "Is this in the list lst? Returns pair with this as its car, or #f if not found."
  (let ((v1-0 arg1))
    (while (not (or (null? v1-0) (= (car v1-0) arg0)))
      (set! v1-0 (cdr v1-0))
      )
    (if (not (null? v1-0))
        v1-0
        )
    )
  )

;; need to forward declare this, we haven't loaded the string library yet.
(define-extern name= (function object object symbol))

(defun nmember ((arg0 basic) (arg1 object))
  "Is this in the list lst? Check with the name= function."
  (while (not (or (null? arg1) (name= (car arg1) arg0)))
    (set! arg1 (cdr arg1))
    )
  (if (not (null? arg1))
      arg1
      )
  )

(defun assoc ((arg0 object) (arg1 object))
  "Is item in the association list alist?
   Returns the key-value pair."
  (let ((v1-0 arg1))
    (while (not (or (null? v1-0) (= (car (car v1-0)) arg0)))
      (set! v1-0 (cdr v1-0))
      )
    (if (not (null? v1-0))
        (car v1-0)
        )
    )
  )

(defun assoce ((arg0 object) (arg1 object))
  "Is there an entry with key item in the association list alist?
   Returns the key-value pair.
   Treats a key of 'else like an else case"
  (let ((v1-0 arg1))
    (while (not (or (null? v1-0) (= (car (car v1-0)) arg0) (= (car (car v1-0)) 'else)))
      (set! v1-0 (cdr v1-0))
      )
    (if (not (null? v1-0))
        (car v1-0)
        )
    )
  )

(defun nassoc ((arg0 string) (arg1 object))
  "Is there an entry named item-name in the association list alist?
   Checks name with nmember or name= so you can have multiple keys.
   Returns the ([key|(key..)] . value) pair."
  (while (not (or (null? arg1) (let ((a1-1 (car (car arg1))))
                                 (if (pair? a1-1)
                                     (nmember arg0 a1-1)
                                     (name= (the-as basic a1-1) arg0)
                                     )
                                 )
                  )
              )
    (set! arg1 (cdr arg1))
    )
  (if (not (null? arg1))
      (car arg1)
      )
  )

(defun nassoce ((arg0 string) (arg1 object))
  "Is there an entry named item-name in the association list alist?
   Checks name with nmember for multiple keys or name= for single.
   Allows else as a single key that always matches"
  (while (not (or (null? arg1) (let ((s4-0 (car (car arg1))))
                                 (if (pair? s4-0)
                                     (nmember arg0 s4-0)
                                     (or (name= (the-as basic s4-0) arg0) (= s4-0 'else))
                                     )
                                 )
                  )
              )
    (set! arg1 (cdr arg1))
    )
  (if (not (null? arg1))
      (car arg1)
      )
  )

(defun append! ((arg0 object) (arg1 object))
  "Append back to front, return the combined list."
  (cond
    ((null? arg0)
     arg1
     )
    (else
      (let ((v1-1 arg0))
        (while (not (null? (cdr v1-1)))
          (nop!)
          (nop!)
          (set! v1-1 (cdr v1-1))
          )
        (if (not (null? v1-1))
            (set! (cdr v1-1) arg1)
            )
        )
      arg0
      )
    )
  )

(defun delete! ((arg0 object) (arg1 object))
  "Remove the first occurance of item from lst (where item is actual a pair in the list)"
  (the-as pair
          (cond
            ((= arg0 (car arg1))
             (cdr arg1)
             )
            (else
              (let ((v1-1 arg1)
                    (a2-0 (cdr arg1))
                    )
                (while (not (or (null? a2-0) (= (car a2-0) arg0)))
                  (set! v1-1 a2-0)
                  (set! a2-0 (cdr a2-0))
                  )
                (if (not (null? a2-0))
                    (set! (cdr v1-1) (cdr a2-0))
                    )
                )
              arg1
              )
            )
          )
  )

(defun delete-car! ((arg0 object) (arg1 object))
  "Remove the first first occurance of an element from the list where (car elt) is item."
  (cond
    ((= arg0 (car (car arg1)))
     (cdr arg1)
     )
    (else
      (let ((v1-2 arg1)
            (a2-0 (cdr arg1))
            )
        (while (not (or (null? a2-0) (= (car (car a2-0)) arg0)))
          (set! v1-2 a2-0)
          (set! a2-0 (cdr a2-0))
          )
        (if (not (null? a2-0))
            (set! (cdr v1-2) (cdr a2-0))
            )
        )
      arg1
      )
    )
  )

(defun insert-cons! ((arg0 object) (arg1 object))
  "Update an association list to have the given (key . value) pair kv.
   If it already exists in the list, remove it.
   DANGER: this function allocates memory on the global heap."
  (let ((a3-0 (delete-car! (car arg0) arg1)))
    (cons arg0 a3-0)
    )
  )

(defun sort ((arg0 pair) (arg1 (function object object object)))
  "Sort a list, using compare-func to compare elements.
  The comparison function can return either an integer or a true/false.
  For integers, use a positive number to represent first > second
  Ex: (sort lst -) will sort in ascending order
  For booleans, you must explicitly use TRUE and not a truthy value.
  Ex: (sort my-list (lambda ((x int) (y int)) (< x y))) will sort ascending.
  NOTE: if you use an integer, don't accidentally return TRUE."
  (let ((s4-0 -1))
    (while (nonzero? s4-0)
      (set! s4-0 0)
      (let ((s3-0 arg0))
        (while (not (or (null? (cdr s3-0)) (not (pair? (cdr s3-0)))))
          (let* ((s2-0 (car s3-0))
                 (s1-0 (car (cdr s3-0)))
                 (v1-1 (arg1 s2-0 s1-0))
                 )
            (when (and (or (not v1-1) (> (the-as int v1-1) 0)) (!= v1-1 #t))
              (+! s4-0 1)
              (set! (car s3-0) s1-0)
              (set! (car (cdr s3-0)) s2-0)
              )
            )
          (set! s3-0 (cdr s3-0))
          )
        )
      )
    )
  arg0
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; inline-array-class
;;;;;;;;;;;;;;;;;;;;;;;;;;

;; This is used as base class for boxed inline arrays.
;; The heap-base of the _type_ object will be used to store the stride
;; This way, you don't pay the price of storing the stride in each object.
;; however, as far as we've seen, nothing actually reads the stride.

(deftype inline-array-class (basic)
  ((length           int32)
   (allocated-length int32)
   (_data            uint8 :dynamic :offset 16)
   )
  (:methods
    (new (symbol type int) _type_)
    )
  )

(defmethod new inline-array-class ((allocation symbol) (type-to-make type) (arg0 int))
  "Allocate a new inline-array-class object with room for the given number of objects.
   Both length and allocated-length are set to the given size"
  (let ((v0-0 (object-new
                allocation
                type-to-make
                (the-as int (+ (-> type-to-make size) (* (the-as uint arg0) (-> type-to-make heap-base))))
                )
              )
        )
    (when (nonzero? v0-0)
      (set! (-> v0-0 length) arg0)
      (set! (-> v0-0 allocated-length) arg0)
      )
    v0-0
    )
  )

(defmethod length ((this inline-array-class))
  "Get the length of the inline-array-class. This is the length field,
   not how much storage there is"
  (-> this length)
  )

(defmethod asize-of ((this inline-array-class))
  "Get the size in memory of an inline-array-class."
  (the-as int (+ (-> this type size) (* (-> this allocated-length) (the-as int (-> this type heap-base)))))
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; array
;;;;;;;;;;;;;;;;;;;;;;;;;;

;; the GOAL array type is a boxed array.
;; it is a basic that knows its content type, currently used length, and allocated length.
;; It can hold:
;;   any boxed object (gets 4 bytes, so bintegers get clipped to 32-bits)
;;   any structure/reference/pointer
;;   any integer/float
;; It cannot hold any inlined structures.

(defmethod new array ((allocation symbol) (type-to-make type) (arg0 type) (arg1 int))
  "Allocate a new array to hold len elements of type content-type.
   The content should either be a numeric type (child of number)
   or the content should be a reference (will get 4-bytes for a pointer)"
  (let ((v0-1 (object-new
                allocation
                type-to-make
                (the-as int (+ (-> type-to-make size) (* arg1 (if (type-type? arg0 number)
                                                                  (the-as int (-> arg0 size))
                                                                  4
                                                                  )
                                                         )
                               )
                        )
                )
              )
        )
    (set! (-> v0-1 allocated-length) arg1)
    (set! (-> v0-1 length) arg1)
    (set! (-> v0-1 content-type) arg0)
    v0-1
    )
  )

(defmethod print ((this array))
  (format #t "#(")
  (cond
    ((type-type? (-> this content-type) integer)
     (case (-> this content-type symbol)
       (('int32)
        (dotimes (s5-0 (-> this length))
          (format
            #t
            (if (zero? s5-0)
                "~D"
                " ~D"
                )
            (-> (the-as (array int32) this) s5-0)
            )
          )
        )
       (('uint32)
        (dotimes (s5-1 (-> this length))
          (format
            #t
            (if (zero? s5-1)
                "~D"
                " ~D"
                )
            (-> (the-as (array uint32) this) s5-1)
            )
          )
        )
       (('int64)
        (dotimes (s5-2 (-> this length))
          (format
            #t
            (if (zero? s5-2)
                "~D"
                " ~D"
                )
            (-> (the-as (array int64) this) s5-2)
            )
          )
        )
       (('uint64)
        (dotimes (s5-3 (-> this length))
          (format
            #t
            (if (zero? s5-3)
                "#x~X"
                " #x~X"
                )
            (-> (the-as (array uint64) this) s5-3)
            )
          )
        )
       (('int8)
        (dotimes (s5-4 (-> this length))
          (format
            #t
            (if (zero? s5-4)
                "~D"
                " ~D"
                )
            (-> (the-as (array int8) this) s5-4)
            )
          )
        )
       (('uint8)
        (dotimes (s5-5 (-> this length))
          (format
            #t
            (if (zero? s5-5)
                "~D"
                " ~D"
                )
            (-> (the-as (array uint8) this) s5-5)
            )
          )
        )
       (('int16)
        (dotimes (s5-6 (-> this length))
          (format
            #t
            (if (zero? s5-6)
                "~D"
                " ~D"
                )
            (-> (the-as (array int16) this) s5-6)
            )
          )
        )
       (('uint16)
        (dotimes (s5-7 (-> this length))
          (format
            #t
            (if (zero? s5-7)
                "~D"
                " ~D"
                )
            (-> (the-as (array uint16) this) s5-7)
            )
          )
        )
       (('uint128 'int128)
        (dotimes (s5-8 (-> this length))
          (format
            #t
            (if (zero? s5-8)
                "#x~X"
                " #x~X"
                )
            (-> (the-as (array uint128) this) s5-8)
            )
          )
        )
       (else
         (dotimes (s5-9 (-> this length))
           (format
             #t
             (if (zero? s5-9)
                 "~D"
                 " ~D"
                 )
             (-> (the-as (array int32) this) s5-9)
             )
           )
         )
       )
     )
    ((= (-> this content-type) float)
     (dotimes (s5-10 (-> this length))
       (if (zero? s5-10)
           (format #t "~f" (-> (the-as (array float) this) s5-10))
           (format #t " ~f" (-> (the-as (array float) this) s5-10))
           )
       )
     )
    (else
      (dotimes (s5-11 (-> this length))
        (if (zero? s5-11)
            (format #t "~A" (-> (the-as (array basic) this) s5-11))
            (format #t " ~A" (-> (the-as (array basic) this) s5-11))
            )
        )
      )
    )
  (format #t ")")
  this
  )

(defmethod inspect ((this array))
  "Inspect an array"
  (format #t "[~8x] ~A~%" this (-> this type))
  (format #t "~Tallocated-length: ~D~%" (-> this allocated-length))
  (format #t "~Tlength: ~D~%" (-> this length))
  (format #t "~Tcontent-type: ~A~%" (-> this content-type))
  (format #t "~Tdata[~D]: @ #x~X~%" (-> this allocated-length) (-> this data))
  (cond
    ((and (= (logand (the-as int (-> this content-type)) 7) 4) (type-type? (-> this content-type) integer))
     (case (-> this content-type symbol)
       (('int32)
        (dotimes (s5-0 (-> this length))
          (format #t "~T  [~D] ~D~%" s5-0 (-> (the-as (array int32) this) s5-0))
          )
        )
       (('uint32)
        (dotimes (s5-1 (-> this length))
          (format #t "~T  [~D] ~D~%" s5-1 (-> (the-as (array uint32) this) s5-1))
          )
        )
       (('int64)
        (dotimes (s5-2 (-> this length))
          (format #t "~T  [~D] ~D~%" s5-2 (-> (the-as (array int64) this) s5-2))
          )
        )
       (('uint64)
        (dotimes (s5-3 (-> this length))
          (format #t "~T  [~D] #x~X~%" s5-3 (-> (the-as (array uint64) this) s5-3))
          )
        )
       (('int8)
        (dotimes (s5-4 (-> this length))
          (format #t "~T  [~D] ~D~%" s5-4 (-> (the-as (array int8) this) s5-4))
          )
        )
       (('uint8)
        (dotimes (s5-5 (-> this length))
          (format #t "~T  [~D] ~D~%" s5-5 (-> (the-as (array int8) this) s5-5))
          )
        )
       (('int16)
        (dotimes (s5-6 (-> this length))
          (format #t "~T  [~D] ~D~%" s5-6 (-> (the-as (array int16) this) s5-6))
          )
        )
       (('uint16)
        (dotimes (s5-7 (-> this length))
          (format #t "~T  [~D] ~D~%" s5-7 (-> (the-as (array uint16) this) s5-7))
          )
        )
       (('int128 'uint128)
        (dotimes (s5-8 (-> this length))
          (format #t "~T  [~D] #x~X~%" s5-8 (-> (the-as (array uint128) this) s5-8))
          )
        )
       (else
         (dotimes (s5-9 (-> this length))
           (format #t "~T  [~D] ~D~%" s5-9 (-> (the-as (array int32) this) s5-9))
           )
         )
       )
     )
    ((= (-> this content-type) float)
     (dotimes (s5-10 (-> this length))
       (format #t "~T  [~D] ~f~%" s5-10 (-> (the-as (array float) this) s5-10))
       )
     )
    (else
      (dotimes (s5-11 (-> this length))
        (format #t "~T  [~D] ~A~%" s5-11 (-> (the-as (array basic) this) s5-11))
        )
      )
    )
  this
  )

(defmethod length ((this array))
  "Get the length of an array"
  (-> this length)
  )

(defmethod asize-of ((this array))
  "Get the size in memory of an array"
  (the-as
    int
    (+ (-> this type size) (* (-> this allocated-length) (if (type-type? (-> this content-type) number)
                                                           (the-as int (-> this content-type size))
                                                           4
                                                           )
                             )
       )
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;
;; memory manipulation
;;;;;;;;;;;;;;;;;;;;;;;;

(defun mem-copy! ((arg0 pointer) (arg1 pointer) (arg2 int))
  "Memory copy. Not a very efficient optimization, but has no restrictions.
   Increasing address copy."
  (let ((v0-0 arg0))
    (dotimes (v1-0 arg2)
      (set! (-> (the-as (pointer uint8) arg0)) (-> (the-as (pointer uint8) arg1)))
      (&+! arg0 1)
      (&+! arg1 1)
      )
    v0-0
    )
  )

(defun qmem-copy<-! ((arg0 pointer) (arg1 pointer) (arg2 int))
  "Memory copy by quadword. More efficient, but has restrictions:
   - dst and src should be 16-byte aligned.
   - size in bytes will be rounded up to 16-bytes
   - Ascending address copy."
  (let ((v0-0 arg0))
    (countdown (v1-1 (/ (+ arg2 15) 16))
      (set! (-> (the-as (pointer uint128) arg0)) (-> (the-as (pointer uint128) arg1)))
      (&+! arg0 16)
      (&+! arg1 16)
      )
    v0-0
    )
  )

(defun qmem-copy->! ((arg0 pointer) (arg1 pointer) (arg2 int))
  "Memory copy by quadword (16-bytes). More efficient, but has restrictions:
  - dst and src should be 16-byte aligned.
  - size in bytes will be rounding up to nearest 16-bytes
  - Descending address copy"
  (let ((v0-0 arg0))
    (let* ((v1-1 (/ (+ arg2 15) 16))
           (a0-1 (&+ arg0 (* v1-1 16)))
           (a1-1 (&+ arg1 (* v1-1 16)))
           )
      (while (nonzero? v1-1)
        (+! v1-1 -1)
        (&+! a0-1 -16)
        (&+! a1-1 -16)
        (set! (-> (the-as (pointer uint128) a0-1)) (-> (the-as (pointer uint128) a1-1)))
        )
      )
    v0-0
    )
  )

(defun mem-set32! ((arg0 pointer) (arg1 int) (arg2 int))
  "Normal memset, but by 32-bit word.
   NOTE: argument order is swapped from C"
  (let ((v0-0 arg0))
    (dotimes (v1-0 arg1)
      (set! (-> (the-as (pointer int32) arg0)) arg2)
      (&+! arg0 4)
      (nop!)
      )
    v0-0
    )
  )

(defun mem-or! ((arg0 pointer) (arg1 pointer) (arg2 int))
  "Set the dst to (logior dst src) byte by byte.
   Not very efficient."
  (let ((v0-0 arg0))
    (dotimes (v1-0 arg2)
      (logior! (-> (the-as (pointer uint8) arg0)) (-> (the-as (pointer uint8) arg1)))
      (&+! arg0 1)
      (&+! arg1 1)
      )
    v0-0
    )
  )

(defun quad-copy! ((dst pointer) (src pointer) (qwc int))
  "Optimized memory copy. The original is pretty clever, but this isn't."
  (qmem-copy<-! dst src (* qwc 16))
  (none)
  )

(defun-recursive fact int ((x int))
  (if (= x 1)
      1
      (* x (fact (+ x -1))))
  )


;;;;;;;;;;;;;;;;;;;;;;;;
;; printing
;;;;;;;;;;;;;;;;;;;;;;;;

;; the column that will be printed to by format.
(define *print-column* (the-as binteger 0))

;; note: normal use of print/inspect will have the compiler pick the appropriate method
;; for non-basics.  However, it may be useful to have print/inspect available as a function
;; as well, allowing you to use it as a function pointer.
;; in this case, we can only do the right thing on boxed objects.

(defun print ((arg0 object))
  "Print out any boxed object. Does NOT insert a newline."
  ((method-of-type (rtype-of arg0) print) arg0)
  )

(defmacro printl (this)
  "Print out a boxed object and a newline.
   Note: we define both a macro and a function on purpose.
   The compiler will use the macro over the function, which will
   allow it to pick the correct print method for non-boxed objects"
  `(begin
     (print ,this)
     (format #t "~%")
     ,this
     )
  )

(defun printl ((arg0 object))
  "Print out any boxed object and a newline at the end."
  (let ((a0-1 arg0))
    ((method-of-type (rtype-of a0-1) print) a0-1)
    )
  (format #t "~%")
  arg0
  )

(defun inspect ((arg0 object))
  "Inspect any boxed object."
  ((method-of-type (rtype-of arg0) inspect) arg0)
  )

(defun-debug mem-print ((arg0 (pointer uint32)) (arg1 int))
  "Print memory to runtime stdout by quadword.
   Input count is in 32-bit words"
  (dotimes (s4-0 (/ arg1 4))
    (format
      0
      "~X: ~X ~X ~X ~X~%"
      (&-> arg0 (* s4-0 4))
      (-> arg0 (* s4-0 4))
      (-> arg0 (+ (* s4-0 4) 1))
      (-> arg0 (+ (* s4-0 4) 2))
      (-> arg0 (+ (* s4-0 4) 3))
      )
    )
  #f
  )

;; unused
(define *trace-list* '())

(defun print-tree-bitmask ((arg0 int) (arg1 int))
  "Print out a single entry for a process tree 'tree' diagram"
  (dotimes (s4-0 arg1)
    (if (zero? (logand arg0 1))
        (format #t "    ")
        (format #t "|   ")
        )
    (set! arg0 (shr arg0 1))
    )
  #f
  )

(defun breakpoint-range-set! ((arg0 uint) (arg1 uint) (arg2 uint))
  "Sets some debug register (COP0 Debug, dab, dabm) to break on memory access.
   This is not supported in OpenGOAL."
  (break!)
  )

;;;;;;;;;;;;;;;;;;;;;;;
;; valid
;;;;;;;;;;;;;;;;;;;;;;;

(defmacro start-of-symbol-table ()
  `(rlet ((st :reg r14 :reset-here #t :type uint))
         (the uint (- st 32768))
         )
  )

(defmacro end-of-symbol-table ()
  `(rlet ((st :reg r14 :reset-here #t :type uint))
         (the uint (+ st 32768))
         )
  )

(define-extern boolean type) ;; not really... but they use it here as if it was one.
(define-extern valid? (function object type string symbol object symbol))

(defun valid? ((this object) (expected-type type) (name string) (allow-false symbol) (print-dest object))
  "Check if the given object is valid. This will work for structures, pairs, basics, bintegers, symbols, and types.
   If you set expected-type to #f, it just checks for a 4-byte aligned address that's in GOAL memory.
   If you're checking a structure, set expected-type to structure. This requires 16-byte alignment
    Note: packed inline structures in arrays or fields will not pass this check.
   Otherwise, set it to the type you expect. More specific types will pass.

   If allow-false is #t, a #f will always pass. Otherwise, #f will fail (unless you're looking for a symbol).
   Use allow-false if you want to allow a 'null' reference.

   The name is only used when printing out an error if the check fails.
   Use a name of #f to suppress error prints.
   "
  (let ((v1-1
          (and (>= (the-as uint this) (start-of-symbol-table)) (< (the-as uint this) END_OF_MEMORY))
          )
        )
    (cond
      ((not expected-type)
       (cond
         ((logtest? (the-as int this) 3)
          (if name
              (format print-dest "ERROR: object #x~X ~S is not a valid object (misaligned)~%" this name)
              )
          #f
          )
         ((not v1-1)
          (if name
              (format print-dest "ERROR: object #x~X ~S is not a valid object (bad address)~%" this name)
              )
          #f
          )
         (else
           #t
           )
         )
       )
      ((and allow-false (not this))
       #t
       )
      ((= expected-type structure)
       (cond
         ((logtest? (the-as int this) 15)
          (if name
              (format print-dest "ERROR: object #x~X ~S is not a valid object of type '~A' (misaligned)~%" this name expected-type)
              )
          #f
          )
         ((or (not v1-1) (< (the-as uint this) (end-of-symbol-table)))
          (if name
              (format print-dest "ERROR: object #x~X ~S is not a valid object of type '~A' (bad address)~%" this name expected-type)
              )
          #f
          )
         (else
           #t
           )
         )
       )
      ((= expected-type pair)
       (cond
         ((not (pair? this))
          (if name
              (format print-dest "ERROR: object #x~X ~S is not a valid object of type '~A' (misaligned)~%" this name expected-type)
              )
          #f
          )
         ((not v1-1)
          (if name
              (format print-dest "ERROR: object #x~X ~S is not a valid object of type '~A' (bad address)~%" this name expected-type)
              )
          #f
          )
         (else
           #t
           )
         )
       )
      ((= expected-type binteger)
       (cond
         ((zero? (logand (the-as int this) 7))
          #t
          )
         (else
           (if name
               (format print-dest "ERROR: object #x~X ~S is not a valid object of type '~A' (misaligned)~%" this name expected-type)
               )
           #f
           )
         )
       )
      ((or (= expected-type symbol) (= expected-type boolean))
       (cond
         ((zero? (logand (the-as int this) 1))
          (if name
              (format print-dest "ERROR: object #x~X ~S is not a valid object of type '~A' (misaligned)~%" this name expected-type)
              )
          #f
          )
         ((or (not v1-1) (< (the-as int this) (start-of-symbol-table))(>= (the-as int this) (end-of-symbol-table)))
          (if name
              (format print-dest "ERROR: object #x~X ~S is not a valid object of type '~A' (bad address)~%" this name expected-type)
              )
          #f
          )
         (else
           #t
           )
         )
       )
      ((!= (logand (the-as int this) 7) 4)
       (if name
           (format print-dest "ERROR: object #x~X ~S is not a valid object of type '~A' (misaligned)~%" this name expected-type)
           )
       #f
       )
      ((not v1-1)
       (if name
           (format print-dest "ERROR: object #x~X ~S is not a valid object of type '~A' (bad address)~%" this name expected-type)
           )
       #f
       )
      ((and (= expected-type type) (!= (rtype-of this) type))
       (if name
           (format
             print-dest
             "ERROR: object #x~X ~S is not a valid object of type '~A' (invalid type #x~X)~%"
             this
             name
             expected-type
             (rtype-of this)
             )
           )
       #f
       )
      ((and (!= expected-type type) (not (valid? (rtype-of this) type (the-as string #f) #t 0)))
       (if name
           (format
             print-dest
             "ERROR: object #x~X ~S is not a valid object of type '~A' (invalid type #x~X)~%"
             this
             name
             expected-type
             (rtype-of this)
             )
           )
       #f
       )
      ((not (type? this expected-type))
       (if name
           (format
             print-dest
             "ERROR: object #x~X ~S is not a valid object of type '~A' (is type '~A' instead)~%"
             this
             name
             expected-type
             (rtype-of this)
             )
           )
       #f
       )
      ((= expected-type symbol)
       (cond
         ((>= (the-as uint this) (end-of-symbol-table))
          (if name
              (format
                print-dest
                "ERROR: object #x~X ~S is not a valid object of type '~A' (not in symbol table)~%"
                this
                name
                expected-type
                )
              )
          #f
          )
         (else
           #t
           )
         )
       )
      ((< (the-as uint this) (end-of-symbol-table))
       (if name
           (format
             print-dest
             "ERROR: object #x~X ~S is not a valid object of type '~A' (inside symbol table)~%"
             this
             name
             expected-type
             )
           )
       #f
       )
      (else
        #t
        )
      )
    )
  )

;;;;;;;;;;;;;;;;;;;;
;; Profiler Macros
;;;;;;;;;;;;;;;;;;;;


(defmacro profiler-instant-event (name)
  "Record an 'instant' event in the profile.
   This can be used however you'd like, but there should be a
   'ROOT' event logged every now and then (like once per frame)
   when no timed events are in progress, to allow the profiler
   to correctly recover the event stack."
  `(#when PC_PROFILER_ENABLE
     (pc-prof ,name (pc-prof-event instant))
     )
  )

(defmacro profiler-start-event (name)
  "Start a timed event with the given name."
  `(#when PC_PROFILER_ENABLE
     (pc-prof ,name (pc-prof-event begin))
     )
  )

(defmacro profiler-end-event ()
  "End the most recently started event that hasn't been stopped yet.
   It is up to you to correctly balance the starts/ends, otherwise
   the profiling data will be corrupted."
  `(#when PC_PROFILER_ENABLE
     (pc-prof "" (pc-prof-event end))
     )
  )

(defmacro with-pc-profiler (name &rest body)
  "Execute the body in a named profiler block.
   Do not `return` or `go` from inside this block,
   otherwise the end will be skipped."
  `(#if PC_PROFILER_ENABLE
        (begin
          (pc-prof ,name (pc-prof-event begin))
          ,@body
          (pc-prof ,name (pc-prof-event end))
          )
        (begin
          ,@body
          )
        )
  )

;;;;;;;;;;;;;;;;;;;;;;;;
;; Decompiler Macros
;;;;;;;;;;;;;;;;;;;;;;;;

;; inserted by the decompiler for assembly branches.
(defmacro b! (pred destination &key (delay '()) &key (likely-delay '()))
  "Branch!"
  ;; evaluate the predicate
  `(let ((should-branch ,pred))
     ;; normal delay slot:
     ,delay
     (when should-branch
       ,likely-delay
       (goto ,destination)
       )
     )
  )

;; the decompiler may fail to recognize setting fields of a 128-bit bitfield
;; and will rely on this macro:
(defmacro copy-and-set-field (original field-name field-value)
  `(let ((temp-copy ,original))
     (set! (-> temp-copy ,field-name) ,field-value)
     temp-copy
     )
  )

;; inserted by the decompiler if a c->goal bool conversion can't be compacted into a single
;; expression.
(defmacro cmove-#f-zero (dest condition src)
  `(if (zero? ,condition)
       (set! ,dest #f)
       (set! ,dest ,src)
       )
   )

(defmacro cmove-#f-nonzero (dest condition src)
  `(if (zero? ,condition)
       (set! ,dest ,src)
       (set! ,dest #f)
       )
   )

(defmacro empty-form ()
  `(none)
  )

(defmacro sext32 (in)
  `(sar (shl ,in 32) 32)
  )

(defmacro .sra (result in sa)
  `(set! ,result (sext32 (sar (logand #xffffffff (the-as int ,in)) ,sa)))
  )

(defmacro l32-false-check (in)
  `(- (logand #xffffffff (the-as uint ,in)) (the-as uint #f))
  )

;;;;;;;;;;;;;;;;;;;;;;;
;; PC Port asm macros
;;;;;;;;;;;;;;;;;;;;;;;
(#when PC_PORT
  ;; SYNC is an EE instruction that waits for various memory access and DMA to be completed
  ;; DMA will be instant in the PC port, so these are no longer necessary
  (fake-asm .sync.l)
  (fake-asm .sync.p)
  ;; Copies the contents of a cop0 (system control) register to a gpr
  (fake-asm .mfc0 dest src)
  ;; Copies the contents of a gpr to a cop0 (system control) register
  (fake-asm .mtc0 dest src)
  ;; Move to perf counter register
  (fake-asm .mtpc src dest)
  ;; Move from perf counter register
  (fake-asm .mfpc dest src)
  )