Introduce Scheme node

Makefile

@@ -0,0 +1,25 @@
+.PHONY: test
+
+test: bin/s7
+	scons && bin/s7 test/test-main.scm
+
+bin/s7: s7/s7.c
+	mkdir -p bin
+	gcc s7/s7.c -o bin/s7 -DWITH_MAIN -DWITH_SYSTEM_EXTRAS -DWITH_C_LOADER=0 -I. -O2 -g -ldl -lm
+
+s7: bin/s7
+
+.PHONY: run
+
+run:
+	scons && godot -e --path demo main.tscn
+
+.PHONY: android
+
+android:
+	scons platform=android target=template_debug
+
+.PHONY: test-watch
+
+test-watch:
+	find demo/addons/s7 test | entr make test

demo/addons/s7/lib/array.scm

@@ -0,0 +1,32 @@
+(provide 'array)
+
+(define* (Array->vector array (mapping (lambda (x) x)))
+  "(Array->vector array (mapping identity)) converts a Godot Array to a Scheme vector, optionally mapping each element via the given mapping function."
+  (let* ((size (length array))
+         (v (make-vector size)))
+    (let loop ((size size))
+      (when (> size 0)
+        (let ((idx (- size 1)))
+          (set! (v idx) (mapping (array idx)))
+          (loop idx))))
+    v))
+
+(define (Array-for-each-reversed f array)
+  "Loops over a Godot array in reverse order."
+  (let loop ((size (length array)))
+    (when (> size 0)
+      (let ((idx (- size 1)))
+        (f (array idx))
+        (loop idx)))))
+
+(define* (Array->list array (mapping (lambda (x) x)))
+  "(Array->list array (mapping identity)) converts a Godot Array to a Scheme list, optionally mapping each element via the given mapping function. #<unspecified> values are removed."
+  (let ((res ()))
+    (Array-for-each-reversed
+     (lambda (a)
+       (let ((e (mapping a)))
+         (unless (unspecified? e)
+           (set! res (cons e res)))))
+     array)
+    res))
+

demo/addons/s7/lib/import.scm

@@ -0,0 +1,65 @@
+(provide 'import)
+
+(require 'array)
+
+(define (snake-case->lisp-case s)
+  (list->string
+   (map
+    (lambda (c)
+      (if (char=? #\_ c) #\- c))
+    s)))
+
+(define (adjust-name-case name lisp-case)
+  (if lisp-case (snake-case->lisp-case name) name))
+
+(define (string->symbol-with-prefix prefix string lisp-case)
+  (string->symbol (string-append (symbol->string prefix) "/" (adjust-name-case string lisp-case))))
+
+(define (symbol->Variant symbol)
+  (Variant (symbol->string symbol)))
+
+(define (Variant->symbol var lisp-case)
+  (string->symbol (adjust-name-case (Variant->string var) lisp-case)))
+
+(define (public-instance-method-name? name)
+  (not (char=? #\_ (name 0))))
+
+(define (import-method class method-info prefix lisp-case)
+  (let ((name (Variant->string (method-info 'name))))
+    (when (public-instance-method-name? name)
+      (let* ((args (method-info 'args))
+             (ps (Array->list args (lambda (arg) (Variant->symbol (arg 'name) lisp-case))))
+             (ps-doc
+               (format #f "(~{~A~^, ~})"
+                 (Array->list args
+                   (lambda (arg)
+                     (format #f "~A: ~A" (Variant->string (arg 'name)) (VariantType->string (arg 'type)))))))
+             (doc
+              (string-append
+               (let ((rt (method-info 'return 'type)))
+                 (if (= 0 rt) "void" (VariantType->string rt)))
+               " " (symbol->string class) "." name ps-doc)))
+
+        `(define (,(string->symbol-with-prefix prefix name lisp-case) self ,@ps)
+           ,doc
+           (! self ',(string->symbol name) ,@ps))))))
+
+(define (import-integer-constants-of class as include-inherited lisp-case)
+  (let ((class-name (symbol->Variant class))
+        (no-inheritance (not include-inherited)))
+    `(begin
+      ,@(Array->list
+        (! (class-db) 'class_get_integer_constant_list class-name no-inheritance)
+        (lambda (c)
+          (let ((value (! (class-db) 'class_get_integer_constant class-name c)))
+            `(define-constant ,(string->symbol-with-prefix as (Variant->string c) lisp-case) ,value)))))))
+
+(define-macro* (import-class class (as #f) (include-inherited #f) (lisp-case #t) (only ()))
+  (let* ((class-name (symbol->Variant class))
+         (no-inheritance (not include-inherited))
+         (ms (! (class-db) 'class_get_method_list class-name no-inheritance))
+         (as (or as class)))
+    `(begin
+       ,(import-integer-constants-of class as include-inherited lisp-case)
+       ,@(Array->list ms (lambda (m) (import-method class m as lisp-case)))
+       #t)))

demo/addons/s7/lib/prelude.scm

@@ -0,0 +1,49 @@
+(provide 'prelude)
+
+(define-macro* (inc! var (by 1))
+  `(set! ,var (+ ,var ,by)))
+
+(define-macro* ($ node-path (from *node*))
+  (let ((node-path-str (symbol->string node-path)))
+    `(! ,from 'get_node ,node-path-str)))
+
+(define* (connect! object signal callable (flags 0))
+  "Connects a procedure (or symbol that resolves to a procedure) to the signal of the given object."
+  (! object 'connect (symbol->string signal) (Callable callable) flags))
+
+(define (connected? obj signal symbol-or-procedure)
+  (! obj 'is_connected (symbol->string signal) (Callable symbol-or-procedure)))
+
+(define (disconnect! obj signal symbol-or-procedure)
+  (! obj 'disconnect (symbol->string signal) (Callable symbol-or-procedure)))
+
+(define (new class-symbol)
+  (! (class-db) 'instantiate (symbol->string class-symbol)))
+
+(define (load-resource resource-path)
+  "Loads a Godot resource via the ResourceLoader."
+  (let ((loader (new 'ResourceLoader)))
+    (dynamic-wind
+      (lambda () #f)
+      (lambda () (! loader 'load resource-path))
+      (lambda () (! loader 'free)))))
+
+(define (load-scheme-resource resource-path)
+  "Loads the given resource as a SchemeScript into the root environment."
+  (let ((script (load-resource resource-path)))
+    (print "Loading " (script 'resource_path) "...")
+    (! *node* 'load script)))
+
+(define (load-library lib-name)
+  "Loads addons/s7/lib/<lib-name>.scm"
+  (load-scheme-resource
+   (string-append "res://addons/s7/lib/" lib-name ".scm")))
+
+(define (require . symbols)
+  "Loads a library from addons/s7/lib if it hasn't been loaded yet."
+  (for-each
+   (lambda (symbol)
+     (when (not (provided? symbol))
+       (load-library (symbol->string symbol))))
+   symbols))
+

demo/addons/s7/s7_scheme_repl.scm

@@ -0,0 +1,132 @@
+;;; s7_scheme_repl_server.scm
+;;;
+;;; Compiles geiser-godot-s7 requests into Scheme
+;;; strings that once evaluated (via eval-string)
+;;; will produce the expected geiser response.
+;;;
+;;; This is so the repl environment doesn't leak
+;;; into the target environment for evaluation and
+;;; it is used by SchemeReplServer to target separate
+;;; Scheme nodes without cross contamination.
+;;;
+;;; The entry point is compile-geiser-request.
+;;;
+;;; See test-main.scm for examples of exchanges between
+;;; geiser and the server.
+
+;; Copyright (C) 2024 Rodrigo B. de Oliveira
+;; Author: Rodrigo B. de Oliveira ([email protected])
+;; Maintainer: Rodrigo B. de Oliveira ([email protected])
+;; Keywords: languages, godot, s7, scheme, geiser
+;; Homepage: https://github.com/bamboo/godot-s7-scheme
+;; SPDX-License-Identifier: BSD-3-Clause
+;; Version: 0.1.0
+
+(define (compile-eval-request-string code-string f)
+  (object->string
+   (let ((r (gensym))
+         (o (gensym)))
+     `(let* ((,r #<unspecified>)
+             (,o (with-output-to-string
+                   (lambda ()
+                     (set! ,r (eval-string ,code-string (rootlet)))))))
+        ,(f r o)))))
+
+(define (geiser-eval-format result output)
+  `(object->string
+    `((result ,(object->string ,result))
+      (output . ,,output))))
+
+(define (simple-eval-format result output)
+  `(let ((result-str (object->string ,result)))
+     (if (= 0 (string-length ,output))
+         result-str
+         (string-append ,output "\n" result-str))))
+
+(define (compile-eval-request code)
+  (compile-eval-request-string (object->string code) geiser-eval-format))
+
+(define (compile-simple-repl-request code-string)
+  (compile-eval-request-string code-string simple-eval-format))
+
+(define (compile-completions-request code)
+  "Handles ge:completions"
+  ;; using single character names to avoid polutting
+  ;; the symbol table that might be used for completion
+  (let* ((p (car code))
+         (l (string-length p)))
+
+    (compile-eval-request
+     `(let ((r '()))
+
+        (for-each
+         (lambda (s)
+           (let ((n (symbol->string s)))
+             (when (and (>= (string-length n) ,l)
+                        (string=? ,p (substring n 0 ,l))
+                        (defined? s))
+               (set! r (cons n r)))))
+         (symbol-table))
+        r))))
+
+(define (compile-symbol-documentation-request code)
+  "Handles ge:symbol-documentation"
+  (let ((s (cadar code)))
+    (compile-eval-request
+     `(let ((s (quote ,s)))
+        (cond
+         ((defined? s)
+          `(("signature" . ,s)
+            ("docstring" . ,(documentation s))))
+         (#t #f))))))
+
+(define (compile-autodoc-request code)
+  (compile-eval-request
+   (let ((s (caadar code)))
+     (cond
+      ((symbol? s)
+       `(let ((s (quote ,s)))
+          (cond
+           ((defined? (quote ,s))
+            (let ((v ,s))
+              (cond
+               ((or (procedure? v) (syntax? v))
+                `((,s ("args" (("required" ...) ("optional") ("key"))))))
+               (#t
+                `((,s ("args") ("value" . ,(object->string v))))))))
+           (#t (list)))))
+      (#t (list))))))
+
+(define (empty-response)
+  (object->string
+   (geiser-eval-format '() "")))
+
+(define (compile-geiser-command-request command-string)
+  (call-with-input-string command-string
+    (lambda (p)
+      (case (read p)
+        ((geiser-eval)
+         (case (read p)
+           ((#f)
+            (let ((code (read p)))
+              (case code
+                ((ge:autodoc) (compile-autodoc-request (read p)))
+                ((ge:symbol-documentation) (compile-symbol-documentation-request (read p)))
+                ((ge:completions
+                  ge:module-completions) (compile-completions-request (read p)))
+
+                ((ge:add-to-load-path
+                  ge:symbol-location
+                  ge:module-location) (empty-response))
+
+                (else (compile-eval-request code)))))))
+        (else (empty-response))))))
+
+(define (compile-geiser-request request-string)
+  "Compiles a geiser request into an expression that can be evaluated to produce the
+corresponding geiser response."
+  ;; geiser commands start with a comma,
+  ;; otherwise it's a simple repl interaction
+  (if (char=? #\, (request-string 0))
+      (compile-geiser-command-request (substring request-string 1))
+      (compile-simple-repl-request request-string)))