jak-project/goal_src/jakx/kernel/gstate.gc

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

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

(defmacro go (next-state &rest args)
  "Change the state of the current process.
   This will only return if this is called within the post thread.
   Otherwise, execution stops here and the kernel will run the next state next time."
  `(with-pp
     (go-hook pp ,next-state ,@args)
     )
  )

(defmacro process-spawn-function (proc-type func &key (from *default-dead-pool*) &key (to *default-pool*) &key (name #f) &key (stack-size #x4000) &key (stack *scratch-memory-top*) &rest args)
  "Start a new process that runs a function on its main thread.
   Returns a pointer to the new process (or #f? on error).
   Note that the extra jak 3 arg is so far always 1 (checked in decompiler)"

  (with-gensyms (new-proc)
    `(let ((,new-proc (the-as ,proc-type (get-process ,from ,proc-type ,stack-size 1))))
        (when ,new-proc
          ((method-of-type ,proc-type activate) ,new-proc ,to ,(if name name `(symbol->string ',proc-type)) ,stack)
          (run-next-time-in-process ,new-proc ,func ,@args)
          (the (pointer ,proc-type) (-> ,new-proc ppointer))
          )
        )
    )
  )

(defmacro process-spawn (proc-type &key (init #f)
                                   &key (from *default-dead-pool*)
                                   &key (to *default-pool*)
                                   &key (name #f)
                                   &key (stack-size #x4000)
                                   &key (stack *scratch-memory-top*)
                                   &key (unk 1)
                                   &key (runtime #f)
                                   &rest args)
  "Start a new process and run an init function on it.
   Returns a pointer to the new process, or #f (or is it 0?) if something goes wrong."
  (with-gensyms (new-proc)
    `(let ((,new-proc (the-as ,(if runtime 'process proc-type) (get-process ,from ,proc-type ,stack-size ,unk))))
        (when ,new-proc
          ((method-of-type ,(if runtime 'process proc-type) activate) ,new-proc ,to ,(if name name `(symbol->string ',proc-type)) ,stack)
          (run-now-in-process ,new-proc ,(if init init (string->symbol (fmt #f "{}-init-by-other" proc-type))) ,@args)
          (the (pointer ,(if runtime 'process proc-type)) (-> ,new-proc ppointer))
          )
        )
    )
  )

(defmacro go-virtual (state-name &key (proc self) &rest args)
  "Same as go, but use a virtual state."
  `(go (method-of-object ,proc ,state-name) ,@args)
  )

(defmacro go-process (proc next-state &rest args)
  "Make another process go."
  `(with-pp
     (protect (pp)
              (set! pp ,proc)
              (go-hook pp ,next-state ,@args)
              )
     )
  )

;; run the given function in a process right now.
;; will return to here when:
;;  - you return
;;  - you deactivate
;;  - you go
;;  - you throw to 'initialize
(defmacro run-now-in-process (proc func &rest args)
  "Run a function in another process right now."
  `((the (function _varargs_ object) run-function-in-process)
    ,proc ,func ,@args
    )
  )

;; sets the main thread of the given process to run the given thing.
;; this resets the main thread stack back to the top
(defmacro run-next-time-in-process (proc func &rest args)
  "Set up a process to run a function the next time it is scheduled."
  `((the (function _varargs_ object) set-to-run)
    (-> ,proc main-thread) ,func ,@args
    )
  )


;; use a compile-time list to keep track of the type of an anonymous behavior.
(seval (define *defstate-type-stack* '()))
(desfun def-state-check-behavior (beh-form beh-type)
  "check if code block is an anonymous behavior. needed for anonymous behaviors on defstate."

  (when (and (pair? beh-form) (eq? (first beh-form) 'behavior))
    (push! *defstate-type-stack* beh-type)
    )
  )
(defmacro clear-def-state-stack ()
  (set! *defstate-type-stack* '())
  `(none)
  )

;; set when inside a defstate.
(seval (define *defstate-current-type* #f))
(seval (define *defstate-current-state-name* #f))

;; *no-state* is just used for the compiler to know whether a handler was actually set or not
(defmacro defstate (state-name parents
                               &key (virtual #f)
                               &key (parent #f)
                               &key (event *no-state*)
                               &key (enter *no-state*)
                               &key (trans *no-state*)
                               &key (exit *no-state*)
                               &key (code *no-state*)
                               &key (post *no-state*)
                               &rest body
                               )
  "Define a new state!"

  (with-gensyms (new-state)
    (let ((defstate-type (first parents))
          (docstring ""))
      (when (and (> (length body) 1) (string? (first body)))
        (set! docstring (first body)))
      (when (not (null? *defstate-type-stack*))
        (fmt #t "*defstate-type-stack* leaked! An error probably happened in a previous defstate. stack is: {}"
                 *defstate-type-stack*)
        )
      (set! *defstate-type-stack* '())
      (when virtual
        (set! *defstate-current-type* defstate-type)
        (set! *defstate-current-state-name* state-name)
        )
      ;; check for default handlers
      (let ((default-handlers (assoc defstate-type *default-state-handlers*)))
          (when default-handlers
              ;;(fmt #t "found default-handlers for {}: {}\n" defstate-type default-handlers)
              ;; event
              (set! default-handlers (cadr default-handlers))
              (when (and (eq? event '*no-state*) (car default-handlers))
                  (set! event (car default-handlers)))
              ;; enter
              (set! default-handlers (cdr default-handlers))
              (when (and (eq? enter '*no-state*) (car default-handlers))
                  (set! enter (car default-handlers)))
              ;; trans
              (set! default-handlers (cdr default-handlers))
              (when (and (eq? trans '*no-state*) (car default-handlers))
                  (set! trans (car default-handlers)))
              ;; exit
              (set! default-handlers (cdr default-handlers))
              (when (and (eq? exit '*no-state*) (car default-handlers))
                  (set! exit (car default-handlers)))
              ;; code
              (set! default-handlers (cdr default-handlers))
              (when (and (eq? code '*no-state*) (car default-handlers))
                  (set! code (car default-handlers)))
              ;; post
              (set! default-handlers (cdr default-handlers))
              (when (and (eq? post '*no-state*) (car default-handlers))
                  (set! post (car default-handlers)))

              (set! default-handlers (cdr default-handlers))
              )
          )
      (def-state-check-behavior event defstate-type)
      (def-state-check-behavior enter defstate-type)
      (def-state-check-behavior trans defstate-type)
      (def-state-check-behavior exit defstate-type)
      (def-state-check-behavior code defstate-type)
      (def-state-check-behavior post defstate-type)
      `(let ((,new-state (new 'static 'state
                              :name (quote ,state-name)
                              :next #f
                              :exit #f
                              :code #f
                              :trans #f
                              :post #f
                              :enter #f
                              :event #f
                              )
                         ))
         ;; the compiler will set the fields of the given state and define the symbol.
         ;; This way it can check the individual function types, make sure they make sense, and create
         ;; a state with the appropriate type.
         ,(cond
           ((and virtual parent)
            `(begin
              (inherit-state ,new-state ,(if (pair? parent) `(method-of-type ,(car parent) ,(cadr parent)) `(the state ,parent)))
              (set! (-> ,new-state parent) ,(if (pair? parent) `(method-of-type ,(car parent) ,(cadr parent)) `(the state ,parent)))
              (define-virtual-state-hook ,state-name ,defstate-type ,new-state ,docstring ,(eq? virtual 'override) :event ,event :enter ,enter :trans ,trans :exit ,exit :code ,code :post ,post)
              )
            )
           (virtual
            `(begin
              (set! (-> ,new-state parent) #f)
              (define-virtual-state-hook ,state-name ,defstate-type ,new-state ,docstring ,(eq? virtual 'override) :event ,event :enter ,enter :trans ,trans :exit ,exit :code ,code :post ,post)
              )
            )
           (parent
            `(begin
              (inherit-state ,new-state (the state ,parent))
              (set! (-> ,new-state parent) (the state ,parent))
              (define-state-hook ,state-name ,defstate-type ,new-state ,docstring :event ,event :enter ,enter :trans ,trans :exit ,exit :code ,code :post ,post)
              )
            )
           (#t
            `(begin
              (set! (-> ,new-state parent) #f)
              (define-state-hook ,state-name ,defstate-type ,new-state ,docstring :event ,event :enter ,enter :trans ,trans :exit ,exit :code ,code :post ,post)
              )
            )
           )
         )
      )
    )
  )

(defmacro find-parent-state ()
  "Find the first different implementation of the current virtual state above this one."
  (when (or (not *defstate-current-type*)
            (not *defstate-current-state-name*))
    (error "use of find-parent-state outside of a defstate.")
    )
  `(cast-to-method-type
     ,*defstate-current-type*
     ,*defstate-current-state-name*
     (find-parent-method ,*defstate-current-type* (method-id-of-type ,*defstate-current-type* ,*defstate-current-state-name*))
    )
  )

(defmacro call-parent-state-handler (handler &key (type (function none)) &rest args)
  "Call the parent handler for this state."
  `(let ((handler (-> (find-parent-state) ,handler)))
     (if handler ((the ,type handler) ,@args))
     )
  )

(defmacro behavior (bindings &rest body)
  "Define an anonymous behavior for a process state. This may only be used inside a defstate!"

  (let ((behavior-type (first *defstate-type-stack*)))
    (pop! *defstate-type-stack*)
    `(lambda :behavior ,behavior-type ,bindings ,@body)
    )
  )

;; set the default handler functions for a process's state handlers
(seval (define *default-state-handlers* '()))
(defmacro defstatehandler (proc
                           &key (event #f)
                           &key (enter #f)
                           &key (trans #f)
                           &key (exit #f)
                           &key (code #f)
                           &key (post #f))
  (let ((old (assoc proc *default-state-handlers*))
        (new (list proc (list event enter trans exit code post))))
      (if (not old)
          (append!! *default-state-handlers* new) ;; add new set of default handlers
          (dolist (hnd *default-state-handlers*)  ;; replace old handlers with new ones
            (when (eq? (car hnd) old)
              (set-car! hnd new)
              )
            )
          )
      )
  `(none)
  )

(define-extern enter-state (function object object object object object object object))

;; DECOMP BEGINS

(defun send-event-function ((arg0 process-tree) (arg1 event-message-block))
  (with-pp
    ;; og:preserve-this check that we have a _valid_ process. originally this just checked
    ;; that type != process-tree, but sometimes we might get stale process ref (jak1 qbert-plat-master)
    (when (and (valid? arg0 process (the-as string #f) #f 0)
               (nonzero? (-> (the-as process arg0) pid))
               (-> (the-as process arg0) event-hook) (-> arg1 from))
      (let ((gp-0 pp))
        (set! pp (the-as process arg0))
        (let ((v0-0 ((-> (the-as process arg0) event-hook) (-> arg1 from 0) (-> arg1 num-params) (-> arg1 message) arg1)))
          (set! pp gp-0)
          v0-0
          )
        )
      )
    )
  )

(defmacro send-event (proc msg &key (from (with-pp pp)) &rest params)
  "Send an event to a process. This should be used over send-event-function"
  `(let ((event-data (new 'stack-no-clear 'event-message-block)))
        (set! (-> event-data from) (process->ppointer ,from))
        (set! (-> event-data num-params) ,(length params))
        (set! (-> event-data message) ,msg)
        ,@(apply-i (lambda (x i) `(set! (-> event-data param ,i) (the-as uint ,x))) params)
        (send-event-function ,proc event-data)
        )
  )