From e76c21e6cf17ab64641b682fbf423573feae4506 Mon Sep 17 00:00:00 2001 From: "Rodrigo B. de Oliveira" Date: Mon, 18 Nov 2024 15:54:42 -0300 Subject: [PATCH] Introduce `Scheme` node --- Makefile | 25 + README.md | 320 +++--------- demo/addons/s7/lib/array.scm | 32 ++ demo/addons/s7/lib/import.scm | 65 +++ demo/addons/s7/lib/prelude.scm | 49 ++ demo/addons/s7/s7_scheme_repl.scm | 132 +++++ demo/addons/s7/test/s7_scheme_tests.gd | 267 ++++++++++ demo/addons/s7/test/s7_scheme_tests.tscn | 10 + demo/main.scm | 15 + demo/main.tscn | 15 + demo/project.godot | 2 +- src/debug_macros.cpp | 23 + src/debug_macros.h | 27 + src/ffi.cpp | 612 +++++++++++++++++++++++ src/ffi.h | 38 ++ src/ffi_macros.h | 12 + src/register_types.cpp | 43 +- src/s7.cpp | 78 +++ src/s7.hpp | 84 ++++ src/scheme.cpp | 125 +++++ src/scheme.h | 45 ++ src/scheme_callable.cpp | 89 ++++ src/scheme_callable.h | 39 ++ src/scheme_object.cpp | 4 + src/scheme_object.h | 33 ++ src/scheme_script.cpp | 10 + src/scheme_script.h | 26 + src/scheme_script_loader.cpp | 38 ++ src/scheme_script_loader.h | 37 ++ test/golden/s7_scheme_tests.txt | 98 ++++ test/test-main.scm | 100 ++++ 31 files changed, 2239 insertions(+), 254 deletions(-) create mode 100644 Makefile create mode 100644 demo/addons/s7/lib/array.scm create mode 100644 demo/addons/s7/lib/import.scm create mode 100644 demo/addons/s7/lib/prelude.scm create mode 100644 demo/addons/s7/s7_scheme_repl.scm create mode 100644 demo/addons/s7/test/s7_scheme_tests.gd create mode 100644 demo/addons/s7/test/s7_scheme_tests.tscn create mode 100644 demo/main.scm create mode 100644 demo/main.tscn create mode 100644 src/debug_macros.cpp create mode 100644 src/debug_macros.h create mode 100644 src/ffi.cpp create mode 100644 src/ffi.h create mode 100644 src/ffi_macros.h create mode 100644 src/s7.cpp create mode 100644 src/s7.hpp create mode 100644 src/scheme.cpp create mode 100644 src/scheme.h create mode 100644 src/scheme_callable.cpp create mode 100644 src/scheme_callable.h create mode 100644 src/scheme_object.cpp create mode 100644 src/scheme_object.h create mode 100644 src/scheme_script.cpp create mode 100644 src/scheme_script.h create mode 100644 src/scheme_script_loader.cpp create mode 100644 src/scheme_script_loader.h create mode 100644 test/golden/s7_scheme_tests.txt create mode 100644 test/test-main.scm diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..97b653a --- /dev/null +++ b/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 diff --git a/README.md b/README.md index 88cce92..665bac2 100644 --- a/README.md +++ b/README.md @@ -1,259 +1,103 @@ -# godot-cpp template -This repository serves as a quickstart template for GDExtension development with Godot 4.0+. - -## Contents -* An empty Godot project (`demo/`) -* godot-cpp as a submodule (`godot-cpp/`) -* GitHub Issues template (`.github/ISSUE_TEMPLATE.yml`) -* GitHub CI/CD workflows to publish your library packages when creating a release (`.github/workflows/builds.yml`) -* GitHub CI/CD actions to build (`.github/actions/build/action.yml`) and to sign Mac frameworks (`.github/actions/build/sign.yml`). -* preconfigured source files for C++ development of the GDExtension (`src/`) -* setup to automatically generate `.xml` files in a `doc_classes/` directory to be parsed by Godot as [GDExtension built-in documentation](https://docs.godotengine.org/en/stable/tutorials/scripting/gdextension/gdextension_docs_system.html) - -## Usage - Template - -To use this template, log in to GitHub and click the green "Use this template" button at the top of the repository page. -This will let you create a copy of this repository with a clean git history. Make sure you clone the correct branch as these are configured for development of their respective Godot development branches and differ from each other. Refer to the docs to see what changed between the versions. - -For getting started after cloning your own copy to your local machine, you should: -* initialize the godot-cpp git submodule via `git submodule update --init` -* change the name of your library - * change the name of the compiled library file inside the `SConstruct` file by modifying the `libname` string. - * change the pathnames of the to be loaded library name inside the `demo/bin/example.gdextension` file. By replacing `libgdexample` to the name specified in your `SConstruct` file. - * change the name of the `demo/bin/example.gdextension` file -* change the `entry_symbol` string inside your `demo/bin/your-extension.gdextension` file to be configured for your GDExtension name. This should be the same as the `GDExtensionBool GDE_EXPORT` external C function. As the name suggests, this sets the entry function for your GDExtension to be loaded by the Godot editors C API. -* register the classes you want Godot to interact with inside the `register_types.cpp` file in the initialization method (here `initialize_gdextension_types`) in the syntax `GDREGISTER_CLASS(CLASS-NAME);`. - -## Usage - Actions - -The actions builds `godot-cpp` at a specified location, and then builds the `gdextension` at a configurable location. It builds for desktop, mobile and web and allows for configuration on what platforms you need. It also supports configuration for debug and release builds, and for double builds. +# Godot scripting via s7 Scheme + +[Godot](https://godotengine.org/) integration for the wonderful [s7 Scheme](https://ccrma.stanford.edu/software/snd/snd/s7.html). `s7` interpreters can be added to scenes as `Scheme` nodes which can load and evaluate code. + +The Scheme code has access to the Godot API via a simple interface (syntax is still in flux): +- the `Scheme` Godot node, which serves as an entry point into the scene model, is exposed as the `*node*` constant +- Godot nodes can be accessed through their relative path to `*node*` via the `$` macro, e.g. `($ Sprite2D)` +- properties can be read via applicable object syntax, e.g., `(*node* 'owner)` reads the [`owner` property](https://docs.godotengine.org/en/stable/classes/class_node.html#class-node-property-owner) of the enclosing node +- applicable syntax can also read nested properties, e.g., `(*node* 'owner 'name)` reads the name of the owner of the enclosing node +- applicable syntax can call methods, e.g., `(*node* 'owner '(get_child 0) 'name)`, even when the arguments are not constants, ``(*node* `(get_child ,child_index))`` +- although explicit syntax for method calls is also provided for when it makes things clearer, `(! (*node* 'owner) 'get_child 0)` +- properties can be set via generalized `set!` syntax, e.g., `(set! (*node* 'owner '(get_child 0) 'name) "Deeply Nested set!")` +- Scheme code can connect to signals via `connect!` + +A more complete example of the available syntax: + +```scheme +(begin + ;; Godot objects are exposed as applicable objects. + (define button (*node* 'owner '(get_child 1))) + + (define (button-append! suffix) + (let ((text (button 'text))) + ;; Godot properties are set via generalized set! syntax + ;; and there are two main ways of calling Godot methods: + ;; * (! &) + ;; * ( '( &)) + ;; ! is preferred for effectful calls such as + ;; 'insert below, and, in general is more amenable + ;; to optimisations. Applicable object syntax + ;; is convenient for const methods like '(length) below and + ;; `(get_child 1) above. + (set! (button 'text) + (! text 'insert (text '(length)) suffix)))) + + (define (function-handler) + (button-append! "!")) + + (define (symbol-handler) + (button-append! "'")) + + ;; Signals can be connected to symbols, lambdas and arbitrary procedures. + ;; Symbols provide late binding, i.e., the ability to redefine the + ;; procedure bound to a symbol / signal via the repl while the program is + ;; running. + (connect! button 'pressed 'symbol-handler) + (connect! button 'pressed (lambda () (button-append! "Ξ»"))) + (connect! button 'pressed function-handler)) +``` -The action uses SConstruct for both godot-cpp and the GDExtension that is built. +## Status -To reuse the build actions, in a github actions yml file, do the following: +Very experimental but a lot of fun to play with. Use it at your own risk. -```yml -name: Build GDExtension -on: - workflow_call: - push: +## Building -jobs: - build: - strategy: - fail-fast: false - matrix: - include: - - platform: linux - arch: x86_64 - os: ubuntu-20.04 - - platform: windows - arch: x86_32 - os: windows-latest - - platform: windows - arch: x86_64 - os: windows-latest - - platform: macos - arch: universal - os: macos-latest - - platform: android - arch: arm64 - os: ubuntu-20.04 - - platform: android - arch: arm32 - os: ubuntu-20.04 - - platform: android - arch: x86_64 - os: ubuntu-20.04 - - platform: android - arch: x86_32 - os: ubuntu-20.04 - - platform: ios - arch: arm64 - os: macos-latest - - platform: web - arch: wasm32 - os: ubuntu-20.04 +Make sure to update all git submodules: - runs-on: ${{ matrix.os }} - steps: - - name: Checkout - uses: actions/checkout@v4 - with: - submodules: true - - name: πŸ”— GDExtension Build - uses: godotengine/godot-cpp-template/.github/actions/build@main - with: - platform: ${{ matrix.platform }} - arch: ${{ matrix.arch }} - float-precision: single - build-target-type: template_release - - name: πŸ”— GDExtension Build - uses: ./.github/actions/build - with: - platform: ${{ matrix.platform }} - arch: ${{ matrix.arch }} - float-precision: ${{ matrix.float-precision }} - build-target-type: template_debug - - name: Mac Sign - if: ${{ matrix.platform == 'macos' && env.APPLE_CERT_BASE64 }} - env: - APPLE_CERT_BASE64: ${{ secrets.APPLE_CERT_BASE64 }} - uses: godotengine/godot-cpp-template/.github/actions/sign@main - with: - FRAMEWORK_PATH: bin/macos/macos.framework - APPLE_CERT_BASE64: ${{ secrets.APPLE_CERT_BASE64 }} - APPLE_CERT_PASSWORD: ${{ secrets.APPLE_CERT_PASSWORD }} - APPLE_DEV_PASSWORD: ${{ secrets.APPLE_DEV_PASSWORD }} - APPLE_DEV_ID: ${{ secrets.APPLE_DEV_ID }} - APPLE_DEV_TEAM_ID: ${{ secrets.APPLE_DEV_TEAM_ID }} - APPLE_DEV_APP_ID: ${{ secrets.APPLE_DEV_APP_ID }} - - name: Upload Artifact - uses: actions/upload-artifact@v4 - with: - name: GDExtension-${{ matrix.platform }}-${{ matrix.arch }} - path: | - ${{ github.workspace }}/bin/** - merge: - runs-on: ubuntu-latest - needs: build - steps: - - name: Merge Artifacts - uses: actions/upload-artifact/merge@v4 - with: - name: GDExtension-all - pattern: GDExtension-* - delete-merged: true +```shell + git submodule update --init ``` -The above example is a lengthy one, so we will go through it action by action to see what is going on. +Build and launch the demo project with: -In the `Checkout` step, we checkout the code. -In the `πŸ”— GDExtension Build` step, we are using the reusable action: -```yml -uses: godotengine/godot-cpp-template/.github/actions/build@main -with: - platform: ${{ matrix.platform }} - arch: ${{ matrix.arch }} - float-precision: single - build-target-type: template_release +```shell + scons && godot -e --path demo ``` -with the parameters from the matrix. - -As a result of this step, the binaries will be built in the `bin` folder (as specified in the SConstruct file). After all builds are completed, all individual builds will be merged into one common GDExtension-all zip that you can download. - -Note: for macos, you will have to build the binary as a `.dylib` in a `EXTENSION-NAME.framework` folder. The framework folder should also have a `Resources` folder with a file called `Info.plist`. Without this file, signing will fail. -Note: for iOS, the same should be as for MacOS, however the `Info.plist` file needs to be close to the `.dylib`, instead of in a `Resources` folder (If this is not done, the build will fail to upload to the App Store). +Build the Android target with: -So, in our case, the builds should be: - -```sh -bin/EXTENSION-NAME.macos.template_debug.framework/EXTENSION-NAME.macos.template_release -bin/EXTENSION-NAME.ios.template_debug.framework/EXTENSION-NAME.ios.template_release.arm64.dylib - -Afterwards, you want to set in the `.gdextension` file the paths to the `.framework` folder, instead of the `.dylib` file (Note that for the `.dylib` binary, the extension is not needed, you could have a file without any extension and it would still work). - -In the `name: Mac Sign` step, we are signing the generated mac binaries. -We are reusing the following action: -```yml -uses: godotengine/godot-cpp-template/.github/actions/sign@main -with: - FRAMEWORK_PATH: bin/macos/macos.framework - APPLE_CERT_BASE64: ${{ secrets.APPLE_CERT_BASE64 }} - APPLE_CERT_PASSWORD: ${{ secrets.APPLE_CERT_PASSWORD }} - APPLE_DEV_PASSWORD: ${{ secrets.APPLE_DEV_PASSWORD }} - APPLE_DEV_ID: ${{ secrets.APPLE_DEV_ID }} - APPLE_DEV_TEAM_ID: ${{ secrets.APPLE_DEV_TEAM_ID }} - APPLE_DEV_APP_ID: ${{ secrets.APPLE_DEV_APP_ID }} +```shell + scons platform=android target=template_debug ``` -As you can see, this action requires some secrets to be configured in order to run. Also, you need to tell it the path to the `.framework` folder, where you have both the binary (`.dylib` file) and the `Resources` folder with the `Info.plist` file. - -## Configuration - Mac Signing Secrets - -In order to sign the Mac binary, you need to configure the following secrets: -`APPLE_CERT_BASE64`, `APPLE_CERT_PASSWORD`, `APPLE_DEV_PASSWORD`, `APPLE_DEV_ID`, `APPLE_DEV_TEAM_ID`, `APPLE_DEV_APP_ID`. These secrets are stored in the example above in the Github secrets for repositories. The names of the secrets have to match the names of the secrets you use for your action. For more on this, read the [Creating secrets for a repository](https://docs.github.com/en/actions/security-guides/using-secrets-in-github-actions#creating-secrets-for-a-repository) article from Github. - -These secrets are then passed down to the `godotengine/godot-cpp-template/.github/actions/sign@main` action that signs the binary. - -In order to configure these secrets, you will need: - -- A Mac -- An Apple ID enrolled in Apple Developer Program (99 USD per year) -- A `Resources/Info.plist` in the `framework` folder. Take the one in this project as an example. Be careful to set CFBundleExecutable to the **EXACT** lib name, otherwise it won't work. Also, don't put strange names in the CFBundleName and other such places. Try to only use letters and spaces. Errors will be extremly vague if not impossible to debug. -For the actions you will need to set the following inputs. Store them as secrets in GitHub: +Make sure `ANDROID_HOME` is set. -- APPLE_CERT_BASE64 -- APPLE_CERT_PASSWORD -- APPLE_DEV_ID -- APPLE_DEV_TEAM_ID -- APPLE_DEV_PASSWORD -- APPLE_DEV_APP_ID +## Emacs live editing support (WIP) -You will find here a guide on how to create all of them. Go to [developer.apple.com](developer.apple.com): +Install [Geiser](https://www.nongnu.org/geiser/) then add the following to your Emacs configuration: -- Create an Apple ID if you don’t have one already. -- Use your Apple ID to register in the Apple Developer Program. -- Accept all agreements from the Apple Developer Page. - -### APPLE_DEV_ID - Apple ID - -- Your email used for your Apple ID. - -- APPLE_DEV_ID = email@provider.com - -### APPLE_DEV_TEAM_ID - Apple Team ID - -- Go to [developer.apple.com](https://developer.apple.com). Go to account. -- Go to membership details. Copy Team ID. - -- APPLE_DEV_TEAM_ID = `1ABCD23EFG` - -### APPLE_DEV_PASSWORD - Apple App-Specific Password - -- Create [Apple App-Specific Password](https://support.apple.com/en-us/102654). Copy the password. - -- APPLE_DEV_PASSWORD = `abcd-abcd-abcd-abcd` - -### APPLE_CERT_BASE64 and APPLE_CERT_PASSWORD and APPLE_DEV_APP_ID - -- Go to [developer.apple.com](https://developer.apple.com). Go to account. -- Go to certificates. -- Click on + at Certificates tab. Create Developer ID Application. Click Continue. -- Leave profile type as is. [Create a certificate signing request from a mac](https://developer.apple.com/help/account/create-certificates/create-a-certificate-signing-request). You can use your own name and email address. Save the file to disk. You will get a file called `CertificateSigningRequest.certSigningRequest`. Upload it to the Developer ID Application request. Click Continue. -- Download the certificate. You will get a file `developerID_application.cer`. -- On a Mac, right click and select open. Add it to the login keychain. In the Keychain Access app that opened, login Keychain tab, go to Keys, sort by date modified, expand your key (the key should have name you entered at common name `Common Name`), right click the expanded certificate, get info, and copy the text at Details -> Subject Name -> Common Name. -Eg. -- APPLE_DEV_APP_ID = `Developer ID Application: Common Name (1ABCD23EFG)` - -- Then, select the certificate, right click and click export. At file format select p12. When exporting, set a password for the certificate. This will be APPLE_CERT_PASSWORD. You will get a `Certificates.p12` file. +```elisp + (add-to-list 'load-path "~/path/to/godot-s7-scheme/emacs/") + (load "geiser-godot-s7-autoloads.el") +``` -Eg. -- APPLE_CERT_PASSWORD = `` +The Emacs extension automatically recognize Scheme files inside Godot project directories as `Godot s7 Scheme` files. -- Then you need to make a base64 file out of it, by running: -``` -base64 -i Certificates.p12 -o Certificates.base64 -``` +### Connecting -- Copy the contents of the generated file: -Eg. -- `APPLE_CERT_BASE64` = `...`(A long text file) +1. Add a `SchemeReplServer` to your scene (preferably as a child of a `Scheme` node) and set its `Auto Start` property to `true`. +2. Check the port number in the Godot output window. +3. `M-x connect-to-godot-s7` -After these secrets are obtained, all that remains is to set them in Github secrets and then use them in the Github action, eg. in the above Github action usage example, this part: +## Roadmap -``` -- name: Mac Sign - if: ${{ matrix.platform == 'macos' && env.APPLE_CERT_BASE64 }} - env: - APPLE_CERT_BASE64: ${{ secrets.APPLE_CERT_BASE64 }} - uses: godotengine/godot-cpp-template/.github/actions/sign@main - with: - FRAMEWORK_PATH: bin/macos/macos.framework - APPLE_CERT_BASE64: ${{ secrets.APPLE_CERT_BASE64 }} - APPLE_CERT_PASSWORD: ${{ secrets.APPLE_CERT_PASSWORD }} - APPLE_DEV_PASSWORD: ${{ secrets.APPLE_DEV_PASSWORD }} - APPLE_DEV_ID: ${{ secrets.APPLE_DEV_ID }} - APPLE_DEV_TEAM_ID: ${{ secrets.APPLE_DEV_TEAM_ID }} -``` +- [x] use Godot API from Scheme +- [o] live coding interface via Emacs (wip) +- [ ] expose tree-sitter API to Scheme +- [ ] Scheme editor with syntax highlighting +- [ ] Scheme notebooks +- [ ] expose Godot signals from Scheme +- [ ] subclass Godot classes from Scheme +- [ ] register Scheme as a proper [script language extension](https://docs.godotengine.org/en/stable/classes/class_scriptlanguageextension.html#class-scriptlanguageextension) diff --git a/demo/addons/s7/lib/array.scm b/demo/addons/s7/lib/array.scm new file mode 100644 index 0000000..d06736f --- /dev/null +++ b/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. # 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)) + diff --git a/demo/addons/s7/lib/import.scm b/demo/addons/s7/lib/import.scm new file mode 100644 index 0000000..345a91a --- /dev/null +++ b/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))) diff --git a/demo/addons/s7/lib/prelude.scm b/demo/addons/s7/lib/prelude.scm new file mode 100644 index 0000000..41aa537 --- /dev/null +++ b/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/.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)) + diff --git a/demo/addons/s7/s7_scheme_repl.scm b/demo/addons/s7/s7_scheme_repl.scm new file mode 100644 index 0000000..724c957 --- /dev/null +++ b/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 (rbo@acm.org) +;; Maintainer: Rodrigo B. de Oliveira (rbo@acm.org) +;; 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 #) + (,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))) diff --git a/demo/addons/s7/test/s7_scheme_tests.gd b/demo/addons/s7/test/s7_scheme_tests.gd new file mode 100644 index 0000000..63cc8ba --- /dev/null +++ b/demo/addons/s7/test/s7_scheme_tests.gd @@ -0,0 +1,267 @@ +extends Node + +func make_node(name: String): + var n = Node.new() + n.name = name + return n + +func define(name: String, value: Variant): + $Scheme.define(name, value) + +func show_value_with_type(r): + return "%s(%s)" % [type_string(typeof(r)), r] + +func eval(code: String): + var r = $Scheme.eval(code) + print(code, "=>", show_value_with_type(r)) + return r + +func apply(symbol: String, args: Array): + var r = $Scheme.apply(symbol, args) + print("(apply ", symbol, " ", args, ")=>", show_value_with_type(r)) + return r + +func can_exchange_primitive_values(): + eval("(format #t \"Hello from Scheme!\n\")") + + define("an-integer", 41) + eval("an-integer") + eval("(+ 1 an-integer)") + + define("a-float", 41.0) + eval("a-float") + eval("(+ 1 a-float)") + + define("a-true", true) + define("a-false", false) + eval("(if a-false #t #f)") + eval("(if a-true #t #f)") + eval("(if (not a-false) #f #t)") + eval("(if (not a-true) #f #t)") + +func can_connect_signal_to_symbol(): + # given: a signal connected to a symbol + $Scheme.eval(""" + (begin + (define (handler n) (print "v1:" (n 'name))) + (connect! *node* 'child_entered_tree 'handler)) + """) + eval("(connected? *node* 'child_entered_tree 'handler)") + $Scheme.add_child(make_node("s1")) + # when: procedure is update + $Scheme.eval(""" + (define (handler n) (print "v2:" (n 'name))) + """) + # then: signal should trigger new procedure + $Scheme.add_child(make_node("s2")) + # when: symbol is disconnected from signal + $Scheme.eval(""" + (disconnect! *node* 'child_entered_tree 'handler) + """) + eval("(connected? *node* 'child_entered_tree 'handler)") + # then: signal no longer triggers the procedure + $Scheme.add_child(make_node("s3")) + +func can_connect_signal_to_procedure(): + # given: a signal connected to a procedure + $Scheme.eval(""" + (begin + (define (handler n) (print "v1:" (n 'name))) + (connect! *node* 'child_entered_tree handler)) + """) + eval("(connected? *node* 'child_entered_tree handler)") + $Scheme.add_child(make_node("p1")) + # when: procedure is update + $Scheme.eval(""" + (define original-handler handler) + (define (handler n) (print "v2:" (n 'name))) + """) + # then: signal should trigger OLD procedure + $Scheme.add_child(make_node("p2")) + # when: symbol is disconnected from signal + $Scheme.eval(""" + (disconnect! *node* 'child_entered_tree original-handler) + """) + eval("(connected? *node* 'child_entered_tree original-handler)") + # then: signal no longer triggers the procedure + $Scheme.add_child(make_node("p3")) + +func can_compare_variants(): + define("v1", [1, 2, 3]) + define("v2", [1, 2, 3, 4]) + define("v3", [1, 2, 3]) + define("v4", "foo") + define("v5", "bar") + define("v6", "foo") + eval("(equal? v1 v2)") + eval("(equal? v1 v3)") + eval("(equal? v4 v5)") + eval("(equal? v4 v6)") + +func can_query_variant_type(): + # int, float and boolean values are never stored as variants + define("i1", 42) + define("f1", 42.0) + define("b1", true) + define("b2", false) + eval("(or (Variant? i1) (Variant? f1) (Variant? b1) (Variant? b2))") + + # everything else, including Strings are Variants + define("v1", []) + eval("(VariantType->string (Variant? v1))") + define("v2", {"foo": "bar"}) + eval("(VariantType->string (Variant? v2))") + define("v3", "Strings are not automatically converted to Scheme") + eval("(VariantType->string (Variant? v3))") + +func can_create_arrays(): + eval("(Array)") + eval("(Array 1 2.0 \"three\" #t #f)") + +func can_create_vectors(): + eval("(Vector2 1.0 2.0)") + eval("(Vector2 1 2)") + eval("(Vector2i 1 2)") + +func can_create_rects(): + eval("(Rect2 1.0 2.0 3.0 4.0)") + eval("(Rect2 1 2 3 4)") + eval("(Rect2i 1 2 3 4)") + +func can_map_arrays(): + define("a1", [1, 2, 3]) + eval("(! a1 'map (lambda (x) (* 2 x)))") + eval("(a1 `(map ,(lambda (x) (* 3 x))))") + eval("(define (f x) (* 4 x))") + eval("a1") + + # Callable discards return values by default + eval("(! a1 'map (Callable 'f))") + eval("(! a1 'map (Callable 'f #f))") + eval("(! a1 'map (Callable 'f #t))") + +func can_import_classes(): + eval(""" + (begin + (require 'import) + (import-class Performance :as p) + (help 'p/get-monitor)) + """) + +func can_import_singletons(): + eval(""" + (begin + (require 'import) + (import-singleton Performance :as p) + (help 'p/get-monitor)) + """) + +func can_create_dictionaries(): + eval("(let ((d (Dictionary))) (set! (d 0) (Color \"red\")) d)") + +func can_iterate_on_variants(): + eval(""" + (define (test-for-each-on xs) + (call-with-output-string + (lambda (p) + (for-each + (lambda (x) (format p "(~A)" x)) + xs)))) + """) + define("array", [1, 2, 3]) + eval("(test-for-each-on array)") + define("dictionary", {"foo": "bar"}) + eval("(test-for-each-on dictionary)") + define("string", "Scheme") + eval("(test-for-each-on string)") + +func can_use_tree_sitter_api(): + eval(""" + (call-with-output-string (lambda (p) + + (require 'tree-sitter) + + (define (print-node node depth) + (format p "~A~A..~A:~A:~A~%" + (if (> depth 0) (make-string (* depth 2) #\\ ) "\\n") + (ts-node-start-point node) + (ts-node-end-point node) + (ts-node-symbol node) + (ts-node-type node))) + + (define (print-subtree node depth) + (print-node node depth) + (for-each + (lambda (child) (print-subtree child (+ 1 depth))) + node)) + + (let* ((tree (ts-parser-parse-string (ts-parser-new) "(Scheme\\nrulez!)")) + (root (ts-tree-root-node tree))) + (print-subtree root 0) + (let ((cursor (ts-tree-cursor-new root))) + (format p "first-child-for-point (1 . 0) => ~A" (ts-tree-cursor-goto-first-child-for-point cursor '(1 . 0))) + (print-node (ts-tree-cursor-current-node cursor) 0))))) + """) + +func roundtrip(expr: String, type_test: String): + var v = eval(expr) + define("roundtrip", v) + eval("(%s roundtrip)" % type_test) + +func char_becomes_int(): + roundtrip("#\\c", "char?") # false + eval("(integer? roundtrip)") + +func symbol_roundtrips_as_StringName(): + roundtrip(":a-keyword-symbol", "symbol?") + +func producedure_roundtrips_as_Callable(): + roundtrip("(lambda (x) (* x 2))", "procedure?") + eval("(roundtrip 21)") + +func can_pass_arbitrary_scheme_objects_back_n_forth(): + roundtrip("#t", "boolean?") + roundtrip("42", "integer?") + roundtrip("42.0", "real?") + roundtrip("()", "list?") + roundtrip("'(1 . 2)", "pair?") + roundtrip("'(1 2 3)", "pair?") + roundtrip("#(1 2 3)", "vector?") + roundtrip("#", "undefined?") + +func can_apply_functions(): + eval("(define* (scheme-function (a #f) (b #t) (c 42)) (object->string (list a b c)))") + + # apply with no arguments first + var r = $Scheme.apply("scheme-function") + print("(apply scheme-function)=>", show_value_with_type(r)) + + apply("scheme-function", [1]) + apply("scheme-function", [1, 2]) + apply("scheme-function", [1, 2, 3]) + apply("scheme-function", [1, 2, 3, 4]) + apply("scheme-function", [1, &":b", 2]) + apply("scheme-function", [1, &":b", 2, &":c", 33]) + apply("non-existing-function", []) + +func _ready(): + can_exchange_primitive_values() + can_connect_signal_to_symbol() + can_connect_signal_to_procedure() + can_compare_variants() + can_query_variant_type() + can_create_arrays() + can_map_arrays() + can_create_vectors() + can_create_rects() + can_import_classes() + #can_import_singletons() + can_create_dictionaries() + can_iterate_on_variants() + #can_use_tree_sitter_api() + char_becomes_int() + symbol_roundtrips_as_StringName() + producedure_roundtrips_as_Callable() + can_pass_arbitrary_scheme_objects_back_n_forth() + can_apply_functions() + get_tree().quit() diff --git a/demo/addons/s7/test/s7_scheme_tests.tscn b/demo/addons/s7/test/s7_scheme_tests.tscn new file mode 100644 index 0000000..cdb385c --- /dev/null +++ b/demo/addons/s7/test/s7_scheme_tests.tscn @@ -0,0 +1,10 @@ +[gd_scene load_steps=3 format=3 uid="uid://8rdh7h8fh5mx"] + +[ext_resource type="Script" path="res://addons/s7/test/s7_scheme_tests.gd" id="1_ke81w"] +[ext_resource type="SchemeScript" path="res://addons/s7/lib/prelude.scm" id="2_weia3"] + +[node name="SchemeTests" type="Node"] +script = ExtResource("1_ke81w") + +[node name="Scheme" type="Scheme" parent="."] +prelude = Array[SchemeScript]([ExtResource("2_weia3")]) diff --git a/demo/main.scm b/demo/main.scm new file mode 100644 index 0000000..c20777d --- /dev/null +++ b/demo/main.scm @@ -0,0 +1,15 @@ +(define amplitude 42) +(define elapsed-time 0.0) + +(define (_process delta) + + (inc! elapsed-time :by delta) + + ;; animate sprite + (let ((x (amplitude-of sin 2.0)) + (y (amplitude-of cos 1.5))) + (! ($ Sprite2D) 'set_position (Vector2 (+ 500 x) (+ 280 y))))) + +(define (amplitude-of f speed) + "Projects amplitude using f at the current time." + (+ amplitude (* amplitude (f (* elapsed-time speed))))) diff --git a/demo/main.tscn b/demo/main.tscn new file mode 100644 index 0000000..4553c81 --- /dev/null +++ b/demo/main.tscn @@ -0,0 +1,15 @@ +[gd_scene load_steps=4 format=3 uid="uid://dd42y1qp4irg8"] + +[ext_resource type="SchemeScript" path="res://main.scm" id="1_4c4e2"] +[ext_resource type="SchemeScript" path="res://addons/s7/lib/prelude.scm" id="1_r2s6g"] +[ext_resource type="Texture2D" uid="uid://dbx66sovxd1" path="res://icon.svg" id="3_lw6r1"] + +[node name="Main" type="Node2D"] + +[node name="Scheme" type="Scheme" parent="."] +prelude = Array[SchemeScript]([ExtResource("1_r2s6g")]) +scheme_script = ExtResource("1_4c4e2") + +[node name="Sprite2D" type="Sprite2D" parent="Scheme"] +position = Vector2(567, 359.289) +texture = ExtResource("3_lw6r1") diff --git a/demo/project.godot b/demo/project.godot index 9c5c174..2a5ec61 100644 --- a/demo/project.godot +++ b/demo/project.godot @@ -11,5 +11,5 @@ config_version=5 [application] config/name="godot cpp template" -config/features=PackedStringArray("4.1", "Forward Plus") +config/features=PackedStringArray("4.3", "Forward Plus") config/icon="res://icon.svg" diff --git a/src/debug_macros.cpp b/src/debug_macros.cpp new file mode 100644 index 0000000..08fa3d0 --- /dev/null +++ b/src/debug_macros.cpp @@ -0,0 +1,23 @@ +#include "debug_macros.h" + +#if DEBUG_LOG + +#include "ffi.h" +#include + +using namespace godot; + +s7_pointer watch_s7_value( + s7_scheme *sc, const char *func, int line, const char *e, s7_pointer v) { + std::cout << func << ":" << line << ":" << e << ":"; + auto type = scheme_object_to_godot_string(sc, s7_type_of(sc, v)); + auto str = scheme_object_to_godot_string(sc, v); + std::cout << type.utf8() << ":" << str.utf8() << std::endl; + return v; +} + +const Variant &watch_variant(const char *func, int line, const char *e, const Variant &v) { + std::cout << func << ":" << line << ":" << e << ":" << v.stringify().utf8() << std::endl; + return v; +} +#endif \ No newline at end of file diff --git a/src/debug_macros.h b/src/debug_macros.h new file mode 100644 index 0000000..84df2da --- /dev/null +++ b/src/debug_macros.h @@ -0,0 +1,27 @@ + +#ifndef GODOT_S7_SCHEME_DEBUG_MACROS_H +#define GODOT_S7_SCHEME_DEBUG_MACROS_H + +#include +#include + +#define DEBUG_LOG 0 + +#if DEBUG_LOG + +#define WATCH(e) watch_s7_value(sc, __func__, __LINE__, #e, e) +#define WATCH_VARIANT(v) watch_variant(__func__, __LINE__, #v, v) +#define LOG_CALL() (std::cout << __func__ << ":" << __LINE__ << std::endl) + +s7_pointer watch_s7_value( + s7_scheme *sc, const char *func, int line, const char *e, s7_pointer v); +const godot::Variant &watch_variant( + const char *func, int line, const char *e, const godot::Variant &v); + +#else +#define WATCH(e) 0 +#define WATCH_VARIANT(v) 0 +#define LOG_CALL() 0 +#endif + +#endif //GODOT_S7_SCHEME_DEBUG_MACROS_H diff --git a/src/ffi.cpp b/src/ffi.cpp new file mode 100644 index 0000000..0ad36cc --- /dev/null +++ b/src/ffi.cpp @@ -0,0 +1,612 @@ +#include "ffi.h" +#include "debug_macros.h" +#include "ffi_macros.h" +#include "scheme_callable.h" +#include "scheme_object.h" + +#include +#include +#include + +#define VARIANT_TYPE_TAG 0 + +#define EXPECT_VARIANT_ARG(n) EXPECT_ARG(n, variant_value(_arg), is_variant, "Variant") + +namespace godot { +s7_pointer variant_to_string(s7_scheme *sc, s7_pointer args) { + auto v = variant_value(s7_car(args)); + auto str = "stringify() + ">"; + return godot_string_to_scheme_string(sc, str); +} + +s7_pointer variant_free([[maybe_unused]] s7_scheme *sc, s7_pointer obj) { + WATCH(obj); + delete variant_value(obj); + return s7_unspecified(sc); +} + +bool is_variant(s7_pointer arg) { + return s7_is_c_object(arg) && s7_c_object_type(arg) == VARIANT_TYPE_TAG; +} + +s7_pointer g_is_variant(s7_scheme *sc, s7_pointer args) { + auto arg = s7_car(args); + if (is_variant(arg)) { + return s7_make_integer(sc, variant_value(arg)->get_type()); + } + return s7_make_boolean(sc, false); +} + +s7_pointer make_variant_object(s7_scheme *sc, const Variant &v) { + return s7_make_c_object(sc, VARIANT_TYPE_TAG, new Variant(v)); +} + +s7_pointer variant_to_scheme(s7_scheme *sc, const Variant &v) { + WATCH_VARIANT(v); + switch (v.get_type()) { + case Variant::NIL: + return s7_unspecified(sc); + case Variant::BOOL: + return s7_make_boolean(sc, v); + case Variant::INT: + return s7_make_integer(sc, v); + case Variant::FLOAT: + return s7_make_real(sc, v); + case Variant::STRING_NAME: + return s7_make_symbol(sc, v.stringify().utf8()); + case Variant::OBJECT: { + const Object *obj = v; + auto scheme_object = dynamic_cast(obj); + if (scheme_object != nullptr && scheme_object->belongs_to(sc)) { + return scheme_object->get_scheme_ptr(); + } + return make_variant_object(sc, v); + } + default: + return make_variant_object(sc, v); + // case Variant::STRING: // given the performance implications, better to + // convert strings explicitly + // break; + // case Variant::VECTOR2: + // break; + // case Variant::VECTOR2I: + // break; + // case Variant::RECT2: + // break; + // case Variant::RECT2I: + // break; + // case Variant::VECTOR3: + // break; + // case Variant::VECTOR3I: + // break; + // case Variant::TRANSFORM2D: + // break; + // case Variant::VECTOR4: + // break; + // case Variant::VECTOR4I: + // break; + // case Variant::PLANE: + // break; + // case Variant::QUATERNION: + // break; + // case Variant::AABB: + // break; + // case Variant::BASIS: + // break; + // case Variant::TRANSFORM3D: + // break; + // case Variant::PROJECTION: + // break; + // case Variant::COLOR: + // break; + // case Variant::NODE_PATH: + // break; + // case Variant::RID: + // break; + // case Variant::CALLABLE: + // break; + // case Variant::SIGNAL: + // break; + // case Variant::DICTIONARY: + // break; + // case Variant::ARRAY: + // break; + // case Variant::PACKED_BYTE_ARRAY: + // break; + // case Variant::PACKED_INT32_ARRAY: + // break; + // case Variant::PACKED_INT64_ARRAY: + // break; + // case Variant::PACKED_FLOAT32_ARRAY: + // break; + // case Variant::PACKED_FLOAT64_ARRAY: + // break; + // case Variant::PACKED_STRING_ARRAY: + // break; + // case Variant::PACKED_VECTOR2_ARRAY: + // break; + // case Variant::PACKED_VECTOR3_ARRAY: + // break; + // case Variant::PACKED_COLOR_ARRAY: + // break; + // case Variant::VARIANT_MAX: + // break; + } +} + +Variant scheme_to_variant(s7_scheme *sc, s7_pointer arg) { + if (s7_is_integer(arg)) { + return s7_integer(arg); + } + if (s7_is_real(arg)) { + return s7_real(arg); + } + if (s7_is_string(arg)) { + return scheme_string_to_godot_string(arg); + } + if (s7_is_boolean(arg)) { + return s7_boolean(sc, arg); + } + if (is_variant(arg)) { + return *variant_value(arg); + } + if (s7_is_unspecified(sc, arg)) { + return {}; + } + if (s7_is_procedure(arg)) { + return Callable(memnew(SchemeCallable(sc, arg, false))); + } + if (s7_is_symbol(arg)) { + return StringName(s7_symbol_name(arg)); + } + if (s7_is_character(arg)) { + return s7_character(arg); + } + WATCH(arg); + return memnew(SchemeObject(sc, arg)); +} + +s7_pointer g_make_variant(s7_scheme *sc, s7_pointer args) { + auto arg = s7_car(args); + WATCH(arg); + return make_variant_object(sc, scheme_to_variant(sc, arg)); +} + +s7_pointer g_variant_type_to_string(s7_scheme *sc, s7_pointer args) { + BEGIN_ARGS(); + EXPECT_INT_ARG(variant_type); + return godot_string_to_scheme_string(sc, UtilityFunctions::type_string(variant_type)); +} + +s7_pointer g_variant_string(s7_scheme *sc, s7_pointer args) { + BEGIN_ARGS(); + EXPECT_VARIANT_ARG(variant); + if (variant->get_type() == Variant::Type::STRING) { + return godot_string_to_scheme_string(sc, *variant); + } + return godot_string_to_scheme_string(sc, variant->stringify()); +} + +template +C collect_variants_into(C result, s7_scheme *sc, s7_pointer vars) { + while (s7_is_pair(vars)) { + result.push_back(scheme_to_variant(sc, s7_car(vars))); + vars = s7_cdr(vars); + } + return result; +} + +std::vector collect_variants(s7_scheme *sc, s7_pointer args) { + return collect_variants_into(std::vector(), sc, args); +} + +std::vector collect_pointers(const std::vector &vargs) { + auto pointers = std::vector(vargs.size()); + for (size_t i = 0; i < vargs.size(); i++) { + pointers[i] = &vargs[i]; + } + return pointers; +} + +s7_pointer variant_call_with_receiver(s7_scheme *sc, s7_pointer receiver, s7_pointer args) { + BEGIN_ARGS(); + EXPECT_SYMBOL_ARG(method); + + GDExtensionCallError error; + Variant ret; + + WATCH(receiver); + if (s7_is_pair(args)) { + auto vargs = collect_variants(sc, args); + auto pointers = collect_pointers(vargs); + variant_value(receiver)->callp(s7_symbol_name(method), + pointers.data(), + static_cast(vargs.size()), + ret, + error); + } else { + variant_value(receiver)->callp(s7_symbol_name(method), nullptr, 0, ret, error); + } + + if (error.error != GDEXTENSION_CALL_OK) { + return s7_error(sc, + s7_make_symbol(sc, "godot"), + godot_string_to_scheme_string(sc, UtilityFunctions::error_string(error.error))); + } + return variant_to_scheme(sc, ret); +} + +s7_pointer g_variant_call(s7_scheme *sc, s7_pointer args) { + WATCH(args); + + s7_pointer receiver = s7_car(args); + if (!is_variant(receiver)) { + return s7_wrong_type_arg_error(sc, __func__, 0, receiver, "Variant"); + } + args = s7_cdr(args); + return variant_call_with_receiver(sc, receiver, args); +} + +static s7_pointer g_class_db(s7_scheme *sc, s7_pointer args) { + return make_variant_object(sc, ClassDBSingleton::get_singleton()); +} + +s7_pointer variant_ref_1(s7_scheme *sc, s7_pointer receiver, s7_pointer arg) { + if (s7_is_symbol(arg)) { + bool valid; + auto name = s7_symbol_name(arg); + auto r = variant_value(receiver)->get_named(name, valid); + if (!valid) { + return nullptr; + } + return variant_to_scheme(sc, r); + } + if (s7_is_integer(arg)) { + bool valid; + bool oob; + auto idx = s7_integer(arg); + auto r = variant_value(receiver)->get_indexed(idx, valid, oob); + if (!valid || oob) { + return nullptr; + } + return variant_to_scheme(sc, r); + } + if (s7_is_list(sc, arg)) { + return variant_call_with_receiver(sc, receiver, arg); + } + return nullptr; +} + +s7_pointer variant_ref(s7_scheme *sc, s7_pointer args) { + WATCH(args); + + s7_pointer res = s7_car(args); + args = s7_cdr(args); + + if (variant_value(res)->get_type() == Variant::CALLABLE) { + const Callable &callable = *variant_value(res); + return variant_to_scheme(sc, callable.callv(collect_variants_into(Array(), sc, args))); + } + + while (args != s7_nil(sc)) { + auto arg = s7_car(args); + res = variant_ref_1(sc, res, arg); + if (res == nullptr) { + return s7_unspecified(sc); + } + args = s7_cdr(args); + } + return res; +} + +bool variant_set_1(s7_pointer receiver, s7_pointer arg, const Variant &value) { + if (s7_is_symbol(arg)) { + bool valid; + auto name = s7_symbol_name(arg); + variant_value(receiver)->set_named(name, value, valid); + return valid; + } else if (s7_is_integer(arg)) { + bool valid; + bool oob; + auto idx = s7_integer(arg); + variant_value(receiver)->set_indexed(idx, value, valid, oob); + return valid && !oob; + } else { + return false; + } +} + +s7_pointer variant_set(s7_scheme *sc, s7_pointer args) { + auto next_args = args; + auto receiver = s7_car(next_args); + next_args = s7_cdr(next_args); + + while (s7_cdr(next_args) != s7_nil(sc) && s7_cddr(next_args) != s7_nil(sc)) { + auto arg = s7_car(next_args); + receiver = variant_ref_1(sc, receiver, arg); + if (receiver == nullptr) { + return s7_unspecified(sc); + } + next_args = s7_cdr(next_args); + } + + WATCH(receiver); + WATCH(args); + + if (s7_cdr(next_args) == s7_nil(sc)) { + // not enough arguments + return s7_wrong_number_of_args_error(sc, __func__, args); + } + + auto arg = s7_car(next_args); + auto value = s7_cadr(next_args); + auto variant_value = scheme_to_variant(sc, value); + if (!variant_set_1(receiver, arg, variant_value)) { + return s7_unspecified(sc); + } + return value; +} + +s7_pointer variants_to_list(s7_scheme *sc, const Variant **args, int arg_count) { + auto list = s7_nil(sc); + while (arg_count > 0) { + auto arg = variant_to_scheme(sc, *args[--arg_count]); + list = s7_cons(sc, arg, list); + } + return list; +} + +s7_pointer variant_is_equal(s7_scheme *sc, s7_pointer args) { + auto v1 = s7_car(args); // we can assume this is a Variant + auto v2 = s7_cadr(args); + if (is_variant(v2)) { + return s7_make_boolean(sc, *variant_value(v1) == *variant_value(v2)); + } + return s7_make_boolean(sc, false); +} + +s7_pointer g_make_Dictionary(s7_scheme *sc, s7_pointer args) { + return make_variant_object(sc, Dictionary()); +} + +s7_pointer g_make_Color(s7_scheme *sc, s7_pointer args) { + BEGIN_ARGS(); + EXPECT_STRING_ARG(color); + return make_variant_object(sc, Color(s7_string(color))); +} + +s7_pointer g_make_Callable(s7_scheme *sc, s7_pointer args) { + auto f = s7_car(args); + auto discard_return_value = + s7_is_pair(s7_cdr(args)) ? s7_boolean(sc, s7_cadr(args)) : true; + return make_variant_object( + sc, + Callable(memnew(SchemeCallable(sc, f, discard_return_value)))); +} + +s7_pointer g_make_Vector2(s7_scheme *sc, s7_pointer args) { + BEGIN_ARGS(); + EXPECT_REAL_ARG(x); + EXPECT_REAL_ARG(y); + return make_variant_object(sc, Vector2(x, y)); +} + +s7_pointer g_make_Vector2i(s7_scheme *sc, s7_pointer args) { + BEGIN_ARGS(); + EXPECT_INT_ARG(x); + EXPECT_INT_ARG(y); + return make_variant_object(sc, Vector2i(x, y)); +} + +s7_pointer g_make_Rect2(s7_scheme *sc, s7_pointer args) { + BEGIN_ARGS(); + EXPECT_REAL_ARG(x); + EXPECT_REAL_ARG(y); + EXPECT_REAL_ARG(w); + EXPECT_REAL_ARG(h); + return make_variant_object(sc, Rect2(x, y, w, h)); +} + +s7_pointer g_make_Rect2i(s7_scheme *sc, s7_pointer args) { + BEGIN_ARGS(); + EXPECT_INT_ARG(x); + EXPECT_INT_ARG(y); + EXPECT_INT_ARG(w); + EXPECT_INT_ARG(h); + return make_variant_object(sc, Rect2i(x, y, w, h)); +} + +void print_internal(const Variant **args, GDExtensionInt arg_count) { + static GDExtensionPtrUtilityFunction _gde_function = + internal::gdextension_interface_variant_get_ptr_utility_function( + StringName("print")._native_ptr(), + 2648703342); + CHECK_METHOD_BIND(_gde_function); + Variant ret; + _gde_function(&ret, reinterpret_cast(args), arg_count); +} + +s7_pointer g_print(s7_scheme *sc, s7_pointer args) { + auto vars = collect_variants(sc, args); + auto pointers = collect_pointers(vars); + print_internal(pointers.data(), static_cast(pointers.size())); + return s7_unspecified(sc); +} + +s7_pointer variant_length(s7_scheme *sc, s7_pointer args) { + switch (const auto v = variant_value(s7_car(args)); v->get_type()) { + case Variant::STRING: + return s7_make_integer(sc, static_cast(*v).length()); + case Variant::ARRAY: + return s7_make_integer(sc, static_cast(*v).size()); + case Variant::PACKED_STRING_ARRAY: + return s7_make_integer(sc, static_cast(*v).size()); + case Variant::PACKED_INT32_ARRAY: + return s7_make_integer(sc, static_cast(*v).size()); + case Variant::PACKED_INT64_ARRAY: + return s7_make_integer(sc, static_cast(*v).size()); + case Variant::PACKED_FLOAT32_ARRAY: + return s7_make_integer(sc, static_cast(*v).size()); + case Variant::PACKED_FLOAT64_ARRAY: + return s7_make_integer(sc, static_cast(*v).size()); + case Variant::PACKED_BYTE_ARRAY: + return s7_make_integer(sc, static_cast(*v).size()); + case Variant::PACKED_VECTOR2_ARRAY: + return s7_make_integer(sc, static_cast(*v).size()); + case Variant::PACKED_VECTOR3_ARRAY: + return s7_make_integer(sc, static_cast(*v).size()); + case Variant::PACKED_COLOR_ARRAY: + return s7_make_integer(sc, static_cast(*v).size()); + default: + return s7_make_boolean(sc, false); + } +} + +/* + * TODO: + // typed arrays + PACKED_BYTE_ARRAY, + PACKED_INT32_ARRAY, + PACKED_INT64_ARRAY, + PACKED_FLOAT32_ARRAY, + PACKED_FLOAT64_ARRAY, + PACKED_STRING_ARRAY, + PACKED_VECTOR2_ARRAY, + PACKED_VECTOR3_ARRAY, + PACKED_COLOR_ARRAY, +*/ +s7_pointer g_make_Array(s7_scheme *sc, s7_pointer args) { + return make_variant_object(sc, collect_variants_into(Array(), sc, args)); +} + +void define_variant_ffi(s7 &scheme) { + auto sc = scheme.get(); + auto variant_ty = s7_make_c_type(sc, "Variant"); + DEV_ASSERT(variant_ty == VARIANT_TYPE_TAG); + + s7_c_type_set_gc_free(sc, variant_ty, variant_free); + s7_c_type_set_ref(sc, variant_ty, variant_ref); + s7_c_type_set_set(sc, variant_ty, variant_set); + s7_c_type_set_is_equal(sc, variant_ty, variant_is_equal); + s7_c_type_set_to_string(sc, variant_ty, variant_to_string); + s7_c_type_set_length(sc, variant_ty, variant_length); + + s7_define_function(sc, + "Variant", + g_make_variant, + 1, + 0, + false, + "(Variant obj) creates a new godot::Variant"); + s7_define_function(sc, + "Variant?", + g_is_variant, + 1, + 0, + false, + "(Variant? obj) returns the Variant type code if its argument is a godot::Variant " + "object, #f otherwise"); + s7_define_function(sc, + "VariantType->string", + g_variant_type_to_string, + 1, + 0, + false, + "(VariantType->string variant-type-code) returns the string representation of the " + "given Variant type code"); + + s7_define_function(sc, + "Variant->string", + g_variant_string, + 1, + 0, + false, + "(Variant->string variant) returns the enclosed string if the argument is a Variant " + "string"); + + s7_define_function(sc, + "Callable", + g_make_Callable, + 1, + 1, + false, + "(Callable symbol-or-procedure (discard-return-value #t)) creates a godot::Callable " + "which can be connected " + "to a signal, by default, the procedure return value is discarded to avoid " + "unnecessary processing."); + s7_define_function(sc, + "Color", + g_make_Color, + 1, + 0, + false, + "(Color ) creates a godot::Color from the html or named " + "color."); + s7_define_function(sc, + "Dictionary", + g_make_Dictionary, + 0, + 0, + false, + "(Dictionary) creates a godot::Dictionary."); + s7_define_function(sc, + "Array", + g_make_Array, + 0, + 0, + true, + "(Array . elements) creates a godot::Array initialized with elements."); + s7_define_function(sc, + "Vector2", + g_make_Vector2, + 2, + 0, + false, + "(Vector2 x y) creates a godot::Vector2 with the given coordinates"); + s7_define_function(sc, + "Vector2i", + g_make_Vector2i, + 2, + 0, + false, + "(Vector2i x y) creates a godot::Vector2i with the given coordinates"); + s7_define_function(sc, + "Rect2", + g_make_Rect2, + 4, + 0, + false, + "(Rect2 real-x real-y real-width real-height) creates a godot::Rect2 with the given coordinates, width and size"); + s7_define_function(sc, + "Rect2i", + g_make_Rect2i, + 4, + 0, + false, + "(Rect2i int-x int-y int-width int-height) creates a godot::Rect2i with the given coordinates, width and size"); + + s7_define_function(sc, + "!", + g_variant_call, + 2, + 0, + true, + "(! variant method-name &args) calls a method on a godot::Variant"); + + s7_define_function(sc, + "class-db", + g_class_db, + 0, + 0, + false, + "(class-db) returns the Godot class database"); + + s7_define_function(sc, + "print", + g_print, + 1, + 0, + true, + "(print format &args) prints to the Godot console"); +} +} //namespace godot \ No newline at end of file diff --git a/src/ffi.h b/src/ffi.h new file mode 100644 index 0000000..c6bb899 --- /dev/null +++ b/src/ffi.h @@ -0,0 +1,38 @@ +#ifndef GODOT_S7_SCHEME_FFI_H +#define GODOT_S7_SCHEME_FFI_H + +#include + +namespace godot { +void define_variant_ffi(s7 &s7); + +s7_pointer make_variant_object(s7_scheme *sc, const Variant &v); + +bool is_variant(s7_pointer arg); + +inline Variant *variant_value(s7_pointer variant) { + return (Variant *)s7_c_object_value(variant); +} + +s7_pointer variants_to_list(s7_scheme *sc, const Variant **args, int arg_count); + +s7_pointer variant_to_scheme(s7_scheme *sc, const Variant &v); + +Variant scheme_to_variant(s7_scheme *sc, s7_pointer arg); + +inline s7_pointer godot_string_to_scheme_string(s7_scheme *sc, const String &s) { + auto utf8 = s.utf8(); + return s7_make_string_with_length(sc, utf8, utf8.length()); +} + +inline auto scheme_string_to_godot_string(s7_pointer s) { + return String::utf8(s7_string(s), static_cast(s7_string_length(s))); +} + +inline auto scheme_object_to_godot_string(s7_scheme *sc, s7_pointer o) { + auto str = s7_object_to_string(sc, o, false); + return scheme_string_to_godot_string(str); +} +} //namespace godot + +#endif //GODOT_S7_SCHEME_FFI_H \ No newline at end of file diff --git a/src/ffi_macros.h b/src/ffi_macros.h new file mode 100644 index 0000000..7bf7c2d --- /dev/null +++ b/src/ffi_macros.h @@ -0,0 +1,12 @@ +#ifndef FFI_MACROS_H +#define FFI_MACROS_H + +#define BEGIN_ARGS() s7_pointer _arg; int _arg_i = 0; +#define EXPECT_ARG(named, value, check, desc) {_arg = s7_car(args); if (!check(_arg)) return s7_wrong_type_arg_error(sc, __func__, _arg_i, _arg, desc); args = s7_cdr(args); _arg_i++;}; const auto named = value +#define EXPECT_INT_ARG(n) EXPECT_ARG(n, s7_integer(_arg), s7_is_integer, "integer") +#define EXPECT_UINT32_ARG(n) EXPECT_ARG(n, s7_uint32(_arg), s7_is_integer, "uint32") +#define EXPECT_REAL_ARG(n) EXPECT_ARG(n, s7_real(_arg), s7_is_real, "real") +#define EXPECT_STRING_ARG(n) EXPECT_ARG(n, _arg, s7_is_string, "string") +#define EXPECT_SYMBOL_ARG(n) EXPECT_ARG(n, _arg, s7_is_symbol, "symbol") + +#endif //FFI_MACROS_H diff --git a/src/register_types.cpp b/src/register_types.cpp index e9ece5c..a1ae9a4 100644 --- a/src/register_types.cpp +++ b/src/register_types.cpp @@ -1,35 +1,48 @@ #include "register_types.h" +#include "scheme.h" +#include "scheme_object.h" +#include "scheme_script.h" +#include "scheme_script_loader.h" #include +#include #include #include #include using namespace godot; -void initialize_gdextension_types(ModuleInitializationLevel p_level) -{ +static Ref script_loader; + +void initialize_gdextension_types(ModuleInitializationLevel p_level) { if (p_level != MODULE_INITIALIZATION_LEVEL_SCENE) { return; } - //GDREGISTER_CLASS(YourClass); + GDREGISTER_CLASS(SchemeScript); + GDREGISTER_CLASS(SchemeScriptLoader); + GDREGISTER_CLASS(Scheme); + GDREGISTER_CLASS(SchemeObject); + + script_loader.instantiate(); + ResourceLoader::get_singleton()->add_resource_format_loader(script_loader); } void uninitialize_gdextension_types(ModuleInitializationLevel p_level) { if (p_level != MODULE_INITIALIZATION_LEVEL_SCENE) { return; } + + ResourceLoader::get_singleton()->remove_resource_format_loader(script_loader); + script_loader.unref(); } -extern "C" -{ - // Initialization - GDExtensionBool GDE_EXPORT godot_s7_scheme_library_init(GDExtensionInterfaceGetProcAddress p_get_proc_address, GDExtensionClassLibraryPtr p_library, GDExtensionInitialization *r_initialization) - { - GDExtensionBinding::InitObject init_obj(p_get_proc_address, p_library, r_initialization); - init_obj.register_initializer(initialize_gdextension_types); - init_obj.register_terminator(uninitialize_gdextension_types); - init_obj.set_minimum_library_initialization_level(MODULE_INITIALIZATION_LEVEL_SCENE); - - return init_obj.init(); - } +extern "C" { +// Initialization +GDExtensionBool GDE_EXPORT godot_s7_scheme_library_init(GDExtensionInterfaceGetProcAddress p_get_proc_address, GDExtensionClassLibraryPtr p_library, GDExtensionInitialization *r_initialization) { + GDExtensionBinding::InitObject init_obj(p_get_proc_address, p_library, r_initialization); + init_obj.register_initializer(initialize_gdextension_types); + init_obj.register_terminator(uninitialize_gdextension_types); + init_obj.set_minimum_library_initialization_level(MODULE_INITIALIZATION_LEVEL_SCENE); + + return init_obj.init(); +} } diff --git a/src/s7.cpp b/src/s7.cpp new file mode 100644 index 0000000..5f4429a --- /dev/null +++ b/src/s7.cpp @@ -0,0 +1,78 @@ + +#include "s7.hpp" +#include "debug_macros.h" +#include +#include +#include + +class godot::s7_scheme_context { +public: + void print_error(uint8_t char_code) { + if (char_code == '\n') { + if (!error_buffer.empty()) { + auto buffer = reinterpret_cast(error_buffer.data()); + UtilityFunctions::printerr( + String::utf8(buffer, static_cast(error_buffer.size()))); + error_buffer.clear(); + } + } else { + error_buffer.push_back(char_code); + } + } + +private: + std::vector error_buffer; +}; + +using namespace godot; + +void add_scheme_mapping(s7_scheme *sc, s7_scheme_context *scheme) { + s7_define_constant(sc, "*ctx*", s7_make_c_pointer(sc, scheme)); +} + +s7_scheme_context *context_of(s7_scheme *sc) { + return static_cast(s7_c_pointer(s7_name_to_value(sc, "*ctx*"))); +} + +void godot_print_error(s7_scheme *sc, uint8_t c, s7_pointer _port) { + context_of(sc)->print_error(c); +} + +void s7::set_current_error_port_function(s7_output_port_function_t f) const { + auto sc = scheme.get(); + auto port = s7_open_output_function(sc, f); + s7_set_current_error_port(sc, port); +} + +s7::s7() { + scheme = std::shared_ptr(s7_init(), s7_free); + scheme_context = std::make_shared(); + + set_current_error_port_function(godot_print_error); + + add_scheme_mapping(scheme.get(), scheme_context.get()); +} + +void s7::load_string(const String &str) const { + auto sc = get(); + auto code = str.utf8(); + auto res = s7_load_c_string(sc, code, code.length()); + WATCH(res); +} + +s7_pointer s7::eval(const String &code) const { + auto sc = get(); + auto str = code.utf8(); + return s7_eval_c_string(sc, str); +} + +s7_pointer s7::define(const char *name, s7_pointer value, const char *help) const { + auto sc = get(); + return s7_define_variable_with_documentation(sc, name, value, help); +} + +s7_pointer s7::define_constant_with_documentation( + const char *name, s7_pointer value, const char *help) const { + auto sc = get(); + return s7_define_constant_with_documentation(sc, name, value, help); +} \ No newline at end of file diff --git a/src/s7.hpp b/src/s7.hpp new file mode 100644 index 0000000..89ade14 --- /dev/null +++ b/src/s7.hpp @@ -0,0 +1,84 @@ +#ifndef GODOT_S7_SCHEME_S7_HPP +#define GODOT_S7_SCHEME_S7_HPP + +#include +#include +#include + +typedef void (*s7_output_port_function_t)(s7_scheme *sc, uint8_t c, s7_pointer port); + +namespace godot { +typedef std::shared_ptr s7_protected_ptr; + +inline s7_protected_ptr s7_gc_protected(s7_scheme *sc, s7_pointer p) { + auto l = s7_gc_protect(sc, p); + s7_protected_ptr ptr(p, [sc, l]([[maybe_unused]] auto p) { s7_gc_unprotect_at(sc, l); }); + return ptr; +} + +class s7_scheme_context; + +class s7 { +public: + s7(const s7 &other) = default; + s7(); + + [[nodiscard]] s7_scheme *get() const { return scheme.get(); }; + + s7_pointer define(const char *name, s7_pointer value, const char *documentation) const; + s7_pointer define_constant_with_documentation( + const char *name, + s7_pointer value, + const char *documentation) const; + [[nodiscard]] s7_pointer eval(const String &code) const; + void load_string(const String &code) const; + void set_current_error_port_function(s7_output_port_function_t f) const; + + s7_protected_ptr make_symbol(const char *name) const { + auto sc = get(); + return s7_gc_protected(sc, s7_make_symbol(sc, name)); + } + + template + s7_pointer call_optional(S what) const { + auto sc = get(); + auto proc = _scheme_resolve(sc, what); + return s7_is_procedure(proc) + ? s7_call_with_location(sc, proc, s7_nil(sc), __func__, __FILE__, __LINE__) + : s7_unspecified(sc); + } + + template + s7_pointer call(S what, T arg) const { + auto sc = get(); + auto proc = _scheme_resolve(sc, what); + return s7_call_with_location(sc, + proc, + s7_cons(sc, _scheme_value_of(sc, arg), s7_nil(sc)), + __func__, + __FILE__, + __LINE__); + } + +private: + static s7_pointer _scheme_value_of(s7_scheme *sc, double arg) { + return s7_make_real(sc, arg); + } + + static s7_pointer _scheme_value_of(s7_scheme *sc, int32_t arg) { + return s7_make_integer(sc, arg); + } + + static s7_pointer _scheme_resolve(s7_scheme *sc, s7_pointer symbol) { + return s7_symbol_value(sc, symbol); + } + + static s7_pointer _scheme_resolve(s7_scheme *sc, const char *name) { + return s7_name_to_value(sc, name); + } + + std::shared_ptr scheme; + std::shared_ptr scheme_context; +}; +} //namespace godot +#endif //GODOT_S7_SCHEME_S7_HPP \ No newline at end of file diff --git a/src/scheme.cpp b/src/scheme.cpp new file mode 100644 index 0000000..04ddbde --- /dev/null +++ b/src/scheme.cpp @@ -0,0 +1,125 @@ +#include "scheme.h" +#include "ffi.h" +#include "godot_cpp/variant/utility_functions.hpp" + +using namespace godot; + +Scheme::Scheme() { + define_variant_ffi(s7); + auto node = make_variant_object(s7.get(), this); + s7.define_constant_with_documentation("*node*", node, "this Godot node"); +} + +Scheme::~Scheme() { _process_symbol = nullptr; } + +void Scheme::define( + const godot::String &name, + const godot::Variant &value, + const String &help) const { + s7.define(name.utf8(), variant_to_scheme(s7.get(), value), help.utf8()); +} + +void Scheme::set_scheme_script(const Ref &p_scheme_script) { + scheme_script = p_scheme_script; + if (is_node_ready()) { + _ready(); + } +} + +void Scheme::_ready() { + for (int i = 0; i < prelude.size(); ++i) { + auto script = Object::cast_to(prelude[i]); + DEV_ASSERT(script != nullptr); + load(script); + } + + if (scheme_script.is_null()) { + _process_symbol = nullptr; + set_process(false); + return; + } + + load(scheme_script.ptr()); + + _process_symbol = s7.make_symbol("_process"); + set_process(true); +} + +void Scheme::load(const godot::SchemeScript *script) const { + load_string(script->get_code()); +} + +void Scheme::load_string(const String &code) const { + s7.load_string(code); +} + +void Scheme::_process(double delta) { + if (_process_symbol) { + s7.call(_process_symbol.get(), delta); + } +} + +void Scheme::_exit_tree() { + if (_process_symbol) { + auto res = s7.call_optional("_exit_tree"); + } + Node::_exit_tree(); +} + +Variant Scheme::eval(const String &code) { + return scheme_to_variant(s7.get(), s7.eval(code)); +} + +s7_pointer array_to_list(s7_scheme *sc, const Array &array) { + auto list = s7_nil(sc); + auto arg_count = static_cast(array.size()); + while (arg_count > 0) { + auto arg = variant_to_scheme(sc, array[--arg_count]); + list = s7_cons(sc, arg, list); + } + return list; +} + +Variant Scheme::apply(const String &symbol, const Array &args) const { + auto sc = s7.get(); + auto func = s7_name_to_value(sc, symbol.utf8().ptr()); + auto scheme_args = array_to_list(sc, args); + return scheme_to_variant(sc, + s7_call_with_location(sc, func, scheme_args, __func__, __FILE__, __LINE__)); +} + +void Scheme::_bind_methods() { + ClassDB::bind_method(D_METHOD("set_prelude", "p_prelude"), &Scheme::set_prelude); + ClassDB::bind_method(D_METHOD("get_prelude"), &Scheme::get_prelude); + ClassDB::add_property("Scheme", + PropertyInfo(Variant::ARRAY, + "prelude", + PROPERTY_HINT_TYPE_STRING, + vformat("%d/%d:SchemeScript", Variant::OBJECT, PROPERTY_HINT_RESOURCE_TYPE)), + "set_prelude", + "get_prelude"); + + ClassDB::bind_method( + D_METHOD("set_scheme_script", "p_scheme_script"), + &Scheme::set_scheme_script); + ClassDB::bind_method(D_METHOD("get_scheme_script"), &Scheme::get_scheme_script); + ClassDB::add_property("Scheme", + PropertyInfo( + Variant::OBJECT, + "scheme_script", + PROPERTY_HINT_RESOURCE_TYPE, + "SchemeScript"), + "set_scheme_script", + "get_scheme_script"); + + ClassDB::bind_method( + D_METHOD("define", "p_name", "p_value", "p_help"), + &Scheme::define, + DEFVAL("")); + ClassDB::bind_method(D_METHOD("eval", "p_code"), &Scheme::eval); + ClassDB::bind_method(D_METHOD("apply", "p_symbol", "p_args"), + &Scheme::apply, + DEFVAL(Array())); + ClassDB::bind_method(D_METHOD("load", "p_scheme_script"), &Scheme::load); + ClassDB::bind_method(D_METHOD("load_string", "p_code"), &Scheme::load_string); +} diff --git a/src/scheme.h b/src/scheme.h new file mode 100644 index 0000000..89f74d8 --- /dev/null +++ b/src/scheme.h @@ -0,0 +1,45 @@ +#ifndef GDS7_H +#define GDS7_H + +#include "s7.hpp" +#include "scheme_script.h" +#include +#include + +namespace godot { +class Scheme : public Node { + GDCLASS(Scheme, Node) + +public: + Scheme(); + ~Scheme() override; + + void _ready() override; + void _process(double delta) override; + void _exit_tree() override; + + void define(const String &name, const Variant &value, const String &help = "") const; + void load(const SchemeScript *script) const; + void load_string(const String& code) const; + Variant eval(const String &code); + Variant apply(const String &symbol, const Array &args) const; + void set_prelude(const TypedArray &p_prelude) { prelude = p_prelude; } + [[nodiscard]] TypedArray get_prelude() const { return prelude; } + void set_scheme_script(const Ref &p_scheme_script); + [[nodiscard]] Ref get_scheme_script() const { return scheme_script; }; + + [[nodiscard]] const s7 &get_s7() const { return s7; } + +protected: + static void _bind_methods(); + +private: + TypedArray prelude; + Ref scheme_script; + s7_protected_ptr _process_symbol; + s7 s7; +}; + +} // namespace godot + +#endif diff --git a/src/scheme_callable.cpp b/src/scheme_callable.cpp new file mode 100644 index 0000000..5793e49 --- /dev/null +++ b/src/scheme_callable.cpp @@ -0,0 +1,89 @@ +#include "scheme_callable.h" +#include "ffi.h" +#include +#include + +using namespace godot; + +SchemeCallable::SchemeCallable(s7_scheme *sc, s7_pointer f, bool discard_return_value) : + sc(sc), + f(s7_gc_protected(sc, f)), + discard_return_value(discard_return_value) { +} + +uint32_t SchemeCallable::hash() const { + return s7_hash_code(sc, f.get(), s7_unspecified(sc)); +} + +String SchemeCallable::get_as_text() const { + return scheme_object_to_godot_string(sc, f.get()); +} + +bool SchemeCallable::compare_equal_func(const CallableCustom *a, const CallableCustom *b) { + if (a == b) { + return true; + } + auto sc1 = dynamic_cast(a); + auto sc2 = dynamic_cast(b); + if (sc1 == sc2) { + return true; + } + if (sc1 == nullptr || sc2 == nullptr) { + return false; + } + auto sc = sc1->sc; + if (sc2->sc != sc) { + return false; + } + return s7_is_equal(sc, sc1->f.get(), sc2->f.get()); +} + +CallableCustom::CompareEqualFunc SchemeCallable::get_compare_equal_func() const { + return &SchemeCallable::compare_equal_func; +} + +bool SchemeCallable::compare_less_func(const CallableCustom *a, const CallableCustom *b) { + return (void *)a < (void *)b; +} + +CallableCustom::CompareLessFunc SchemeCallable::get_compare_less_func() const { + return &SchemeCallable::compare_less_func; +} + +bool SchemeCallable::is_valid() const { return true; } + +ObjectID SchemeCallable::get_object() const { + auto node = s7_name_to_value(sc, "*node*"); + if (is_variant(node)) { + return ObjectID(variant_value(node)->operator Object *()->get_instance_id()); + } + return {}; +} + +void SchemeCallable::call(const Variant **args, + int arg_count, + Variant &return_value, + GDExtensionCallError &return_call_error) const { + auto fp = f.get(); + auto proc = fp; + if (s7_is_symbol(fp)) { + proc = s7_symbol_value(sc, fp); + } + + if (!s7_is_procedure(proc)) { + return_call_error.error = GDEXTENSION_CALL_ERROR_INVALID_METHOD; + return; + } + + auto res = s7_call_with_location( + sc, + proc, + variants_to_list(sc, args, arg_count), + __func__, + __FILE__, + __LINE__); + if (!discard_return_value) { + return_value = scheme_to_variant(sc, res); + } + return_call_error.error = GDEXTENSION_CALL_OK; +} \ No newline at end of file diff --git a/src/scheme_callable.h b/src/scheme_callable.h new file mode 100644 index 0000000..0d33e42 --- /dev/null +++ b/src/scheme_callable.h @@ -0,0 +1,39 @@ +#ifndef SCHEME_CALLABLE_H +#define SCHEME_CALLABLE_H + +#include "s7.hpp" +#include + +namespace godot { +class SchemeCallable : public CallableCustom { +public: + SchemeCallable(s7_scheme *sc, s7_pointer f, bool discard_return_value); + + [[nodiscard]] uint32_t hash() const override; + + [[nodiscard]] String get_as_text() const override; + + static bool compare_equal_func(const CallableCustom *a, const CallableCustom *b); + + [[nodiscard]] CompareEqualFunc get_compare_equal_func() const override; + + static bool compare_less_func(const CallableCustom *a, const CallableCustom *b); + + [[nodiscard]] CompareLessFunc get_compare_less_func() const override; + + [[nodiscard]] bool is_valid() const override; + + [[nodiscard]] ObjectID get_object() const override; + + void call(const Variant **args, + int arg_count, + Variant &return_value, + GDExtensionCallError &return_call_error) const override; + +private: + s7_scheme *sc; + s7_protected_ptr f; + bool discard_return_value; +}; +} //namespace godot +#endif //SCHEME_CALLABLE_H diff --git a/src/scheme_object.cpp b/src/scheme_object.cpp new file mode 100644 index 0000000..8762a28 --- /dev/null +++ b/src/scheme_object.cpp @@ -0,0 +1,4 @@ +#include "scheme_object.h" + +void godot::SchemeObject::_bind_methods() { +} \ No newline at end of file diff --git a/src/scheme_object.h b/src/scheme_object.h new file mode 100644 index 0000000..a40a278 --- /dev/null +++ b/src/scheme_object.h @@ -0,0 +1,33 @@ + +#ifndef SCHEME_OBJECT_H +#define SCHEME_OBJECT_H + +#include "s7.hpp" + +#include + +namespace godot { +class SchemeObject : public RefCounted { + GDCLASS(SchemeObject, RefCounted) + +public: + SchemeObject() : sc(nullptr), scheme_ptr(nullptr) {} + SchemeObject(s7_scheme* sc, s7_pointer shared) : sc(sc), scheme_ptr(std::move(s7_gc_protected(sc, shared))){} + + bool belongs_to(const s7_scheme* scheme) const { + return sc == scheme; + } + + [[nodiscard]] s7_pointer get_scheme_ptr() const { + return scheme_ptr.get(); + } +protected: + static void _bind_methods(); + +private: + const s7_scheme* sc; + s7_protected_ptr scheme_ptr; +}; +} + +#endif //SCHEME_OBJECT_H diff --git a/src/scheme_script.cpp b/src/scheme_script.cpp new file mode 100644 index 0000000..9b96138 --- /dev/null +++ b/src/scheme_script.cpp @@ -0,0 +1,10 @@ +#include "scheme_script.h" +#include + +using namespace godot; + +void SchemeScript::_bind_methods() {} + +SchemeScript::SchemeScript() {} + +SchemeScript::~SchemeScript() {} diff --git a/src/scheme_script.h b/src/scheme_script.h new file mode 100644 index 0000000..cc689e8 --- /dev/null +++ b/src/scheme_script.h @@ -0,0 +1,26 @@ +#ifndef GODOT_S7_SCHEME_SCHEME_SCRIPT_H +#define GODOT_S7_SCHEME_SCHEME_SCRIPT_H + +#include + +namespace godot { +class SchemeScript : public Resource { + GDCLASS(SchemeScript, Resource) + +public: + SchemeScript(); + SchemeScript(const String &code) : code(code) {} + ~SchemeScript(); + + const String &get_code() const { return code; } + +protected: + static void _bind_methods(); + +private: + String code; +}; + +} // namespace godot + +#endif //GODOT_S7_SCHEME_SCHEME_SCRIPT_H diff --git a/src/scheme_script_loader.cpp b/src/scheme_script_loader.cpp new file mode 100644 index 0000000..e7d1784 --- /dev/null +++ b/src/scheme_script_loader.cpp @@ -0,0 +1,38 @@ +#include "scheme_script_loader.h" +#include "scheme_script.h" +#include +#include + +using namespace godot; + +void SchemeScriptLoader::_bind_methods() {} + +SchemeScriptLoader::SchemeScriptLoader() {} + +SchemeScriptLoader::~SchemeScriptLoader() {} + +PackedStringArray SchemeScriptLoader::_get_recognized_extensions() const { + auto extensions = PackedStringArray(); + extensions.append("scm"); + return extensions; +} + +bool SchemeScriptLoader::_handles_type(const StringName &type) const { + return type == String("SchemeScript"); +} + +Variant SchemeScriptLoader::_load( + const String &path, + const String &original_path, + bool use_sub_threads, + int32_t cache_mode) const { + auto code = FileAccess::get_file_as_string(path); + return memnew(SchemeScript(code)); +} + +String SchemeScriptLoader::_get_resource_type(const String &p_path) const { + if (p_path.get_extension().to_lower() == "scm") { + return "SchemeScript"; + } + return ""; +} \ No newline at end of file diff --git a/src/scheme_script_loader.h b/src/scheme_script_loader.h new file mode 100644 index 0000000..4319226 --- /dev/null +++ b/src/scheme_script_loader.h @@ -0,0 +1,37 @@ +#ifndef GODOT_S7_SCHEME_SCHEMESCRIPTLOADER_H +#define GODOT_S7_SCHEME_SCHEMESCRIPTLOADER_H + +#include + +namespace godot { +class SchemeScriptLoader : public ResourceFormatLoader { + GDCLASS(SchemeScriptLoader, ResourceFormatLoader) + +public: + SchemeScriptLoader(); + ~SchemeScriptLoader(); + + PackedStringArray _get_recognized_extensions() const override; + bool _handles_type(const StringName &type) const override; + Variant _load(const String &path, + const String &original_path, + bool use_sub_threads, + int32_t cache_mode) const override; + String _get_resource_type(const String &path) const override; + // bool _recognize_path(const String &path, const StringName &type) const override; + // String _get_resource_script_class(const String &path) const override; + // int64_t _get_resource_uid(const String &path) const override; + // PackedStringArray _get_dependencies(const String &path, bool add_types) const + // override; Error _rename_dependencies(const String &path, const Dictionary &renames) + // const override; bool _exists(const String &path) const override; PackedStringArray + // _get_classes_used(const String &path) const override; + +protected: + static void _bind_methods(); + +private: +}; + +} // namespace godot + +#endif //GODOT_S7_SCHEME_SCHEMESCRIPTLOADER_H diff --git a/test/golden/s7_scheme_tests.txt b/test/golden/s7_scheme_tests.txt new file mode 100644 index 0000000..c6ff6c4 --- /dev/null +++ b/test/golden/s7_scheme_tests.txt @@ -0,0 +1,98 @@ +Godot Engine v4.3.stable.official.77dcf97d8 - https://godotengine.org + +Hello from Scheme! +(format #t "Hello from Scheme! +")=>String(Hello from Scheme! +) +an-integer=>int(41) +(+ 1 an-integer)=>int(42) +a-float=>float(41) +(+ 1 a-float)=>float(42) +(if a-false #t #f)=>bool(false) +(if a-true #t #f)=>bool(true) +(if (not a-false) #f #t)=>bool(false) +(if (not a-true) #f #t)=>bool(true) +(connected? *node* 'child_entered_tree 'handler)=>bool(true) +v1:s1 +v2:s2 +(connected? *node* 'child_entered_tree 'handler)=>bool(false) +(connected? *node* 'child_entered_tree handler)=>bool(true) +v1:p1 +v1:p2 +(connected? *node* 'child_entered_tree original-handler)=>bool(false) +(equal? v1 v2)=>bool(false) +(equal? v1 v3)=>bool(true) +(equal? v4 v5)=>bool(false) +(equal? v4 v6)=>bool(true) +(or (Variant? i1) (Variant? f1) (Variant? b1) (Variant? b2))=>bool(false) +(VariantType->string (Variant? v1))=>String(Array) +(VariantType->string (Variant? v2))=>String(Dictionary) +(VariantType->string (Variant? v3))=>String(String) +(Array)=>Array([]) +(Array 1 2.0 "three" #t #f)=>Array([1, 2, "three", true, false]) +(! a1 'map (lambda (x) (* 2 x)))=>Array([2, 4, 6]) +(a1 `(map ,(lambda (x) (* 3 x))))=>Array([3, 6, 9]) +(define (f x) (* 4 x))=>Callable(f) +a1=>Array([1, 2, 3]) +(! a1 'map (Callable 'f))=>Array([, , ]) +(! a1 'map (Callable 'f #f))=>Array([4, 8, 12]) +(! a1 'map (Callable 'f #t))=>Array([, , ]) +(Vector2 1.0 2.0)=>Vector2((1, 2)) +(Vector2 1 2)=>Vector2((1, 2)) +(Vector2i 1 2)=>Vector2i((1, 2)) +(Rect2 1.0 2.0 3.0 4.0)=>Rect2([P: (1, 2), S: (3, 4)]) +(Rect2 1 2 3 4)=>Rect2([P: (1, 2), S: (3, 4)]) +(Rect2i 1 2 3 4)=>Rect2i([P: (1, 2), S: (3, 4)]) +Loading res://addons/s7/lib/import.scm... +Loading res://addons/s7/lib/array.scm... + + (begin + (require 'import) + (import-class Performance :as p) + (help 'p/get-monitor)) + =>String(float Performance.get_monitor(monitor: int)) +(let ((d (Dictionary))) (set! (d 0) (Color "red")) d)=>Dictionary({ 0: (1, 0, 0, 1) }) + + (define (test-for-each-on xs) + (call-with-output-string + (lambda (p) + (for-each + (lambda (x) (format p "(~A)" x)) + xs)))) + =>Callable(test-for-each-on) +(test-for-each-on array)=>String((1)(2)(3)) +(test-for-each-on dictionary)=>String() +(test-for-each-on string)=>String(()()()()()()) +#\c=>int(99) +(char? roundtrip)=>bool(false) +(integer? roundtrip)=>bool(true) +:a-keyword-symbol=>StringName(:a-keyword-symbol) +(symbol? roundtrip)=>bool(true) +(lambda (x) (* x 2))=>Callable(#) +(procedure? roundtrip)=>bool(true) +(roundtrip 21)=>int(42) +#t=>bool(true) +(boolean? roundtrip)=>bool(true) +42=>int(42) +(integer? roundtrip)=>bool(true) +42.0=>float(42) +(real? roundtrip)=>bool(true) +()=>Object([Wrapped:0]) +(list? roundtrip)=>bool(true) +'(1 . 2)=>Object([Wrapped:0]) +(pair? roundtrip)=>bool(true) +'(1 2 3)=>Object([Wrapped:0]) +(pair? roundtrip)=>bool(true) +#(1 2 3)=>Object([Wrapped:0]) +(vector? roundtrip)=>bool(true) +#=>Object([Wrapped:0]) +(undefined? roundtrip)=>bool(true) +(define* (scheme-function (a #f) (b #t) (c 42)) (object->string (list a b c)))=>Callable(scheme-function) +(apply scheme-function)=>String((#f #t 42)) +(apply scheme-function [1])=>String((1 #t 42)) +(apply scheme-function [1, 2])=>String((1 2 42)) +(apply scheme-function [1, 2, 3])=>String((1 2 3)) +(apply scheme-function [1, 2, 3, 4])=>StringName(wrong-number-of-args) +(apply scheme-function [1, &":b", 2])=>String((1 2 42)) +(apply scheme-function [1, &":b", 2, &":c", 33])=>String((1 2 33)) +(apply non-existing-function [])=>StringName(syntax-error) diff --git a/test/test-main.scm b/test/test-main.scm new file mode 100644 index 0000000..d47806c --- /dev/null +++ b/test/test-main.scm @@ -0,0 +1,100 @@ +(define-macro (assert-equals l r) + `(let ((l' ,l) + (r' ,r)) + (when (not (equal? l' r')) + (let ((lq (quote ,l)) + (rq (quote ,r))) + (error 'assertion-error "ERROR~%# (assert-equals ~a ~a)~%## ~a~%`~a`~%## ~a~%`~a`" lq rq lq l' rq r'))))) + +(define (godot scene) + (system (format #f "godot --path demo ~a --headless --quit" scene) #t)) + +(define (read-file path) + (call-with-input-file path + (lambda (p) (read-string 65535 p)))) + +(define* (golden-scene-test scene golden-file) + (let ((output-file "bin/s7_scheme_tests.txt")) + (call-with-output-file output-file + (lambda (p) (write-string (godot scene) p))) + (unless (= 0 (system (format #f "diff --color=auto -u ~a ~a" golden-file output-file))) + (error 'assertion-error scene)))) + +(define (golden-scene-tests) + (golden-scene-test + :scene "addons/s7/test/s7_scheme_tests.tscn" + :golden-file "test/golden/s7_scheme_tests.txt")) + +(define (eval-geiser-request r) + (eval-string (compile-geiser-request r) (rootlet))) + +(define (assert-geiser-request-string request expected) + (assert-equals + (eval-geiser-request request) + expected)) + +(define (assert-geiser-request request expected) + (assert-geiser-request-string request (object->string expected))) + +(define completion-candidate-1 #f) + +(define (completion-candidate-2) #f) + +(define autodoc-variable 42) + +(define (autodoc-function-0) + "the docstring") + +(define (autodoc-function-1 x) + "the docstring") + +(define (repl-unit-tests) + (load "demo/addons/s7/s7_scheme_repl.scm") + + ;; output is captured + (assert-geiser-request + ",geiser-eval #f (format #t \"~a~a\" 4 2) ()" + '((result "\"42\"") (output . "42"))) + + ;; define is evaluated at the top-level + (assert-geiser-request + ",geiser-eval #f (define *foo-bar* 13) ()" + '((result "13") (output . ""))) + + (assert-geiser-request + ",geiser-eval #f (begin (format #t \"=> ~a\" *foo-bar*) *foo-bar*) ()" + '((result "13") (output . "=> 13"))) + + ;; can evaluate expression directly at the repl + (assert-geiser-request-string + "(format #t \"~a~%\" 42)" + "42\n\n\"42\n\"") + + (assert-geiser-request-string + ",geiser-eval #f ge:completions (\"completion-candidate\") ()" + "((result \"(\\\"completion-candidate-1\\\" \\\"completion-candidate-2\\\")\") (output . \"\"))") + + ;; return the value when it's not a proc + (assert-geiser-request + ",geiser-eval #f ge:autodoc ('(autodoc-variable)) ()" + '((result "((autodoc-variable (\"args\") (\"value\" . \"42\")))") (output . ""))) + + (assert-geiser-request + ",geiser-eval #f ge:autodoc ('(autodoc-function-1)) ()" + '((result "((autodoc-function-1 (\"args\" ((\"required\" ...) (\"optional\") (\"key\")))))") (output . ""))) + +;; < : scheme@(guile-user)> ((result "((hello (\"args\" ((\"required\" x) (\"optional\") (\"key\"))) (\"module\" guile-user)) (hello (\"args\" ((\"required\" x) (\"optional\") (\"key\"))) (\"module\" guile-user)))") (output . "")) + +;; > : ,geiser-eval #f ge:symbol-documentation ((quote hello)) () +;; < : scheme@(guile-user)> ((result "((\"signature\" hello (\"args\" ((\"required\" x) (\"optional\") (\"key\")))) (\"docstring\" . \"A procedure in module (guile-user).\\n\\nmy hello\"))") (output . "")) + +;; > : ,geiser-eval #f ge:symbol-location ((quote hello)) () +;; < : scheme@(guile-user)> ((result "((\"file\") (\"line\" . 48))") (output . "")) + + (assert-geiser-request-string + "42" + "42")) + +(repl-unit-tests) +(golden-scene-tests) +(format #t "βœ“ ok~%")