mirror of
https://github.com/open-goal/jak-project
synced 2026-05-24 23:22:14 -04:00
water111
1107 lines
28 KiB
Common Lisp
Vendored
1107 lines
28 KiB
Common Lisp
Vendored
;;-*-Lisp-*-
|
|
(in-package goal)
|
|
|
|
;; definition for method 2 of type res-tag
|
|
(defmethod print res-tag ((obj res-tag))
|
|
(if (zero? (-> obj inlined?))
|
|
(format
|
|
#t
|
|
"#<res-tag :name ~A :key-frame ~f :elt-type ~A :elt-count ~D>"
|
|
(-> obj name)
|
|
(-> obj key-frame)
|
|
(-> obj elt-type)
|
|
(-> obj elt-count)
|
|
)
|
|
(format
|
|
#t
|
|
"#<res-tag (i) :name ~A :key-frame ~f :elt-type ~A :elt-count ~D>"
|
|
(-> obj name)
|
|
(-> obj key-frame)
|
|
(-> obj elt-type)
|
|
(-> obj elt-count)
|
|
)
|
|
)
|
|
obj
|
|
)
|
|
|
|
;; definition for method 4 of type res-tag
|
|
;; INFO: Return type mismatch uint vs int.
|
|
(defmethod length res-tag ((obj res-tag))
|
|
(the-as int (if (zero? (-> obj inlined?))
|
|
(* (-> obj elt-count) 4)
|
|
(* (-> obj elt-count) (-> obj elt-type size))
|
|
)
|
|
)
|
|
)
|
|
|
|
;; definition for method 13 of type res-lump
|
|
;; Used lq/sq
|
|
(defmethod get-tag-index-data res-lump ((obj res-lump) (arg0 int))
|
|
(&+ (-> obj data-base) (-> obj tag arg0 data-offset))
|
|
)
|
|
|
|
;; definition for method 14 of type res-lump
|
|
(defmethod get-tag-data res-lump ((obj res-lump) (arg0 res-tag))
|
|
(&+ (-> obj data-base) (-> arg0 data-offset))
|
|
)
|
|
|
|
;; definition for method 0 of type res-lump
|
|
(defmethod
|
|
new
|
|
res-lump
|
|
((allocation symbol) (type-to-make type) (data-count int) (data-size int))
|
|
(let
|
|
((obj
|
|
(object-new
|
|
allocation
|
|
type-to-make
|
|
(the-as int (+ (-> type-to-make size) (* (+ data-count -1) 16) data-size))
|
|
)
|
|
)
|
|
)
|
|
(set! (-> obj allocated-length) data-count)
|
|
(set! (-> obj data-size) data-size)
|
|
(set! (-> obj length) 0)
|
|
(set! (-> obj data-base) (&-> (-> obj tag) data-count))
|
|
(set! (-> obj data-top) (&-> (-> obj tag) data-count))
|
|
obj
|
|
)
|
|
)
|
|
|
|
;; definition for method 4 of type res-lump
|
|
(defmethod length res-lump ((obj res-lump))
|
|
(-> obj length)
|
|
)
|
|
|
|
;; definition for method 5 of type res-lump
|
|
;; INFO: Return type mismatch uint vs int.
|
|
(defmethod asize-of res-lump ((obj res-lump))
|
|
(the-as
|
|
int
|
|
(+ (-> obj type psize) (* (-> obj allocated-length) 16) (-> obj data-size))
|
|
)
|
|
)
|
|
|
|
;; definition for method 3 of type res-lump
|
|
;; INFO: this function exists in multiple non-identical object files
|
|
;; Used lq/sq
|
|
(defmethod inspect res-lump ((obj res-lump))
|
|
(format #t "[~8x] ~A~%" obj (-> obj type))
|
|
(format #t "~Textra: ~A~%" (-> obj extra))
|
|
(format #t "~Tallocated-length: ~D~%" (-> obj allocated-length))
|
|
(format #t "~Tlength: ~D~%" (-> obj length))
|
|
(format #t "~Tdata-base: #x~X~%" (-> obj data-base))
|
|
(format #t "~Tdata-top: #x~X~%" (-> obj data-top))
|
|
(format #t "~Tdata-size: #x~X~%" (-> obj data-size))
|
|
(format #t "~Ttag[~D]: @ #x~X~%" (-> obj allocated-length) (-> obj tag))
|
|
(dotimes (i (-> obj length))
|
|
(format #t "~T [~D] " i)
|
|
(print (-> obj tag i))
|
|
(let ((t9-10 format)
|
|
(a0-12 #t)
|
|
(a1-9 " @ #x~X")
|
|
(a3-2 obj)
|
|
(a2-9 i)
|
|
)
|
|
(t9-10 a0-12 a1-9 (&+ (-> a3-2 data-base) (-> a3-2 tag a2-9 data-offset)))
|
|
)
|
|
(cond
|
|
((zero? (-> obj tag i inlined?))
|
|
(let ((t9-11 format)
|
|
(a0-14 #t)
|
|
(a1-10 " = ~A~%")
|
|
(a3-4 obj)
|
|
(a2-17 i)
|
|
)
|
|
(t9-11
|
|
a0-14
|
|
a1-10
|
|
(->
|
|
(the-as
|
|
(pointer uint32)
|
|
(&+ (-> a3-4 data-base) (-> a3-4 tag a2-17 data-offset))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(else
|
|
(format #t "~%")
|
|
)
|
|
)
|
|
)
|
|
obj
|
|
)
|
|
|
|
;; definition for method 19 of type res-lump
|
|
;; INFO: Return type mismatch int vs res-tag-pair.
|
|
;; Used lq/sq
|
|
(defmethod
|
|
lookup-tag-idx
|
|
res-lump
|
|
((obj res-lump) (name-sym symbol) (mode symbol) (time float))
|
|
(local-vars (tag-idx int))
|
|
(when
|
|
(or
|
|
(= name-sym 'id)
|
|
(= name-sym 'aid)
|
|
(= name-sym 'trans)
|
|
(= name-sym 'rot)
|
|
(= name-sym 'nav-mesh)
|
|
(= name-sym 'process-type)
|
|
(= name-sym 'task)
|
|
)
|
|
(crash!)
|
|
0
|
|
)
|
|
(if (or (not obj) (zero? obj) (<= (-> obj length) 0))
|
|
(return (new 'static 'res-tag-pair :lo #xffffffff :hi #xffffffff))
|
|
)
|
|
(let ((hi-tag-idx-out -1)
|
|
(lo-tag-idx-out -1)
|
|
)
|
|
(let ((most-recent-invalid-time-idx -1)
|
|
(type-chars
|
|
(-> (the-as (pointer uint64) (-> (symbol->string name-sym) data)) 0)
|
|
)
|
|
)
|
|
(let ((max-search (+ (-> obj length) -1))
|
|
(min-search 0)
|
|
)
|
|
(while (>= max-search min-search)
|
|
(let* ((check-idx (+ min-search (/ (- max-search min-search) 2)))
|
|
(diff
|
|
(-
|
|
type-chars
|
|
(->
|
|
(the-as
|
|
(pointer uint64)
|
|
(-> (symbol->string (-> obj tag check-idx name)) data)
|
|
)
|
|
0
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(cond
|
|
((zero? diff)
|
|
(set! tag-idx check-idx)
|
|
(goto cfg-32)
|
|
)
|
|
((< (the-as int diff) 0)
|
|
(set! max-search (+ check-idx -1))
|
|
)
|
|
(else
|
|
(set! min-search (+ check-idx 1))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(set! tag-idx -1)
|
|
(label cfg-32)
|
|
(if (< tag-idx 0)
|
|
(return (the-as res-tag-pair tag-idx))
|
|
)
|
|
(while
|
|
(and
|
|
(> tag-idx 0)
|
|
(=
|
|
type-chars
|
|
(->
|
|
(the-as
|
|
(pointer uint64)
|
|
(-> (symbol->string (-> obj tag (+ tag-idx -1) name)) data)
|
|
)
|
|
0
|
|
)
|
|
)
|
|
)
|
|
(+! tag-idx -1)
|
|
)
|
|
(when (= mode 'base)
|
|
(set! lo-tag-idx-out tag-idx)
|
|
(set! hi-tag-idx-out tag-idx)
|
|
(goto cfg-73)
|
|
)
|
|
(let ((interp-tag-idx tag-idx)
|
|
(tag-ptr (&-> (-> obj tag) tag-idx))
|
|
)
|
|
(while
|
|
(not
|
|
(or
|
|
(>= interp-tag-idx (-> obj length))
|
|
(<
|
|
type-chars
|
|
(->
|
|
(the-as
|
|
(pointer uint64)
|
|
(-> (symbol->string (-> tag-ptr 0 name)) data)
|
|
)
|
|
0
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(cond
|
|
((!= name-sym (-> tag-ptr 0 name))
|
|
)
|
|
((= (-> tag-ptr 0 key-frame) time)
|
|
(set! lo-tag-idx-out interp-tag-idx)
|
|
(set! hi-tag-idx-out interp-tag-idx)
|
|
(goto cfg-73)
|
|
)
|
|
((and (>= time (-> tag-ptr 0 key-frame)) (!= mode 'exact))
|
|
(set! lo-tag-idx-out interp-tag-idx)
|
|
(set! hi-tag-idx-out interp-tag-idx)
|
|
(if (= (-> tag-ptr 0 key-frame) -1000000000.0)
|
|
(set! most-recent-invalid-time-idx interp-tag-idx)
|
|
)
|
|
)
|
|
((< time (-> tag-ptr 0 key-frame))
|
|
(if
|
|
(and (!= lo-tag-idx-out most-recent-invalid-time-idx) (= mode 'interp))
|
|
(set! hi-tag-idx-out interp-tag-idx)
|
|
)
|
|
(goto cfg-73)
|
|
)
|
|
)
|
|
(+! interp-tag-idx 1)
|
|
(set! tag-ptr (&-> tag-ptr 1))
|
|
)
|
|
)
|
|
)
|
|
(label cfg-73)
|
|
(the-as
|
|
res-tag-pair
|
|
(logior
|
|
(logand (the-as uint #xffffffff) lo-tag-idx-out)
|
|
(shl hi-tag-idx-out 32)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
;; definition for method 20 of type res-lump
|
|
;; Used lq/sq
|
|
(defmethod
|
|
make-property-data
|
|
res-lump
|
|
((obj res-lump) (time float) (result res-tag-pair) (buf pointer))
|
|
(rlet ((vf1 :class vf)
|
|
(vf2 :class vf)
|
|
(vf3 :class vf)
|
|
(vf4 :class vf)
|
|
)
|
|
(let* ((tag-lo (-> obj tag (-> result lo)))
|
|
(tag-hi (-> obj tag (-> result hi)))
|
|
(elt-count (-> tag-lo elt-count))
|
|
)
|
|
(cond
|
|
((zero? (-> tag-lo inlined?))
|
|
(&+ (-> obj data-base) (-> tag-lo data-offset))
|
|
)
|
|
((or
|
|
(not buf)
|
|
(= (-> result lo) (-> result hi))
|
|
(!= elt-count (-> tag-hi elt-count))
|
|
(!= (-> tag-lo elt-type) (-> tag-hi elt-type))
|
|
)
|
|
(let ((a0-4 tag-lo))
|
|
(&+ (-> obj data-base) (-> a0-4 data-offset))
|
|
)
|
|
)
|
|
(else
|
|
(let*
|
|
((interp
|
|
(/
|
|
(- time (-> tag-lo key-frame))
|
|
(- (-> tag-hi key-frame) (-> tag-lo key-frame))
|
|
)
|
|
)
|
|
(a1-4 obj)
|
|
(a2-7 tag-lo)
|
|
(src-lo (&+ (-> a1-4 data-base) (-> a2-7 data-offset)))
|
|
(src-hi (&+ (-> obj data-base) (-> tag-hi data-offset)))
|
|
)
|
|
(case (-> tag-lo elt-type symbol)
|
|
(('float)
|
|
(dotimes (a0-8 (the-as int elt-count))
|
|
(set!
|
|
(-> (the-as (pointer float) (&+ buf (* a0-8 4))))
|
|
(+
|
|
(*
|
|
(-> (the-as (pointer float) (&+ src-lo (* a0-8 4))))
|
|
(- 1.0 interp)
|
|
)
|
|
(* (-> (the-as (pointer float) (&+ src-hi (* a0-8 4)))) interp)
|
|
)
|
|
)
|
|
)
|
|
buf
|
|
)
|
|
(('integer 'sinteger 'uinteger 'int64 'uint64)
|
|
(let ((a0-9 (the int (* 4096.0 interp))))
|
|
(dotimes (t0-9 (the-as int elt-count))
|
|
(set!
|
|
(-> (the-as (pointer int64) (&+ buf (* t0-9 8))))
|
|
(sar
|
|
(+
|
|
(*
|
|
(the-as
|
|
int
|
|
(-> (the-as (pointer uint64) (&+ src-lo (* t0-9 8))))
|
|
)
|
|
(- 4096 a0-9)
|
|
)
|
|
(*
|
|
(the-as
|
|
int
|
|
(-> (the-as (pointer uint64) (&+ src-hi (* t0-9 8))))
|
|
)
|
|
a0-9
|
|
)
|
|
)
|
|
12
|
|
)
|
|
)
|
|
)
|
|
)
|
|
buf
|
|
)
|
|
(('int8)
|
|
(let ((a0-10 (the int (* 4096.0 interp))))
|
|
(dotimes (t0-10 (the-as int elt-count))
|
|
(set!
|
|
(-> (the-as (pointer int8) (&+ buf t0-10)))
|
|
(sar
|
|
(+
|
|
(* (-> (the-as (pointer int8) (&+ src-lo t0-10))) (- 4096 a0-10))
|
|
(* (-> (the-as (pointer int8) (&+ src-hi t0-10))) a0-10)
|
|
)
|
|
12
|
|
)
|
|
)
|
|
)
|
|
)
|
|
buf
|
|
)
|
|
(('uint8)
|
|
(let ((a0-11 (the int (* 4096.0 interp))))
|
|
(dotimes (t0-11 (the-as int elt-count))
|
|
(set!
|
|
(-> (the-as (pointer uint8) (&+ buf t0-11)))
|
|
(shr
|
|
(+
|
|
(*
|
|
(-> (the-as (pointer uint8) (&+ src-lo t0-11)))
|
|
(the-as uint (- 4096 a0-11))
|
|
)
|
|
(*
|
|
(-> (the-as (pointer uint8) (&+ src-hi t0-11)))
|
|
(the-as uint a0-11)
|
|
)
|
|
)
|
|
12
|
|
)
|
|
)
|
|
)
|
|
)
|
|
buf
|
|
)
|
|
(('int16)
|
|
(let ((a0-12 (the int (* 4096.0 interp))))
|
|
(dotimes (t0-12 (the-as int elt-count))
|
|
(set!
|
|
(-> (the-as (pointer int16) (&+ buf (* t0-12 2))))
|
|
(sar
|
|
(+
|
|
(*
|
|
(-> (the-as (pointer int16) (&+ src-lo (* t0-12 2))))
|
|
(- 4096 a0-12)
|
|
)
|
|
(* (-> (the-as (pointer int16) (&+ src-hi (* t0-12 2)))) a0-12)
|
|
)
|
|
12
|
|
)
|
|
)
|
|
)
|
|
)
|
|
buf
|
|
)
|
|
(('uint16)
|
|
(let ((a0-13 (the int (* 4096.0 interp))))
|
|
(dotimes (t0-13 (the-as int elt-count))
|
|
(set!
|
|
(-> (the-as (pointer uint16) (&+ buf (* t0-13 2))))
|
|
(shr
|
|
(+
|
|
(*
|
|
(-> (the-as (pointer uint16) (&+ src-lo (* t0-13 2))))
|
|
(the-as uint (- 4096 a0-13))
|
|
)
|
|
(*
|
|
(-> (the-as (pointer uint16) (&+ src-hi (* t0-13 2))))
|
|
(the-as uint a0-13)
|
|
)
|
|
)
|
|
12
|
|
)
|
|
)
|
|
)
|
|
)
|
|
buf
|
|
)
|
|
(('int32)
|
|
(let ((a0-14 (the int (* 4096.0 interp))))
|
|
(dotimes (t0-14 (the-as int elt-count))
|
|
(set!
|
|
(-> (the-as (pointer int32) (&+ buf (* t0-14 4))))
|
|
(sar
|
|
(+
|
|
(*
|
|
(-> (the-as (pointer int32) (&+ src-lo (* t0-14 4))))
|
|
(- 4096 a0-14)
|
|
)
|
|
(* (-> (the-as (pointer int32) (&+ src-hi (* t0-14 4)))) a0-14)
|
|
)
|
|
12
|
|
)
|
|
)
|
|
)
|
|
)
|
|
buf
|
|
)
|
|
(('uint32)
|
|
(let ((a0-15 (the int (* 4096.0 interp))))
|
|
(dotimes (t0-15 (the-as int elt-count))
|
|
(set!
|
|
(-> (the-as (pointer uint32) (&+ buf (* t0-15 4))))
|
|
(shr
|
|
(+
|
|
(*
|
|
(-> (the-as (pointer uint32) (&+ src-lo (* t0-15 4))))
|
|
(the-as uint (- 4096 a0-15))
|
|
)
|
|
(*
|
|
(-> (the-as (pointer uint32) (&+ src-hi (* t0-15 4))))
|
|
(the-as uint a0-15)
|
|
)
|
|
)
|
|
12
|
|
)
|
|
)
|
|
)
|
|
)
|
|
buf
|
|
)
|
|
(('vector)
|
|
(let ((a0-16 interp))
|
|
(.mov vf3 a0-16)
|
|
)
|
|
(let ((a0-17 (- 1.0 interp)))
|
|
(.mov vf4 a0-17)
|
|
)
|
|
(dotimes (a0-18 (the-as int elt-count))
|
|
(let ((t0-17 (+ (* a0-18 16) (the-as int src-lo))))
|
|
(.lvf vf1 (&-> (the-as (pointer int128) t0-17)))
|
|
)
|
|
(let ((t0-19 (+ (* a0-18 16) (the-as int src-hi))))
|
|
(.lvf vf2 (&-> (the-as (pointer int128) t0-19)))
|
|
)
|
|
(.mul.x.vf vf1 vf1 vf4)
|
|
(.mul.x.vf vf2 vf2 vf3)
|
|
(.add.vf vf1 vf1 vf2)
|
|
(.svf (&-> (-> (the-as (inline-array vector) buf) a0-18) quad) vf1)
|
|
)
|
|
buf
|
|
)
|
|
(else
|
|
(let ((a0-19 tag-lo))
|
|
(&+ (-> obj data-base) (-> a0-19 data-offset))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
;; definition for method 9 of type res-lump
|
|
;; Used lq/sq
|
|
(defmethod
|
|
get-property-data
|
|
res-lump
|
|
((obj res-lump)
|
|
(name symbol)
|
|
(mode symbol)
|
|
(time float)
|
|
(default pointer)
|
|
(tag-addr (pointer res-tag))
|
|
(buf-addr pointer)
|
|
)
|
|
(let ((tag-pair (lookup-tag-idx obj name mode time)))
|
|
(cond
|
|
((< (the-as int tag-pair) 0)
|
|
(empty)
|
|
)
|
|
(else
|
|
(set! default (make-property-data obj time tag-pair buf-addr))
|
|
(if tag-addr
|
|
(set! (-> tag-addr 0) (-> obj tag (-> tag-pair lo)))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
default
|
|
)
|
|
|
|
;; definition for method 10 of type res-lump
|
|
;; INFO: Return type mismatch object vs structure.
|
|
;; Used lq/sq
|
|
(defmethod
|
|
get-property-struct
|
|
res-lump
|
|
((obj res-lump)
|
|
(name symbol)
|
|
(mode symbol)
|
|
(time float)
|
|
(default structure)
|
|
(tag-addr (pointer res-tag))
|
|
(buf-addr pointer)
|
|
)
|
|
(let ((tag-pair (lookup-tag-idx obj name mode time)))
|
|
(cond
|
|
((< (the-as int tag-pair) 0)
|
|
(empty)
|
|
)
|
|
(else
|
|
(set!
|
|
default
|
|
(the-as structure (make-property-data obj time tag-pair buf-addr))
|
|
)
|
|
(let ((tag (-> obj tag (-> tag-pair lo))))
|
|
(if tag-addr
|
|
(set! (-> tag-addr 0) tag)
|
|
)
|
|
(if (zero? (-> tag inlined?))
|
|
(set! default (the-as structure (-> (the-as (pointer uint32) default))))
|
|
(empty)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(the-as structure default)
|
|
)
|
|
|
|
;; definition for method 11 of type res-lump
|
|
;; INFO: Return type mismatch int vs uint128.
|
|
;; Used lq/sq
|
|
(defmethod
|
|
get-property-value
|
|
res-lump
|
|
((obj res-lump)
|
|
(name symbol)
|
|
(mode symbol)
|
|
(time float)
|
|
(default uint128)
|
|
(tag-addr (pointer res-tag))
|
|
(buf-addr pointer)
|
|
)
|
|
(let ((tag-pair (lookup-tag-idx obj name mode time)))
|
|
(cond
|
|
((< (the-as int tag-pair) 0)
|
|
(empty)
|
|
)
|
|
(else
|
|
(let* ((a0-2 (-> tag-pair lo))
|
|
(tag (-> obj tag a0-2))
|
|
(tag-type (-> tag elt-type))
|
|
(data (make-property-data obj time tag-pair buf-addr))
|
|
)
|
|
(if tag-addr
|
|
(set! (-> tag-addr 0) tag)
|
|
)
|
|
(cond
|
|
((type-type? (the-as type tag-type) uinteger)
|
|
(case (-> tag elt-type size)
|
|
((1)
|
|
(set! default (the-as uint128 (-> (the-as (pointer uint8) data))))
|
|
)
|
|
((2)
|
|
(set! default (the-as uint128 (-> (the-as (pointer uint16) data))))
|
|
)
|
|
((4)
|
|
(set! default (the-as uint128 (-> (the-as (pointer uint32) data))))
|
|
)
|
|
((16)
|
|
(set! default (-> (the-as (pointer uint128) data)))
|
|
)
|
|
(else
|
|
(set! default (the-as uint128 (-> (the-as (pointer uint64) data))))
|
|
)
|
|
)
|
|
)
|
|
((type-type? (the-as type tag-type) integer)
|
|
(case (-> tag elt-type size)
|
|
((1)
|
|
(set! default (the-as uint128 (-> (the-as (pointer int8) data))))
|
|
)
|
|
((2)
|
|
(set! default (the-as uint128 (-> (the-as (pointer int16) data))))
|
|
)
|
|
((4)
|
|
(set! default (the-as uint128 (-> (the-as (pointer int32) data))))
|
|
)
|
|
((16)
|
|
(set! default (-> (the-as (pointer uint128) data)))
|
|
)
|
|
(else
|
|
(set! default (the-as uint128 (-> (the-as (pointer uint64) data))))
|
|
)
|
|
)
|
|
)
|
|
((type-type? (the-as type tag-type) float)
|
|
(set!
|
|
default
|
|
(the-as uint128 (the int (-> (the-as (pointer float) data))))
|
|
)
|
|
)
|
|
(else
|
|
(empty)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(the-as uint128 default)
|
|
)
|
|
|
|
;; definition for method 12 of type res-lump
|
|
;; Used lq/sq
|
|
(defmethod
|
|
get-property-value-float
|
|
res-lump
|
|
((obj res-lump)
|
|
(name symbol)
|
|
(mode symbol)
|
|
(time float)
|
|
(default float)
|
|
(tag-addr (pointer res-tag))
|
|
(buf-addr pointer)
|
|
)
|
|
(local-vars (v1-8 uint) (v1-11 int))
|
|
(let ((tag-pair (lookup-tag-idx obj name mode time)))
|
|
(cond
|
|
((< (the-as int tag-pair) 0)
|
|
(empty)
|
|
)
|
|
(else
|
|
(let* ((a0-2 (-> tag-pair lo))
|
|
(tag (-> obj tag a0-2))
|
|
(tag-type (-> tag elt-type))
|
|
(data (make-property-data obj time tag-pair buf-addr))
|
|
)
|
|
(if tag-addr
|
|
(set! (-> tag-addr 0) tag)
|
|
)
|
|
(cond
|
|
((type-type? (the-as type tag-type) float)
|
|
(set! default (-> (the-as (pointer float) data)))
|
|
)
|
|
((type-type? (the-as type tag-type) uinteger)
|
|
(case (-> tag elt-type size)
|
|
((1)
|
|
(set! v1-8 (-> (the-as (pointer uint8) data)))
|
|
)
|
|
((2)
|
|
(set! v1-8 (-> (the-as (pointer uint16) data)))
|
|
)
|
|
((4)
|
|
(set! v1-8 (-> (the-as (pointer uint32) data)))
|
|
)
|
|
((16)
|
|
(set! v1-8 (the-as uint (-> (the-as (pointer uint128) data))))
|
|
)
|
|
(else
|
|
(set! v1-8 (-> (the-as (pointer uint64) data)))
|
|
)
|
|
)
|
|
(set! default (the float v1-8))
|
|
)
|
|
((type-type? (the-as type tag-type) integer)
|
|
(case (-> tag elt-type size)
|
|
((1)
|
|
(set! v1-11 (-> (the-as (pointer int8) data)))
|
|
)
|
|
((2)
|
|
(set! v1-11 (-> (the-as (pointer int16) data)))
|
|
)
|
|
((4)
|
|
(set! v1-11 (-> (the-as (pointer int32) data)))
|
|
)
|
|
((16)
|
|
(set! v1-11 (the-as int (-> (the-as (pointer uint128) data))))
|
|
)
|
|
(else
|
|
(set! v1-11 (the-as int (-> (the-as (pointer uint64) data))))
|
|
)
|
|
)
|
|
(set! default (the float v1-11))
|
|
)
|
|
(else
|
|
(empty)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
default
|
|
)
|
|
|
|
;; definition for method 16 of type res-lump
|
|
;; Used lq/sq
|
|
(defmethod sort! res-lump ((obj res-lump))
|
|
(let ((tags-sorted -1))
|
|
(while (nonzero? tags-sorted)
|
|
(set! tags-sorted 0)
|
|
(let ((i 0)
|
|
(tag-stop (+ (-> obj length) -2))
|
|
)
|
|
(while (>= tag-stop i)
|
|
(let* ((tag1 (-> obj tag i))
|
|
(tag2 (-> obj tag (+ i 1)))
|
|
(tag-name1
|
|
(->
|
|
(the-as
|
|
(pointer uint64)
|
|
(-> (symbol->string (-> tag1 name)) data)
|
|
)
|
|
0
|
|
)
|
|
)
|
|
(tag-name2
|
|
(->
|
|
(the-as
|
|
(pointer uint64)
|
|
(-> (symbol->string (-> tag2 name)) data)
|
|
)
|
|
0
|
|
)
|
|
)
|
|
)
|
|
(when
|
|
(or
|
|
(< tag-name2 tag-name1)
|
|
(and
|
|
(= tag-name1 tag-name2)
|
|
(< (-> tag2 key-frame) (-> tag1 key-frame))
|
|
)
|
|
)
|
|
(+! tags-sorted 1)
|
|
(set! (-> obj tag i) tag2)
|
|
(set! (-> obj tag (+ i 1)) tag1)
|
|
)
|
|
)
|
|
(+! i 1)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
obj
|
|
)
|
|
|
|
;; definition for method 15 of type res-lump
|
|
;; Used lq/sq
|
|
(defmethod allocate-data-memory-for-tag! res-lump ((obj res-lump) (arg0 res-tag))
|
|
(local-vars (resource-mem pointer))
|
|
(let*
|
|
((tag-pair (lookup-tag-idx obj (-> arg0 name) 'exact (-> arg0 key-frame)))
|
|
(existing-tag (-> obj tag (-> tag-pair lo)))
|
|
)
|
|
0
|
|
(if
|
|
(and
|
|
(>= (the-as int tag-pair) 0)
|
|
(!= (-> arg0 key-frame) (-> arg0 key-frame))
|
|
)
|
|
(set! tag-pair (new 'static 'res-tag-pair :lo #xffffffff :hi #xffffffff))
|
|
)
|
|
(if (zero? (-> arg0 elt-count))
|
|
(set! arg0 (copy-and-set-field arg0 elt-count 1))
|
|
)
|
|
(let ((data-size (length arg0)))
|
|
(cond
|
|
((and
|
|
(>= (the-as int tag-pair) 0)
|
|
(>= (the-as uint (length existing-tag)) (the-as uint data-size))
|
|
)
|
|
(set! resource-mem (&+ (-> obj data-base) (-> existing-tag data-offset)))
|
|
(when (logtest? (the-as int resource-mem) 7)
|
|
(set! resource-mem (logand -16 (&+ (-> obj data-top) 15)))
|
|
(set! (-> obj data-top) (&+ resource-mem data-size))
|
|
)
|
|
)
|
|
(else
|
|
(set! resource-mem (logand -16 (&+ (-> obj data-top) 15)))
|
|
(set! (-> obj data-top) (&+ resource-mem data-size))
|
|
)
|
|
)
|
|
(let* ((a0-22 arg0)
|
|
(s4-1
|
|
(copy-and-set-field
|
|
a0-22
|
|
data-offset
|
|
(&- resource-mem (the-as uint (-> obj data-base)))
|
|
)
|
|
)
|
|
)
|
|
(when
|
|
(>=
|
|
(the-as int (&+ resource-mem data-size))
|
|
(the-as int (&+ (-> obj data-base) (-> obj data-size)))
|
|
)
|
|
(format
|
|
0
|
|
"ERROR: attempting to a new tag ~`res-tag`P data of #x~X bytes to ~A, but data memory is full.~%"
|
|
s4-1
|
|
data-size
|
|
obj
|
|
)
|
|
(return (the-as res-tag #f))
|
|
)
|
|
(cond
|
|
((< (the-as int tag-pair) 0)
|
|
(cond
|
|
((>= (-> obj length) (-> obj allocated-length))
|
|
(format
|
|
0
|
|
"ERROR: attempting to a new tag ~`res-tag`P to ~A, but tag memory is full.~%"
|
|
s4-1
|
|
obj
|
|
)
|
|
(return (the-as res-tag #f))
|
|
)
|
|
(else
|
|
(set! (-> obj tag (-> obj length)) s4-1)
|
|
(+! (-> obj length) 1)
|
|
(sort! obj)
|
|
)
|
|
)
|
|
)
|
|
(else
|
|
(set! (-> obj tag (-> tag-pair lo)) s4-1)
|
|
)
|
|
)
|
|
s4-1
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
;; definition for method 17 of type res-lump
|
|
(defmethod add-data! res-lump ((obj res-lump) (arg0 res-tag) (arg1 pointer))
|
|
(let ((new-tag (allocate-data-memory-for-tag! obj arg0)))
|
|
(when new-tag
|
|
(let* ((v1-2 obj)
|
|
(a1-1 new-tag)
|
|
(tag-mem (&+ (-> v1-2 data-base) (-> a1-1 data-offset)))
|
|
)
|
|
(cond
|
|
((zero? (-> new-tag inlined?))
|
|
(length new-tag)
|
|
(set! (-> (the-as (pointer pointer) tag-mem) 0) arg1)
|
|
)
|
|
(else
|
|
(let ((a2-1 (length new-tag)))
|
|
(mem-copy! tag-mem arg1 a2-1)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
obj
|
|
)
|
|
|
|
;; definition for method 18 of type res-lump
|
|
(defmethod add-32bit-data! res-lump ((obj res-lump) (arg0 res-tag) (arg1 object))
|
|
(local-vars (sv-16 object))
|
|
(set! sv-16 arg1)
|
|
(let* ((v1-0 arg0)
|
|
(a1-4 (copy-and-set-field v1-0 inlined? 1))
|
|
)
|
|
(add-data! obj a1-4 (& sv-16))
|
|
)
|
|
)
|
|
|
|
;; definition for method 21 of type res-lump
|
|
;; Used lq/sq
|
|
(defmethod
|
|
get-curve-data!
|
|
res-lump
|
|
((obj res-lump) (arg0 curve) (arg1 symbol) (arg2 symbol) (arg3 float))
|
|
(local-vars (sv-16 res-tag) (sv-32 res-tag))
|
|
(let ((s5-0 #f))
|
|
(set! sv-16 (new 'static 'res-tag))
|
|
(let
|
|
((a0-2
|
|
((method-of-object obj get-property-data)
|
|
obj
|
|
arg1
|
|
'exact
|
|
arg3
|
|
(the-as pointer #f)
|
|
(& sv-16)
|
|
*res-static-buf*
|
|
)
|
|
)
|
|
)
|
|
(when a0-2
|
|
(set! (-> arg0 cverts) a0-2)
|
|
(set! (-> arg0 num-cverts) (the-as int (-> sv-16 elt-count)))
|
|
(when (< 256 (-> arg0 num-cverts))
|
|
(format
|
|
0
|
|
"ERROR<GMJ>: curve has ~D control points--only ~D are allowed. Increase MAX-CURVE-CONTROL-POINTS or shorten the curve.~%"
|
|
(-> arg0 num-cverts)
|
|
256
|
|
)
|
|
(set! (-> arg0 num-cverts) 256)
|
|
)
|
|
(set! sv-32 (new 'static 'res-tag))
|
|
(let
|
|
((a0-6
|
|
((method-of-object obj get-property-data)
|
|
obj
|
|
arg2
|
|
'exact
|
|
arg3
|
|
(the-as pointer #f)
|
|
(& sv-32)
|
|
*res-static-buf*
|
|
)
|
|
)
|
|
)
|
|
(when a0-6
|
|
(set! (-> arg0 knots) (the-as (inline-array vector) a0-6))
|
|
(set! (-> arg0 num-knots) (the-as int (-> sv-32 elt-count)))
|
|
(set! s5-0 #t)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
s5-0
|
|
)
|
|
)
|
|
|
|
;; definition for method 8 of type res-lump
|
|
;; INFO: Return type mismatch int vs res-lump.
|
|
;; Used lq/sq
|
|
(defmethod
|
|
mem-usage
|
|
res-lump
|
|
((obj res-lump) (block memory-usage-block) (flags int))
|
|
(local-vars (sv-16 int))
|
|
(let ((mem-use-id 48)
|
|
(mem-use-name "res")
|
|
)
|
|
(cond
|
|
((logtest? flags 256)
|
|
(set! mem-use-id 44)
|
|
(set! mem-use-name "camera")
|
|
)
|
|
((logtest? flags 64)
|
|
(set! mem-use-id 43)
|
|
(set! mem-use-name "entity")
|
|
)
|
|
((logtest? flags 128)
|
|
(set! mem-use-id 49)
|
|
(set! mem-use-name "ambient")
|
|
)
|
|
((logtest? flags 512)
|
|
(set! mem-use-id 73)
|
|
(set! mem-use-name "art-joint-geo")
|
|
)
|
|
)
|
|
(set! (-> block length) (max (-> block length) (+ mem-use-id 1)))
|
|
(set! (-> block data mem-use-id name) mem-use-name)
|
|
(+! (-> block data mem-use-id count) 1)
|
|
(let ((obj-size (asize-of obj)))
|
|
(+! (-> block data mem-use-id used) obj-size)
|
|
(+! (-> block data mem-use-id total) (logand -16 (+ obj-size 15)))
|
|
)
|
|
(dotimes (tag-idx (-> obj length))
|
|
(when (zero? (-> obj tag tag-idx inlined?))
|
|
(let* ((a1-4 obj)
|
|
(a0-15 tag-idx)
|
|
(tag-data
|
|
(the-as
|
|
basic
|
|
(->
|
|
(the-as
|
|
(pointer uint32)
|
|
(&+ (-> a1-4 data-base) (-> a1-4 tag a0-15 data-offset))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(when (not (part-group-pointer? (the-as pointer tag-data)))
|
|
(case (-> tag-data type)
|
|
((symbol type)
|
|
)
|
|
((string)
|
|
(set! (-> block length) (max (-> block length) (+ mem-use-id 1)))
|
|
(set! (-> block data mem-use-id name) mem-use-name)
|
|
(+! (-> block data mem-use-id count) 1)
|
|
(let ((v1-47 (asize-of tag-data)))
|
|
(+! (-> block data mem-use-id used) v1-47)
|
|
(+! (-> block data mem-use-id total) (logand -16 (+ v1-47 15)))
|
|
)
|
|
)
|
|
((nav-mesh collide-mesh)
|
|
(mem-usage (the-as collide-mesh tag-data) block flags)
|
|
)
|
|
((array)
|
|
(set! (-> block length) (max (-> block length) (+ mem-use-id 1)))
|
|
(set! (-> block data mem-use-id name) mem-use-name)
|
|
(+! (-> block data mem-use-id count) 1)
|
|
(let ((v1-63 (asize-of (the-as (array object) tag-data))))
|
|
(+! (-> block data mem-use-id used) v1-63)
|
|
(+! (-> block data mem-use-id total) (logand -16 (+ v1-63 15)))
|
|
)
|
|
(set! sv-16 0)
|
|
(while (< sv-16 (-> (the-as array tag-data) length))
|
|
(let ((a0-58 (-> (the-as (array object) tag-data) sv-16)))
|
|
((method-of-type (rtype-of a0-58) mem-usage) a0-58 block flags)
|
|
)
|
|
(set! sv-16 (+ sv-16 1))
|
|
)
|
|
)
|
|
(else
|
|
(set! (-> block length) (max (-> block length) (+ mem-use-id 1)))
|
|
(set! (-> block data mem-use-id name) mem-use-name)
|
|
(+! (-> block data mem-use-id count) 1)
|
|
(let ((v1-88 (asize-of tag-data)))
|
|
(+! (-> block data mem-use-id used) v1-88)
|
|
(+! (-> block data mem-use-id total) (logand -16 (+ v1-88 15)))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(the-as res-lump 0)
|
|
)
|
|
|
|
;; definition for symbol *res-static-buf*, type pointer
|
|
(define *res-static-buf* (malloc 'global 128))
|