Files
ManDude cd68cb671e deftype and defmethod syntax major changes (#3094)
Major change to how `deftype` shows up in our code:
- the decompiler will no longer emit the `offset-assert`,
`method-count-assert`, `size-assert` and `flag-assert` parameters. There
are extremely few cases where having this in the decompiled code is
helpful, as the types there come from `all-types` which already has
those parameters. This also doesn't break type consistency because:
  - the asserts aren't compared.
- the first step of the test uses `all-types`, which has the asserts,
which will throw an error if they're bad.
- the decompiler won't emit the `heap-base` parameter unless necessary
now.
- the decompiler will try its hardest to turn a fixed-offset field into
an `overlay-at` field. It falls back to the old offset if all else
fails.
- `overlay-at` now supports field "dereferencing" to specify the offset
that's within a field that's a structure, e.g.:
```lisp
(deftype foobar (structure)
  ((vec    vector  :inline)
   (flags  int32   :overlay-at (-> vec w))
   )
  )
```
in this structure, the offset of `flags` will be 12 because that is the
final offset of `vec`'s `w` field within this structure.
- **removed ID from all method declarations.** IDs are only ever
automatically assigned now. Fixes #3068.
- added an `:overlay` parameter to method declarations, in order to
declare a new method that goes on top of a previously-defined method.
Syntax is `:overlay <method-name>`. Please do not ever use this.
- added `state-methods` list parameter. This lets you quickly specify a
list of states to be put in the method table. Same syntax as the
`states` list parameter. The decompiler will try to put as many states
in this as it can without messing with the method ID order.

Also changes `defmethod` to make the first type definition (before the
arguments) optional. The type can now be inferred from the first
argument. Fixes #3093.

---------

Co-authored-by: Hat Kid <6624576+Hat-Kid@users.noreply.github.com>
2023-10-30 03:20:02 +00:00

357 lines
11 KiB
Common Lisp

;;-*-Lisp-*-
(in-package goal)
;; name: load-dgo.gc
;; name in dgo: load-dgo
;; dgos: ENGINE, GAME
;; status flag sent from OVERLORD about a DGO load.
(defenum load-msg-result
:type uint16
:bitfield #f
(done 0) ;; dgo fully loaded!
(error 1) ;; loading failed (file not found, etc)
(more 2) ;; more files exist!
(aborted 3) ;; status returned after a request to cancel.
(invalid 666) ;; invalid status indicating a communication error.
)
;; DECOMP BEGINS
(deftype load-dgo-msg (structure)
((rsvd uint16)
(result load-msg-result)
(b1 pointer)
(b2 pointer)
(bt pointer)
(name uint128)
(address uint32 :overlay-at b1)
)
)
(deftype load-chunk-msg (structure)
((rsvd uint16)
(result load-msg-result)
(address pointer)
(section uint32)
(maxlen uint32)
(dummy uint32 4)
(basename sound-stream-name :inline)
)
)
(deftype play-chunk-msg (structure)
((rsvd uint16)
(result uint16)
(address pointer)
(section uint32)
(maxlen uint32)
(id uint32 4)
(basename sound-stream-name 4 :inline)
)
)
(deftype dgo-header (structure)
((length uint32)
(rootname uint8 60)
)
)
(define-extern *load-dgo-rpc* rpc-buffer-pair)
(when (zero? *load-dgo-rpc*)
(define *load-dgo-rpc* (new 'global 'rpc-buffer-pair (the-as uint 32) (the-as uint 1) 3))
(define *load-str-rpc* (new 'global 'rpc-buffer-pair (the-as uint 64) (the-as uint 1) 4))
(define *play-str-rpc* (new 'global 'rpc-buffer-pair (the-as uint 256) (the-as uint 2) 5))
(define *load-str-lock* #f)
(define *que-str-lock* #f)
(define *dgo-name* (new 'global 'string 64 (the-as string #f)))
)
(defun str-load ((arg0 string) (arg1 int) (arg2 pointer) (arg3 int))
(if (or (check-busy *load-str-rpc*) *load-str-lock*)
(return #f)
)
(let ((s2-0 (the-as load-chunk-msg (add-element *load-str-rpc*))))
(set! (-> s2-0 result) (load-msg-result invalid))
(set! (-> s2-0 address) arg2)
(set! (-> s2-0 section) (the-as uint arg1))
(set! (-> s2-0 maxlen) (the-as uint arg3))
(copyn-charp<-string (the-as (pointer uint8) (-> s2-0 basename)) arg0 48)
(call *load-str-rpc* (the-as uint 0) (the-as pointer s2-0) (the-as uint 32))
)
(set! *load-str-lock* #t)
(set! *que-str-lock* #t)
#t
)
(defun str-load-status ((arg0 (pointer int32)))
(if (check-busy *load-str-rpc*)
(return 'busy)
)
(set! *load-str-lock* #f)
(set! *que-str-lock* #t)
(let ((v1-7 (the-as load-chunk-msg (pop-last-received *load-str-rpc*))))
(if (= (-> v1-7 result) (load-msg-result error))
(return 'error)
)
(set! (-> arg0 0) (the-as int (-> v1-7 maxlen)))
)
'complete
)
(defun str-load-cancel ()
(set! *load-str-lock* #f)
(set! *que-str-lock* #t)
0
(none)
)
(defun str-play-async ((arg0 string) (arg1 sound-id))
(set! *que-str-lock* #t)
(let ((s4-0 (the-as play-chunk-msg (add-element *play-str-rpc*))))
(copyn-charp<-string (the-as (pointer uint8) (-> s4-0 basename)) arg0 48)
(copyn-charp<-string (the-as (pointer uint8) (-> s4-0 basename 1)) "" 48)
(copyn-charp<-string (the-as (pointer uint8) (-> s4-0 basename 2)) "" 48)
(copyn-charp<-string (the-as (pointer uint8) (-> s4-0 basename 3)) "" 48)
(set! (-> s4-0 id 0) (the-as uint arg1))
(set! (-> s4-0 id 1) (the-as uint 0))
(set! (-> s4-0 id 2) (the-as uint 0))
(set! (-> s4-0 id 3) (the-as uint 0))
(set! (-> s4-0 result) (the-as uint 0))
)
0
0
(none)
)
(defun str-play-stop ((arg0 string) (arg1 sound-id))
(set! *que-str-lock* #t)
(let ((s4-0 (the-as play-chunk-msg (add-element *play-str-rpc*))))
(copyn-charp<-string (the-as (pointer uint8) (-> s4-0 basename)) arg0 48)
(copyn-charp<-string (the-as (pointer uint8) (-> s4-0 basename 1)) "" 48)
(copyn-charp<-string (the-as (pointer uint8) (-> s4-0 basename 2)) "" 48)
(copyn-charp<-string (the-as (pointer uint8) (-> s4-0 basename 3)) "" 48)
(set! (-> s4-0 id 0) (the-as uint arg1))
(set! (-> s4-0 id 1) (the-as uint 0))
(set! (-> s4-0 id 2) (the-as uint 0))
(set! (-> s4-0 id 3) (the-as uint 0))
(set! (-> s4-0 result) (the-as uint 1))
)
0
(none)
)
(defun str-play-queue ((arg0 string) (arg1 string) (arg2 string) (arg3 string) (arg4 (pointer uint32)) (arg5 pointer))
(when (and (not (check-busy *play-str-rpc*)) (not *load-str-lock*) (not *que-str-lock*))
(let ((s4-0 (the-as play-chunk-msg (add-element *play-str-rpc*))))
(if arg0
(copyn-charp<-string (the-as (pointer uint8) (-> s4-0 basename)) arg0 48)
(copyn-charp<-string (the-as (pointer uint8) (-> s4-0 basename)) "" 48)
)
(if arg1
(copyn-charp<-string (the-as (pointer uint8) (-> s4-0 basename 1)) arg1 48)
(copyn-charp<-string (the-as (pointer uint8) (-> s4-0 basename 1)) "" 48)
)
(if arg2
(copyn-charp<-string (the-as (pointer uint8) (-> s4-0 basename 2)) arg2 48)
(copyn-charp<-string (the-as (pointer uint8) (-> s4-0 basename 2)) "" 48)
)
(if arg3
(copyn-charp<-string (the-as (pointer uint8) (-> s4-0 basename 3)) arg3 48)
(copyn-charp<-string (the-as (pointer uint8) (-> s4-0 basename 3)) "" 48)
)
(dotimes (v1-15 4)
(set! (-> s4-0 id v1-15) (-> arg4 v1-15))
)
(set! (-> s4-0 address) arg5)
(set! (-> s4-0 result) (the-as uint 2))
)
)
(set! *que-str-lock* #f)
0
(none)
)
(defun str-ambient-play ((arg0 string))
(set! *que-str-lock* #t)
(let ((s5-0 (the-as load-chunk-msg (add-element *play-str-rpc*))))
(set! (-> s5-0 basename name 0) (the-as uint 36))
(copyn-charp<-string (&-> s5-0 basename name 1) arg0 48)
(set! (-> s5-0 result) (load-msg-result done))
)
0
0
(none)
)
(defun str-ambient-stop ((arg0 string))
(set! *que-str-lock* #t)
(let ((s5-0 (the-as load-chunk-msg (add-element *play-str-rpc*))))
(set! (-> s5-0 basename name 0) (the-as uint 36))
(copyn-charp<-string (&-> s5-0 basename name 1) arg0 48)
(set! (-> s5-0 result) (load-msg-result error))
)
0
(none)
)
(defun str-play-kick ()
(cond
((check-busy *play-str-rpc*)
)
(else
(call *play-str-rpc* (the-as uint 0) (the-as pointer 0) (the-as uint 0))
)
)
0
(none)
)
(define *dgo-time* (the-as time-frame 0))
(defun dgo-load-begin ((arg0 string) (arg1 pointer) (arg2 pointer) (arg3 pointer))
(set! *dgo-time* (the-as time-frame (-> *display* real-clock integral-frame-counter)))
(format 0 "Starting level load clock~%")
(sync *load-dgo-rpc* #t)
(let ((s2-0 (the-as load-dgo-msg (add-element *load-dgo-rpc*))))
(set! (-> s2-0 result) (load-msg-result invalid))
(set! (-> s2-0 b1) arg1)
(set! (-> s2-0 b2) arg2)
(set! (-> s2-0 bt) arg3)
(set! (-> s2-0 name) (string->sound-name arg0))
(call *load-dgo-rpc* (the-as uint 0) (the-as pointer s2-0) (the-as uint 32))
s2-0
)
)
(defun dgo-load-get-next ((arg0 (pointer symbol)))
(set! (-> arg0 0) #f)
(let ((gp-0 (the-as pointer #f)))
(when (not (check-busy *load-dgo-rpc*))
(let ((v1-4 (the-as load-dgo-msg (pop-last-received *load-dgo-rpc*))))
(when v1-4
(when (or (= (-> v1-4 result) (load-msg-result done)) (= (-> v1-4 result) (load-msg-result more)))
(set! gp-0 (-> v1-4 b1))
(set! (-> arg0 0) #t)
)
(if (= (-> v1-4 result) (load-msg-result more))
(set! (-> arg0 0) #f)
)
(if (= (-> v1-4 result) (load-msg-result done))
(format
0
"Elapsed time for level = ~Fs~%"
(* 0.016666668 (the float (- (-> *display* real-clock integral-frame-counter) (the-as uint *dgo-time*))))
)
)
)
)
)
gp-0
)
)
(defun dgo-load-continue ((arg0 pointer) (arg1 pointer) (arg2 pointer))
(let ((gp-0 (the-as load-dgo-msg (add-element *load-dgo-rpc*))))
(set! (-> gp-0 result) (load-msg-result invalid))
(set! (-> gp-0 b1) arg0)
(set! (-> gp-0 b2) arg1)
(set! (-> gp-0 bt) arg2)
(set! (-> gp-0 name) (the-as uint128 0))
(call *load-dgo-rpc* (the-as uint 1) (the-as pointer gp-0) (the-as uint 32))
gp-0
)
)
(defun dgo-load-cancel ()
(sync *load-dgo-rpc* #t)
(let ((a2-0 (add-element *load-dgo-rpc*)))
(call *load-dgo-rpc* (the-as uint 2) a2-0 (the-as uint 32))
)
0
(none)
)
(defun find-temp-buffer ((arg0 int))
(let ((gp-0 (+ (/ arg0 16) 2)))
(cond
((< (the-as uint gp-0)
(the-as uint (dma-buffer-free (-> *display* frames (-> *display* on-screen) global-buf)))
)
(logand -16 (&+ (-> *display* frames (-> *display* on-screen) global-buf base) 15))
)
((< (the-as uint gp-0)
(the-as uint (dma-buffer-free (-> *display* frames (-> *display* on-screen) global-buf)))
)
(logand -16 (&+ (-> *display* frames (-> *display* on-screen) global-buf base) 15))
)
)
)
)
(defun dgo-load-link ((arg0 dgo-header) (arg1 kheap) (arg2 uint) (arg3 symbol) (arg4 symbol))
(let ((s4-0 (the-as object (&+ arg0 64))))
(let ((v1-0 arg2))
(cond
((>= (the-as int (+ (the-as uint s4-0) (-> arg0 length))) (the-as int (-> arg1 top-base)))
(format
0
"ERROR: -----> dgo file header ~g #x~X has overrun heap #x~X by ~D bytes. This is very bad!~%"
(-> arg0 rootname)
arg0
arg1
(- (+ (the-as uint s4-0) (-> arg0 length)) (the-as uint (-> arg1 top-base)))
)
)
((and (< (the-as int arg0) (the-as int v1-0))
(>= (the-as int (+ (the-as uint s4-0) (-> arg0 length))) (the-as int v1-0))
)
(format
0
"ERROR: -----> dgo file header ~g #x~X has overrun heap #x~X by ~D bytes. This is very bad!~%"
(-> arg0 rootname)
arg0
arg1
(- (+ (the-as uint s4-0) (-> arg0 length)) v1-0)
)
)
)
)
(if arg4
(format
0
"NOTICE: loaded ~g, ~D bytes (~f K) at top ~D at #x~X~%"
(-> arg0 rootname)
(-> arg0 length)
(* 0.0009765625 (the float (-> arg0 length)))
(- (+ (the-as uint s4-0) (-> arg0 length)) (the-as uint (-> arg1 base)))
arg0
)
)
(string<-charp (clear *dgo-name*) (-> arg0 rootname))
(nonzero? (link-begin
(the-as pointer s4-0)
(-> *dgo-name* data)
(the-as int (-> arg0 length))
arg1
(if arg3
(link-flag output-load-msg output-load-true-msg execute-login print-login fast-link)
(link-flag output-load-msg output-load-true-msg execute-login fast-link)
)
)
)
)
)
(defun destroy-mem ((arg0 (pointer uint32)) (arg1 (pointer uint32)))
(while (< (the-as int arg0) (the-as int arg1))
(set! (-> arg0 0) (the-as uint #xffffffff))
(set! arg0 (&-> arg0 1))
)
0
(none)
)