From 8ef73ee457a7ea8054ace5c147bba1649d5a8293 Mon Sep 17 00:00:00 2001 From: ManDude <7569514+ManDude@users.noreply.github.com> Date: Sun, 25 Jul 2021 05:23:30 +0100 Subject: [PATCH] give `defstate` a parent type and allow anonymous behaviors inside (#715) * give `defstate` a parent type and allow anonymous behaviors inside * add defstate type stack leak detection+correction, remove debug print --- decompiler/config/all-types.gc | 62 ++++------ docs/markdown/process_and_state.md | 2 +- goal_src/goal-lib.gc | 6 + goal_src/goos-lib.gs | 15 +++ goal_src/kernel/gkernel-h.gc | 6 +- goal_src/kernel/gstate.gc | 116 ++++++++++++------ .../source_templates/kernel/kernel-test.gc | 6 +- 7 files changed, 130 insertions(+), 83 deletions(-) diff --git a/decompiler/config/all-types.gc b/decompiler/config/all-types.gc index 56391d927..efecba0c3 100644 --- a/decompiler/config/all-types.gc +++ b/decompiler/config/all-types.gc @@ -37521,38 +37521,28 @@ ;; - Types -; (deftype sun-iris-door (process-drawable) -; ((timeout float :offset-assert 176) -; (proximity? basic :offset-assert 180) -; (directional-proximity? basic :offset-assert 184) -; (move-to? basic :offset-assert 188) -; (locked-by-task? basic :offset-assert 192) -; (close-dist float :offset-assert 196) -; (open-dist float :offset-assert 200) -; (move-to-pos vector :inline :offset-assert 208) -; (outward-vec vector :inline :offset-assert 224) -; (move-to-quat quaternion :inline :offset-assert 240) -; ) -; :method-count-assert 22 -; :size-assert #x100 -; :flag-assert #x1600900100 -; ;; inherited inspect of process-drawable -; (:methods -; (dummy-9 () none 9) -; (dummy-10 () none 10) -; (dummy-11 () none 11) -; (dummy-12 () none 12) -; (dummy-13 () none 13) -; (dummy-14 () none 14) -; (dummy-15 () none 15) -; (dummy-16 () none 16) -; (dummy-17 () none 17) -; (dummy-18 () none 18) -; (dummy-19 () none 19) -; (dummy-20 () none 20) -; (dummy-21 () none 21) -; ) -; ) +(deftype sun-iris-door (process-drawable) + ((timeout float :offset-assert 176) + (proximity? basic :offset-assert 180) + (directional-proximity? basic :offset-assert 184) + (move-to? basic :offset-assert 188) + (locked-by-task? basic :offset-assert 192) + (close-dist float :offset-assert 196) + (open-dist float :offset-assert 200) + (move-to-pos vector :inline :offset-assert 208) + (outward-vec vector :inline :offset-assert 224) + (move-to-quat quaternion :inline :offset-assert 240) + ) + :method-count-assert 22 + :size-assert #x100 + :heap-base #x90 + :flag-assert #x1600900100 + ;; inherited inspect of process-drawable + (:methods + (dummy-20 () none 20) + (dummy-21 () none 21) + ) + ) ;; - Functions @@ -37561,10 +37551,10 @@ ;; - Unknowns (define-extern *sun-iris-door-sg* skeleton-group) -;;(define-extern sun-iris-door-open object) ;; unknown type -;;(define-extern sun-iris-door-closed object) ;; unknown type -;;(define-extern sun-iris-door-opening object) ;; unknown type -;;(define-extern sun-iris-door-closing object) ;; unknown type +(define-extern sun-iris-door-open state) +(define-extern sun-iris-door-closed state) +(define-extern sun-iris-door-opening state) +(define-extern sun-iris-door-closing state) ;; ---------------------- diff --git a/docs/markdown/process_and_state.md b/docs/markdown/process_and_state.md index d75d1fb36..a9e2923cd 100644 --- a/docs/markdown/process_and_state.md +++ b/docs/markdown/process_and_state.md @@ -91,7 +91,7 @@ The `state` system is used to control a process. Each process can be in a `stat For example, we can create a simple test state like this: ``` -(defstate test-state +(defstate test-state (process) :enter (lambda () (format #t "enter!~%")) :exit (lambda () (format #t "exit!~%")) :trans (lambda () (format #t "trans!~%")) diff --git a/goal_src/goal-lib.gc b/goal_src/goal-lib.gc index 12c71d690..43b930328 100644 --- a/goal_src/goal-lib.gc +++ b/goal_src/goal-lib.gc @@ -322,6 +322,12 @@ ) ) +(defmacro loop (&rest body) + "Loop this code forever." + `(while #t + ,@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 diff --git a/goal_src/goos-lib.gs b/goal_src/goos-lib.gs index e774c8c22..00cf92350 100644 --- a/goal_src/goos-lib.gs +++ b/goal_src/goos-lib.gs @@ -31,6 +31,10 @@ `(if ,x #f #t) ) +(defsmacro unless (clause &rest body) + `(if (not ,clause) (begin ,@body) #f) + ) + (desfun factorial (x) (if (= x 1) 1 @@ -71,6 +75,13 @@ (desfun third (x) (car (cddr x))) +(defsmacro push! (lst x) + `(set! ,lst (cons ,x ,lst)) + ) +(defsmacro pop! (lst) + `(set! ,lst (cdr ,lst)) + ) + (desfun apply (fun x) (if (null? x) '() @@ -161,6 +172,10 @@ `(type? 'pair ,x) ) +(defsmacro symbol? (x) + `(type? 'symbol ,x) + ) + (defsmacro ferror (&rest args) `(error (fmt #f ,@args)) ) diff --git a/goal_src/kernel/gkernel-h.gc b/goal_src/kernel/gkernel-h.gc index 151bdf80a..8d39dd56d 100644 --- a/goal_src/kernel/gkernel-h.gc +++ b/goal_src/kernel/gkernel-h.gc @@ -576,9 +576,9 @@ "get the name of a process using a handle. #f is the result if the handle was invalid." (with-gensyms (proc) - `(let ((proc (handle->process ,handle))) - (if proc - (-> proc name) + `(let ((,proc (handle->process ,handle))) + (if ,proc + (-> ,proc name) ) ) ) diff --git a/goal_src/kernel/gstate.gc b/goal_src/kernel/gstate.gc index 915d48f04..cc1300809 100644 --- a/goal_src/kernel/gstate.gc +++ b/goal_src/kernel/gstate.gc @@ -85,9 +85,17 @@ There are several ways to "go" `(inspect-process-tree *active-pool* 0 0 ,detail) ) +;; 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." -;; define a state state -(defmacro defstate (state-name + (when (and (pair? beh-form) (eq? (first beh-form) 'behavior)) + (push! *defstate-type-stack* beh-type) + ) + ) + +(defmacro defstate (state-name parents &key (event #f) &key (enter #f) &key (trans #f) @@ -95,46 +103,69 @@ There are several ways to "go" &key (code #f) &key (post #f) ) - `(begin - (define ,state-name (new 'static 'state - :name (quote ,state-name) - :next #f - :exit #f - :code #f - :trans #f - :post #f - :enter #f - :event #f - ) + "Define a new state!" + + (with-gensyms (new-state) + (let ((defstate-type (first parents))) + (when (not (null? *defstate-type-stack*)) + (ferror "*defstate-type-stack* leaked! An error probably happened in a previous defstate. stack is: {}" *defstate-type-stack*) + ) + (set! *defstate-type-stack* '()) + (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 + ) + )) + (define ,state-name ,new-state) + ,(if event + `(set! (-> ,new-state event) ,event) + `(none) + ) + ,(if enter + `(set! (-> ,new-state enter) (the (function object object object object object object object) ,enter)) + `(none) + ) + ,(if trans + `(set! (-> ,new-state trans) ,trans) + `(none) + ) + ,(if exit + `(set! (-> ,new-state exit) ,exit) + `(none) + ) + ,(if code + `(set! (-> ,new-state code) ,code) + `(none) + ) + ,(if post + `(set! (-> ,new-state post) ,post) + `(none) + ) + ) ) - ,(if event - `(set! (-> ,state-name event) ,event) - `(none) - ) - ,(if enter - `(set! (-> ,state-name enter) (the (function object object object object object object object) ,enter)) - `(none) - ) - ,(if trans - `(set! (-> ,state-name trans) ,trans) - `(none) - ) - ,(if exit - `(set! (-> ,state-name exit) ,exit) - `(none) - ) - ,(if code - `(set! (-> ,state-name code) ,code) - `(none) - ) - ,(if post - `(set! (-> ,state-name post) ,post) - `(none) - ) ) - ) - + +(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*) + `(the-as (function object) (lambda :behavior ,behavior-type ,bindings ,@body)) + ) + ) (defmethod new state ((allocation symbol) @@ -351,8 +382,13 @@ There are several ways to "go" (defun looping-code () "Loop." - (while #t + (loop (suspend) ) #f ) + + + + + diff --git a/test/goalc/source_templates/kernel/kernel-test.gc b/test/goalc/source_templates/kernel/kernel-test.gc index aac293a67..a3098f7a2 100644 --- a/test/goalc/source_templates/kernel/kernel-test.gc +++ b/test/goalc/source_templates/kernel/kernel-test.gc @@ -100,7 +100,7 @@ ) -(defstate die-state +(defstate die-state (process) :enter (lambda () (format #t "enter die~%")) :exit (lambda () (format #t "exit die~%")) :code (lambda () @@ -144,13 +144,13 @@ ) ;; a state. -(defstate xmm-check-state +(defstate xmm-check-state (process) :enter (lambda (x y z w) (format #t "enter check: ~D ~D ~D ~D~%" x y z w)) :exit (lambda () (format #t "exit check~%")) :code xmm-check-code ) -(defstate xmm-wreck-state +(defstate xmm-wreck-state (process) :enter (lambda (x y z w) (format #t "enter wreck: ~D ~D ~D ~D~%" x y z w)) :exit (lambda () (format #t "exit wreck~%")) :code xmm-wreck-code