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

@@ -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)
 
 
 ;; ----------------------

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!~%"))

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

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))
   )

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)
             )
           )
     )

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
   )
+
+
+
+
+

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