├── README.md ├── examples ├── csv.scm ├── data.csv ├── flask.scm ├── matplotlib.scm ├── re.scm └── requests.scm ├── python#.scm ├── python-config.py ├── python._must-build_ ├── python.scm ├── python.sld └── test ├── leaks.scm └── test.scm /README.md: -------------------------------------------------------------------------------- 1 | # python 2 | **ATTENTION:** This is a work in progress. _Caveat emptor_! 3 | 4 | ``` scheme 5 | > \import calendar 6 | > (display (\calendar.month 2022 09)) 7 | September 2022 8 | Mo Tu We Th Fr Sa Su 9 | 1 2 3 4 10 | 5 6 7 8 9 10 11 11 | 12 13 14 15 16 17 18 12 | 19 20 21 22 23 24 25 13 | 26 27 28 29 30 14 | ``` 15 | 16 | This module is an interface to Python for Gambit Scheme. It wraps and exposes 17 | the low-level CPython C API using the Gambit Scheme C FFI managing the CPython 18 | GIL and reference counting. It implements a Foreign Procedure Call mechanism 19 | which bridges the Gambit and CPython threading models. It also offers a 20 | convenient syntactic interface to write Python expressions in Scheme. This 21 | module allows the use of packages from the Python Package Index's (PyPI) 22 | repository of almost 400,000 packages. 23 | 24 | For more details, see the preprint for our Scheme Workshop 2022 article here: [A 25 | Foreign Function Interface between Gambit Scheme and 26 | CPython](https://andykeep.com/SchemeWorkshop2022/scheme2022-final22.pdf). 27 | 28 | ## Getting started 29 | 30 | ### Requirements 31 | This module has a few mandatory requirements: 32 | 33 | - You must have a recent version of Gambit compiled with thread support 34 | either using the configure option `--enable-thread-system`, which is 35 | enabled by default in recent versions of Gambit, or with the configure 36 | option `--enable-multiple-threaded-vms`. 37 | - You must have a dynamically linked version of CPython >= 3.7 installed. This 38 | module will link against the CPython shared library. 39 | - A Windows, Linux or macOS operating system (other OSes have not been tested but 40 | might work). 41 | 42 | ### Installation 43 | You can install and compile the program at the command-line as such: 44 | 45 | ``` sh 46 | gsi -install github.com/gambit/python 47 | gsc github.com/gambit/python 48 | ``` 49 | 50 | or you can download and compile the module lazily by importing it from within 51 | `gsi` or any program compiled with the C backend: 52 | 53 | ``` scheme 54 | (import (github.com/gambit/python)) 55 | ``` 56 | 57 | In both cases, Gambit will download and compile the code. During compilation, 58 | the module will perform an automatic discovery of the installed CPython 59 | executable. Various C compiler options will be determined by introspection. This 60 | module will create a `virtualenv` to manage its packages. 61 | 62 | Users can configure the compilation with environment variables: 63 | 64 | - `GAMBIT_PYTHON_EXECUTABLE` is the path to the CPython executable (supersedes `GAMBIT_PYTHON_VERSION`) 65 | - `GAMBIT_PYTHON_VERSION` is the CPython version to use (e.g. `3.7`) 66 | - `GAMBIT_PYTHON_VENV` is the directory where to put the `virtualenv` 67 | - `GAMBIT_PYTHON_DEBUG` is a flag to show debug information (`yes`) 68 | 69 | A default installation _should_ work out of the box. By default, the Python 70 | `virtualenv` will be placed under `~~userlib/.venv${GAMBIT_PYTHON_VERSION}`. 71 | 72 | ## Usage 73 | 74 | This module dynamically links to the CPython shared library. On some systems and 75 | configurations, you _must_ preload the shared library. For example, on a Linux 76 | system you most probably need to invoke the `gsi` binary as such: 77 | 78 | ``` sh 79 | LD_PRELOAD=/path/to/Python-3.10.5/lib/libpython3.10.so gsi 80 | ``` 81 | 82 | To use the syntactic interface, you must import the `(_six python)` module. To 83 | use the low-level interface and instantiate the CPython VM, you must import the 84 | `github.com/gambit/python` module. Combined, these are: 85 | 86 | ``` scheme 87 | (import (_six python) 88 | (github.com/gambit/python)) 89 | ``` 90 | 91 | ### Installing packages 92 | 93 | To install packages from PyPI, simply run `(pip-install "package-name")`. 94 | Advanced users can always load the virtual environment as they would any other, 95 | or use other packaging mechanisms if they wish. 96 | 97 | ## Examples 98 | 99 | The [examples](examples/) can be run as follows: 100 | 101 | ``` sh 102 | gsi github.com/gambit/python/examples/EXAMPLE_NAME_WITHOUT_SCM 103 | ``` 104 | 105 | So to run the `requests` example, you would do: 106 | 107 | ``` sh 108 | gsi github.com/gambit/python/examples/requests 109 | ``` 110 | 111 | Some examples require packages to be installed from the PyPI. These have to be 112 | manually installed using `pip-install`. 113 | 114 | ## Testing 115 | 116 | To test the module, run the following command: 117 | 118 | ``` sh 119 | gsi github.com/gambit/python/test 120 | ``` 121 | 122 | There is a specific test for memory leaks that you can run as: 123 | 124 | ``` sh 125 | gsi github.com/gambit/python/test/leaks 126 | ``` 127 | 128 | 129 | ## License and copyright 130 | 131 | This software is distributed under the same terms as 132 | [Gambit](https://github.com/gambit/gambit). 133 | 134 | © Marc Feeley 2021-2022 135 | 136 | © Marc-André Bélanger 2021-2022 137 | -------------------------------------------------------------------------------- /examples/csv.scm: -------------------------------------------------------------------------------- 1 | (import (_six python) 2 | (github.com/gambit/python)) 3 | 4 | \import csv 5 | 6 | (define (read-csv path) 7 | \f=open(`path) 8 | \reader=csv.reader(f) 9 | (let loop ((acc '())) 10 | (with-exception-catcher 11 | (lambda (e) 12 | ;; The exception will be a pair (PyObject* . repr(PyObject*)) 13 | \f.close() 14 | (if \isinstance(`(car e), StopIteration) 15 | (reverse acc) ;; Return the result 16 | (write e))) ;; Propagate the exception 17 | ;; Iterate using __next__() until StopIteration is raised 18 | (lambda () (loop (cons \reader.__next__() acc)))))) 19 | 20 | (pretty-print (read-csv (path-expand "~~userlib/github.com/gambit/python/@/examples/data.csv"))) 21 | 22 | ;; (("A" "B" "C") ("1" "2" "3")) 23 | -------------------------------------------------------------------------------- /examples/data.csv: -------------------------------------------------------------------------------- 1 | A,B,C 2 | 1,2,3 3 | -------------------------------------------------------------------------------- /examples/flask.scm: -------------------------------------------------------------------------------- 1 | (import (_six python) 2 | (github.com/gambit/python)) 3 | 4 | \from flask import Flask 5 | 6 | \app=Flask(__name__) 7 | 8 | (define (home) 9 | (string-append "This is Gambit " 10 | (system-version-string))) 11 | 12 | \app.route("/")(`home) 13 | 14 | (define flask-thread 15 | (thread 16 | (lambda () 17 | (\app.run host: "127.0.0.1" 18 | port: 5000 19 | threaded: #f)))) 20 | 21 | (thread-sleep! 1) ;; wait for Flask server to start 22 | 23 | ;; Connect to the Flask server 24 | 25 | (let ((conn (open-tcp-client "127.0.0.1:5000"))) 26 | (print port: conn "GET / HTTP/1.1\r\n\r\n") 27 | (force-output conn) 28 | (pp (read-line conn #f)) 29 | (close-port conn)) 30 | 31 | ;; output: 32 | ;; 33 | ;; * Serving Flask app '__main__' 34 | ;; * Debug mode: off 35 | ;; WARNING: This is a development server. Do not use it in a production deployment. Use a production WSGI server instead. 36 | ;; * Running on http://127.0.0.1:5000 37 | ;; Press CTRL+C to quit 38 | ;; 127.0.0.1 - - [04/Sep/2022 16:04:57] "GET / HTTP/1.1" 200 - 39 | ;; "HTTP/1.1 200 OK\r\nServer: Werkzeug/2.2.2 Python/3.9.13\r\nDate: Sun, 04 Sep 2022 20:04:57 GMT\r\nContent-Type: text/html; charset=utf-8\r\nContent-Length: 34\r\nConnection: close\r\n\r\nThis is Gambit v4.9.4-64-g9c22ed86" 40 | -------------------------------------------------------------------------------- /examples/matplotlib.scm: -------------------------------------------------------------------------------- 1 | (import (_six python) 2 | (github.com/gambit/python)) 3 | 4 | \import matplotlib.pyplot as plt 5 | \import numpy as np 6 | 7 | (define N 5) 8 | (define men-means (vector 20 35 30 35 -27)) 9 | (define women-means (vector 25 32 34 20 -25)) 10 | (define men-std (vector 2 3 4 1 2)) 11 | (define women-std (vector 3 5 2 3 3)) 12 | (define ind \np.arange(`N)) 13 | (define width 0.35) 14 | 15 | (python-exec "fig, ax = plt.subplots()") 16 | 17 | \p1=ax.bar(`ind, `men-means, `width, yerr=`men-std, label='Men') 18 | \p2=ax.bar(`ind, `women-means, `width, bottom=`men-means, 19 | yerr=`women-std, label='Women') 20 | 21 | \ax.axhline(0, color='grey', linewidth=0.8) 22 | \ax.set_ylabel('Scores') 23 | \ax.set_title('Scores by group and gender') 24 | \ax.set_xticks(`ind, labels=['G1', 'G2', 'G3', 'G4', 'G5']) 25 | \ax.legend() 26 | 27 | \ax.bar_label(p1, label_type='center') 28 | \ax.bar_label(p2, label_type='center') 29 | \ax.bar_label(p2) 30 | 31 | \plt.show() 32 | -------------------------------------------------------------------------------- /examples/re.scm: -------------------------------------------------------------------------------- 1 | (import (_six python) 2 | (github.com/gambit/python)) 3 | 4 | \import re 5 | 6 | (define (re-search pattern string) 7 | \re.search(`pattern, `string)) 8 | 9 | (define (re-group match i) 10 | \(`match).group(`i)) 11 | 12 | (define m (re-search "s....e" "(sch3me)")) 13 | 14 | (pp (re-group m 0)) ;; prints "sch3me" 15 | -------------------------------------------------------------------------------- /examples/requests.scm: -------------------------------------------------------------------------------- 1 | (import (_six python) 2 | (github.com/gambit/python)) 3 | 4 | \import requests 5 | 6 | (define (get-json url) \requests.get(`url).json()) 7 | 8 | (pp (table->list (get-json "https://jsonplaceholder.typicode.com/todos/1"))) 9 | 10 | ;; output: 11 | ;; 12 | ;; (("userId" . 1) ("title" . "delectus aut autem") ("completed" . #f) ("id" . 1)) 13 | -------------------------------------------------------------------------------- /python#.scm: -------------------------------------------------------------------------------- 1 | ;;;============================================================================ 2 | 3 | ;;; File: "python#.scm" 4 | 5 | ;;; Copyright (c) 2020-2025 by Marc Feeley, All Rights Reserved. 6 | ;;; Copyright (c) 2020-2022 by Marc-André Bélanger, All Rights Reserved. 7 | 8 | ;;;============================================================================ 9 | 10 | (##namespace ("github.com/gambit/python#" 11 | 12 | ;; Constants 13 | Py_eval_input 14 | Py_file_input 15 | Py_single_input 16 | 17 | ;; Initialization, Finalization, and Threads 18 | Py_Initialize 19 | Py_Finalize 20 | 21 | ;; These are no longer available: 22 | ;; Py_SetPath 23 | ;; Py_SetProgramName 24 | ;; Py_SetPythonHome 25 | ;; PySys_SetArgv 26 | ;; PySys_SetArgvEx 27 | 28 | ;; PyRun_* 29 | PyRun_SimpleString 30 | PyRun_String 31 | 32 | ;; PyImport_* 33 | PyImport_AddModuleObject 34 | PyImport_AddModule 35 | PyImport_ImportModule 36 | PyImport_ImportModuleEx 37 | 38 | ;; PyModule_* 39 | PyModule_GetDict 40 | 41 | ;; PyDict_* 42 | PyDict_New 43 | PyDict_Size 44 | PyDict_Items 45 | PyDict_Keys 46 | PyDict_Values 47 | PyDict_GetItem 48 | PyDict_SetItem 49 | PyDict_GetItemString 50 | PyDict_SetItemString 51 | 52 | ;; PyList_* 53 | PyList_New 54 | 55 | ;; PyTuple_* 56 | PyTuple_GetItem 57 | 58 | ;; PyBool_* 59 | PyBool_FromLong 60 | 61 | ;; PyLong_* 62 | PyLong_FromUnicodeObject 63 | 64 | ;; PyUnicode_* 65 | PyUnicode_FromString 66 | 67 | ;; PyObject_* 68 | PyObject_CallMethod 69 | PyObject_GetAttrString 70 | PyObject_Length 71 | PyObject_Repr 72 | PyObject*-type 73 | PyObject*-type-name 74 | 75 | ;; Call Python callables 76 | PyObject_CallObject 77 | PyObject_CallFunctionObjArgs 78 | PyObject_CallFunctionObjArgs* 79 | PyObject_CallFunctionObjArgs0 80 | PyObject_CallFunctionObjArgs1 81 | PyObject_CallFunctionObjArgs2 82 | PyObject_CallFunctionObjArgs3 83 | PyObject_CallFunctionObjArgs4 84 | 85 | ;; Converters 86 | PyObject*/None->void 87 | void->PyObject*/None 88 | PyObject*/bool->boolean 89 | boolean->PyObject*/bool 90 | PyObject*/int->exact-integer 91 | exact-integer->PyObject*/int 92 | PyObject*/float->flonum 93 | flonum->PyObject*/float 94 | PyObject*/complex->cpxnum 95 | flonums->PyObject*/complex 96 | PyObject*/Fraction->ratnum 97 | ints->PyObject*/Fraction 98 | PyObject*/str->string 99 | string->PyObject*/str 100 | PyObject*/bytes->u8vector 101 | u8vector->PyObject*/bytes 102 | s8vector->PyObject*/bytes 103 | PyObject*/bytearray->u8vector 104 | u8vector->PyObject*/bytearray 105 | PyObject*/list->vector 106 | vector->PyObject*/list 107 | PyObject*/list->list 108 | list->PyObject*/list 109 | PyObject*/tuple->vector 110 | vector->PyObject*/tuple 111 | PyObject*/tuple->list 112 | list->PyObject*/tuple 113 | PyObject*->object 114 | object->PyObject* 115 | procedure->PyObject*/function 116 | SchemeObject->object 117 | object->SchemeObject 118 | 119 | ;; Misc 120 | pip-install 121 | pip-uninstall 122 | python-eval 123 | python-exec 124 | cleanup-fpc 125 | 126 | scheme 127 | 128 | )) 129 | 130 | ;;;============================================================================ 131 | -------------------------------------------------------------------------------- /python-config.py: -------------------------------------------------------------------------------- 1 | # python-config.py 2 | # 3 | # This script tries to find the correct ldflags and cflags through python3 4 | # introspection. See CPython's Misc/python-config.in and configure.ac for 5 | # details. 6 | 7 | 8 | import sys 9 | import sysconfig 10 | import platform 11 | import pathlib 12 | 13 | 14 | class MSVC: 15 | def __init__(self): 16 | self.name = "cl" 17 | self.cflags = [] 18 | self.ldflags = ["-link"] 19 | 20 | def add_library_path(self, path): 21 | self.ldflags.append('-LIBPATH:"' + path + '"') 22 | 23 | def add_library(self, lib): 24 | self.ldflags.append(lib + ".lib") 25 | 26 | def add_libraries(self, libs): 27 | for lib in libs: 28 | self.add_library(lib) 29 | 30 | def add_include_path(self, path): 31 | self.cflags.append('-I"' + path + '"') 32 | 33 | 34 | class GnuLikeCompiler: 35 | def __init__(self, name): 36 | self.name = name 37 | self.cflags = [] 38 | self.ldflags = [] 39 | 40 | def add_library_path(self, path): 41 | self.ldflags.append('-L"' + path + '"') 42 | 43 | def add_library(self, lib): 44 | self.ldflags.append('-l' + lib) 45 | 46 | def add_libraries(self, libs): 47 | for lib in libs: 48 | self.add_library(lib) 49 | 50 | def add_include_path(self, path): 51 | self.cflags.append('-I"' + path + '"') 52 | 53 | 54 | getvar = sysconfig.get_config_var 55 | 56 | 57 | def extend_with_config_var(array, name): 58 | var = getvar(name) 59 | if var is not None: 60 | array.extend(var.split()) 61 | 62 | 63 | def find_compiler(): 64 | try: 65 | CC = getvar("CC").lower() 66 | if "clang" in CC: 67 | compiler = GnuLikeCompiler("clang") 68 | elif "gcc" in CC: 69 | compiler = GnuLikeCompiler("gcc") 70 | else: 71 | raise RuntimeError("Unknown compiler") 72 | except Exception: 73 | pycompiler = platform.python_compiler().lower() 74 | if "msc" in pycompiler: 75 | compiler = MSVC() 76 | elif "clang" in pycompiler: 77 | compiler = GnuLikeCompiler("clang") 78 | elif "gcc" in pycompiler: 79 | compiler = GnuLikeCompiler("gcc") 80 | else: 81 | raise RuntimeError("Unknown compiler") 82 | 83 | return compiler 84 | 85 | 86 | # Detect the platform/system 87 | 88 | system = platform.system().lower() 89 | if system not in ["linux", "darwin", "windows"]: 90 | raise RuntimeError("Unsupported system") 91 | 92 | 93 | # Detect the compiler 94 | 95 | compiler = find_compiler() 96 | 97 | 98 | # Get common Python configuration variables 99 | 100 | VERSION = getvar("VERSION") 101 | LIBDIR = getvar("LIBDIR") 102 | CONFINCLUDEDIR = getvar("CONFINCLUDEDIR") 103 | try: 104 | abiflags = sys.abiflags 105 | except Exception: 106 | abiflags = getvar("abiflags") or "" 107 | 108 | 109 | # Configure system specific variables 110 | 111 | if system == "windows" and LIBDIR is None: 112 | # Assume libpath is %PYTHONPREFIX%\\libs on Windows 113 | prefix = pathlib.Path(sysconfig.get_config_var("prefix")) 114 | libs = prefix / "libs" 115 | if not libs.exists(): 116 | raise RuntimeError("Unable to find python C libraries") 117 | LIBDIR = str(libs) 118 | 119 | elif system == "darwin": 120 | # Set @rpath when using clang 121 | PYTHONFRAMEWORKPREFIX = getvar("PYTHONFRAMEWORKPREFIX") 122 | if PYTHONFRAMEWORKPREFIX != "": 123 | compiler.cflags.append("-Wl,-rpath -Wl," + PYTHONFRAMEWORKPREFIX) 124 | 125 | 126 | # Configure ldflags 127 | 128 | compiler.add_library_path(LIBDIR) 129 | compiler.add_library("python" + VERSION + abiflags) 130 | extend_with_config_var(compiler.ldflags, "LIBS") 131 | extend_with_config_var(compiler.ldflags, "SYSLIBS") 132 | 133 | if not getvar("Py_ENABLE_SHARED"): 134 | LIBPL = getvar("LIBPL") 135 | if LIBPL is not None: 136 | compiler.add_library_path(LIBPL) 137 | 138 | if not getvar("PYTHONFRAMEWORK"): 139 | extend_with_config_var(compiler.ldflags, "LINKFORSHARED") 140 | 141 | 142 | # Configure cflags 143 | 144 | compiler.add_include_path(sysconfig.get_path("include")) 145 | compiler.add_include_path(sysconfig.get_path("platinclude")) 146 | if CONFINCLUDEDIR is not None: # Can be None on Windows 147 | compiler.add_include_path(CONFINCLUDEDIR + "/python" + VERSION + abiflags) 148 | extend_with_config_var(compiler.cflags, "CFLAGS") 149 | 150 | 151 | # The output is parsed by gsc, one line at a time: 152 | 153 | print(VERSION) 154 | print(compiler.name) 155 | print(" ".join(compiler.ldflags)) 156 | print(" ".join(compiler.cflags)) 157 | print(LIBDIR) 158 | -------------------------------------------------------------------------------- /python._must-build_: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gambit/python/942500296a9c21d5a0fe8e53fd3b60ca8b00ecb0/python._must-build_ -------------------------------------------------------------------------------- /python.scm: -------------------------------------------------------------------------------- 1 | ;;;============================================================================ 2 | 3 | ;;; File: "python.scm" 4 | 5 | ;;; Copyright (c) 2020-2025 by Marc Feeley, All Rights Reserved. 6 | ;;; Copyright (c) 2020-2022 by Marc-André Bélanger, All Rights Reserved. 7 | 8 | ;;;============================================================================ 9 | 10 | ;;; Python FFI. 11 | 12 | (##supply-module github.com/gambit/python) 13 | 14 | (##namespace ("github.com/gambit/python#")) ;; in github.com/gambit/python# 15 | 16 | (##include "~~lib/gambit/prim/prim#.scm") ;; map fx+ to ##fx+, etc 17 | (##include "~~lib/_gambit#.scm") ;; for macro-check-procedure, 18 | ;; macro-absent-obj, etc 19 | 20 | (##include "python#.scm") ;; correctly map exported names 21 | 22 | (declare (standard-bindings)) ;; ##fx+ is bound to fixnum addition, etc 23 | (declare (not safe)) ;; claim code has no type errors 24 | (declare (block)) ;; claim no global is assigned 25 | 26 | (##namespace ("" 27 | current-thread make-thread thread-start! thread-sleep! 28 | make-mutex mutex-lock! mutex-unlock!)) 29 | 30 | ;;;---------------------------------------------------------------------------- 31 | 32 | ;; When this module is built a suitable python executable must be 33 | ;; located. A venv must then be created to host the python modules 34 | ;; that will be installed (to avoid clobbering an existing python 35 | ;; installation). 36 | 37 | ;; These build-time operations are encapsulated in the following macro 38 | ;; which allows executing Scheme code when the module is compiled. 39 | ;; The macro generates various definitions giving the details of the 40 | ;; python venv, and it generates ##meta-info forms that give C 41 | ;; compiler and linker flags required to properly link to the python 42 | ;; shared library. 43 | 44 | (define-syntax find-python-and-create-venv-and-generate-meta-info 45 | (lambda (src) 46 | 47 | (define GAMBIT_PYTHON_EXECUTABLE (getenv "GAMBIT_PYTHON_EXECUTABLE" #f)) 48 | (define GAMBIT_PYTHON_VERSION (getenv "GAMBIT_PYTHON_VERSION" #f)) 49 | (define GAMBIT_PYTHON_VENV (getenv "GAMBIT_PYTHON_VENV" #f)) 50 | (define GAMBIT_PYTHON_DEBUG (getenv "GAMBIT_PYTHON_DEBUG" #f)) 51 | 52 | (define python-min-supported-version "3.7") 53 | 54 | (define python-executables 55 | '("python3.10" 56 | "python3.9" 57 | "python3.8" 58 | "python3.7" 59 | "python3" 60 | "python")) 61 | 62 | (define (this-source-file-dir) 63 | (path-directory (##source-path src))) 64 | 65 | (define python-config-script 66 | (path-expand "python-config.py" (this-source-file-dir))) 67 | 68 | (define (get-python-config python-executable) 69 | (if (not (file-exists? python-config-script)) 70 | (error "The following required script is missing:" 71 | python-config-script) 72 | (let* ((res 73 | (shell-command 74 | (string-append python-executable " " python-config-script) 75 | #t)) 76 | (exit-code 77 | (car res)) 78 | (output 79 | (cdr res))) 80 | (if (= exit-code 0) 81 | (with-input-from-string 82 | output 83 | (lambda () 84 | (let* ((version 85 | (string-strip-trailing-return! (read-line))) 86 | (c-compiler 87 | (string-strip-trailing-return! (read-line))) 88 | (ldflags 89 | (string-strip-trailing-return! (read-line))) 90 | (cflags 91 | (string-strip-trailing-return! (read-line))) 92 | (libdir 93 | (string-strip-trailing-return! (read-line)))) 94 | (list version 95 | (cons 'executable python-executable) 96 | (cons 'version version) 97 | (cons 'c-compiler c-compiler) 98 | (cons 'ldflags ldflags) 99 | (cons 'cflags cflags) 100 | (cons 'libdir libdir))))) 101 | #f)))) 102 | 103 | (define (string-strip-trailing-return! str) 104 | (if (string? str) 105 | (let ((newlen (- (string-length str) 1))) 106 | (if (char=? #\return (string-ref str newlen)) 107 | (string-shrink! str newlen)))) 108 | str) 109 | 110 | (define (string-split-at str sep) 111 | (call-with-input-string 112 | str 113 | (lambda (port) 114 | (read-all port (lambda (port) (read-line port sep)))))) 115 | 116 | (define (split-version str) 117 | (let ((v (map string->number (string-split-at str #\.)))) 118 | (if (memv #f v) 119 | #f 120 | v))) 121 | 122 | (define (compare-versions version1 version2) 123 | (let ((v1 (split-version version1)) 124 | (v2 (split-version version2))) 125 | (let loop ((v1 v1) (v2 v2)) 126 | (cond ((null? v1) 127 | (if (null? v2) 128 | 0 129 | -1)) 130 | ((null? v2) 131 | 1) 132 | ((< (car v1) (car v2)) 133 | -1) 134 | ((> (car v1) (car v2)) 135 | 1) 136 | (else 137 | (loop (cdr v1) (cdr v2))))))) 138 | 139 | (define python-configs-found '()) 140 | 141 | (define (find-suitable-python-config) 142 | 143 | (if GAMBIT_PYTHON_EXECUTABLE 144 | (set! python-executables 145 | (list GAMBIT_PYTHON_EXECUTABLE)) 146 | (if GAMBIT_PYTHON_VERSION 147 | (let ((executable 148 | (string-append "python" GAMBIT_PYTHON_VERSION))) 149 | (if (not (member executable python-executables)) 150 | (set! python-executables 151 | (cons executable python-executables)))))) 152 | 153 | (for-each (lambda (python-executable) 154 | (let ((config (get-python-config python-executable))) 155 | (if config 156 | (set! python-configs-found 157 | (cons config python-configs-found))))) 158 | python-executables) 159 | 160 | (set! python-configs-found (reverse python-configs-found)) 161 | 162 | (cond ((null? python-configs-found) 163 | 164 | (error "None of these python executables were found:" 165 | python-executables)) 166 | 167 | (GAMBIT_PYTHON_VERSION 168 | 169 | ;; check if requested version exists (note that it could 170 | ;; be lower than python-min-supported-version to allow 171 | ;; bypassing the check by experts) 172 | 173 | (let ((x (assoc GAMBIT_PYTHON_VERSION python-configs-found))) 174 | (if x 175 | (cdr x) 176 | (error (string-append "A python executable for version " 177 | GAMBIT_PYTHON_VERSION 178 | " was not found"))))) 179 | 180 | (else 181 | 182 | ;; find highest version and make sure it is at least 183 | ;; python-min-supported-version 184 | 185 | (let* ((sorted-python-configs-found 186 | (list-sort 187 | (lambda (config1 config2) 188 | (let ((version1 (car config1)) 189 | (version2 (car config2))) 190 | (> (compare-versions version1 version2) 0))) 191 | python-configs-found)) 192 | (config 193 | (car sorted-python-configs-found)) 194 | (version 195 | (car config))) 196 | (if (< (compare-versions version python-min-supported-version) 0) 197 | (error (string-append 198 | "The minimal python version allowed is " 199 | python-min-supported-version 200 | " and the version that was found is " 201 | version 202 | ". Set the GAMBIT_PYTHON_EXECUTABLE env var to the path of a compatible version or upgrade your python installation.")) 203 | (cdr config)))))) 204 | 205 | (let* ((config (find-suitable-python-config)) 206 | (version (cdr (assoc 'version config))) 207 | (executable (cdr (assoc 'executable config))) 208 | (venv-dir 209 | (or GAMBIT_PYTHON_VENV 210 | (path-expand (string-append ".venv" version) 211 | (path-expand "~~userlib")))) 212 | (venv-executable 213 | (path-expand "python" (path-expand "bin" venv-dir)))) 214 | 215 | (if (not (file-exists? venv-dir)) 216 | (let* ((res 217 | (shell-command 218 | (string-append executable " -m venv " venv-dir) 219 | #t)) 220 | (exit-code 221 | (car res)) 222 | (output 223 | (cdr res))) 224 | (if (not (= exit-code 0)) 225 | (begin 226 | (display output) 227 | (error "The python venv could not be created in:" 228 | venv-dir))))) 229 | 230 | (let ((config (get-python-config venv-executable))) 231 | (if (not config) 232 | (error "Could not get the python configuration of:" 233 | venv-executable) 234 | (let* ((config (cdr config)) 235 | (version (cdr (assoc 'version config))) 236 | (executable (cdr (assoc 'executable config))) 237 | (c-compiler (cdr (assoc 'c-compiler config))) 238 | (cflags (cdr (assoc 'cflags config))) 239 | (ldflags (cdr (assoc 'ldflags config))) 240 | (libdir (cdr (assoc 'libdir config))) 241 | (venv-bin-dir (path-expand "bin" venv-dir)) 242 | (venv-lib-dir (path-expand (string-append "python" version) 243 | (path-expand "lib" venv-dir)))) 244 | (let ((definitions 245 | `(begin 246 | (define python-version ,version) 247 | (define python-executable ,executable) 248 | (define python-c-compiler ,c-compiler) 249 | (define python-libdir ,libdir) 250 | (define python-venv-dir ,venv-dir) 251 | (define python-venv-bin-dir ,venv-bin-dir) 252 | (define python-venv-lib-dir ,venv-lib-dir) 253 | (##meta-info ld-options ,ldflags) 254 | (##meta-info cc-options ,cflags)))) 255 | (if GAMBIT_PYTHON_DEBUG 256 | (pp definitions)) 257 | definitions))))))) 258 | 259 | (find-python-and-create-venv-and-generate-meta-info) 260 | 261 | ;;;---------------------------------------------------------------------------- 262 | 263 | (c-declare #< 291 | 292 | typedef PyObject *PyObjectPtr; 293 | 294 | PyTypeObject *Fraction_cls = NULL; 295 | PyTypeObject *_SchemeObject_cls = NULL; 296 | 297 | #define DEBUG_LOWLEVEL_not 298 | #define DEBUG_PYTHON_REFCNT_not 299 | 300 | #ifdef DEBUG_PYTHON_REFCNT 301 | 302 | // Taken from https://stackoverflow.com/a/46202119 303 | static void debug_print_repr(PyObject *obj) { 304 | 305 | PyObject* repr = PyObject_Repr(obj); 306 | PyObject* str = PyUnicode_AsEncodedString(repr, "utf-8", "~E~"); 307 | const char *bytes = PyBytes_AS_STRING(str); 308 | 309 | printf("REPR: %s\n", bytes); 310 | fflush(stdout); 311 | 312 | Py_XDECREF(repr); 313 | Py_XDECREF(str); 314 | } 315 | 316 | #endif 317 | 318 | #ifdef DEBUG_PYTHON_REFCNT 319 | 320 | #define PYOBJECTPTR_INCREF(obj, where) \ 321 | do { \ 322 | Py_INCREF(obj); \ 323 | printf(where " REFCNT(%p)=%ld after INCREF\n", obj, Py_REFCNT(obj)); \ 324 | fflush(stdout); \ 325 | } while (0) 326 | 327 | #define PYOBJECTPTR_DECREF(obj, where) \ 328 | do { \ 329 | printf(where " REFCNT(%p)=%ld before DECREF\n", obj, Py_REFCNT(obj)); \ 330 | if (Py_REFCNT(obj) == 1) { \ 331 | printf("##### WILL FREE "); \ 332 | debug_print_repr(obj); \ 333 | } \ 334 | fflush(stdout); \ 335 | Py_DECREF(obj); \ 336 | } while (0) 337 | 338 | #define PYOBJECTPTR_REFCNT_SHOW(obj, where) \ 339 | do { \ 340 | if (obj != NULL) { \ 341 | printf(where " REFCNT(%p)=%ld\n", obj, Py_REFCNT(obj)); \ 342 | fflush(stdout); \ 343 | } \ 344 | } while (0) 345 | 346 | #else 347 | 348 | #define PYOBJECTPTR_INCREF(obj, where) Py_INCREF(obj) 349 | #define PYOBJECTPTR_DECREF(obj, where) Py_DECREF(obj) 350 | #define PYOBJECTPTR_REFCNT_SHOW(obj, where) 351 | 352 | #endif 353 | 354 | #define GIL_ACQUIRE() PyGILState_STATE ___gilstate = PyGILState_Ensure() 355 | #define GIL_RELEASE() PyGILState_Release(___gilstate) 356 | 357 | ___SCMOBJ release_PyObjectPtr(void *obj) { 358 | 359 | if (Py_IsInitialized()) { // Avoid mem management after Python is shutdown 360 | GIL_ACQUIRE(); 361 | PYOBJECTPTR_DECREF(___CAST(PyObjectPtr, obj), "release_PyObjectPtr"); 362 | GIL_RELEASE(); 363 | } 364 | 365 | return ___FIX(___NO_ERR); 366 | } 367 | 368 | end-of-c-declare 369 | ) 370 | 371 | ;;;---------------------------------------------------------------------------- 372 | 373 | ;; Define PyObject* foreign type. 374 | 375 | (c-define-type PyObject "PyObject") 376 | 377 | (c-define-type _PyObject* 378 | (nonnull-pointer 379 | PyObject 380 | (PyObject* 381 | PyObject*/None 382 | PyObject*/bool 383 | PyObject*/int 384 | PyObject*/float 385 | PyObject*/complex 386 | PyObject*/Fraction 387 | PyObject*/bytes 388 | PyObject*/bytearray 389 | PyObject*/str 390 | PyObject*/list 391 | PyObject*/dict 392 | PyObject*/frozenset 393 | PyObject*/set 394 | PyObject*/tuple 395 | PyObject*/module 396 | PyObject*/type 397 | PyObject*/function 398 | PyObject*/builtin_function_or_method 399 | PyObject*/method 400 | PyObject*/method_descriptor 401 | PyObject*/cell 402 | PyObject*/SchemeObject 403 | ))) 404 | 405 | (c-define-type PyObject* 406 | "void*" 407 | "PYOBJECTPTR_to_SCMOBJ" 408 | "SCMOBJ_to_PYOBJECTPTR" 409 | #t) 410 | 411 | (c-define-type PyObject*!own 412 | "void*" 413 | "PYOBJECTPTR_OWN_to_SCMOBJ" 414 | "SCMOBJ_to_PYOBJECTPTR_OWN" 415 | #t) 416 | 417 | ;;;---------------------------------------------------------------------------- 418 | 419 | ;; Define PyObject* subtypes. 420 | 421 | (define-macro (define-python-subtype-type subtype) 422 | (define type (string-append "PyObjectPtr_" subtype)) 423 | (define _name (string->symbol (string-append "_PyObject*/" subtype))) 424 | (define name (string->symbol (string-append "PyObject*/" subtype))) 425 | (define name-own (string->symbol (string-append "PyObject*!own/" subtype))) 426 | (define TYPE (string-append "PYOBJECTPTR_" (string-upcase subtype))) 427 | (define TYPE-OWN (string-append "PYOBJECTPTR_OWN_" (string-upcase subtype))) 428 | (define to-scmobj (string-append TYPE "_to_SCMOBJ")) 429 | (define from-scmobj (string-append "SCMOBJ_to_" TYPE)) 430 | (define to-scmobj-own (string-append TYPE-OWN "_to_SCMOBJ")) 431 | (define from-scmobj-own (string-append "SCMOBJ_to_" TYPE-OWN)) 432 | `(begin 433 | (c-declare ,(string-append "typedef PyObjectPtr " type ";")) 434 | (c-define-type ,_name (nonnull-pointer PyObject ,name)) 435 | (c-define-type ,name "void*" ,to-scmobj ,from-scmobj #t) 436 | (c-define-type ,name-own "void*" ,to-scmobj-own ,from-scmobj-own #t))) 437 | 438 | (define-python-subtype-type "None") 439 | (define-python-subtype-type "bool") 440 | (define-python-subtype-type "int") 441 | (define-python-subtype-type "float") 442 | (define-python-subtype-type "complex") 443 | (define-python-subtype-type "Fraction") 444 | (define-python-subtype-type "bytes") 445 | (define-python-subtype-type "bytearray") 446 | (define-python-subtype-type "str") 447 | (define-python-subtype-type "list") 448 | (define-python-subtype-type "dict") 449 | (define-python-subtype-type "frozenset") 450 | (define-python-subtype-type "set") 451 | (define-python-subtype-type "tuple") 452 | (define-python-subtype-type "module") 453 | (define-python-subtype-type "type") 454 | (define-python-subtype-type "function") 455 | (define-python-subtype-type "builtin_function_or_method") 456 | (define-python-subtype-type "method") 457 | (define-python-subtype-type "method_descriptor") 458 | (define-python-subtype-type "cell") 459 | (define-python-subtype-type "SchemeObject") 460 | 461 | ;;;---------------------------------------------------------------------------- 462 | 463 | ;; Define PyTypeObject* foreign type. 464 | 465 | ;; NOTE: Not sure yet if we want to use raw PyTypeObjects. 466 | 467 | (c-define-type PyTypeObject "PyTypeObject") 468 | 469 | (c-define-type PyTypeObject* 470 | (nonnull-pointer PyTypeObject (PyTypeObject*))) 471 | 472 | ;;;---------------------------------------------------------------------------- 473 | 474 | ;; Generator of converter macros. 475 | 476 | (define-macro (define-converter-macros _SUBTYPE _OWN release) 477 | `(c-declare ,(string-append " 478 | 479 | #define ___BEGIN_CFUN_SCMOBJ_to_PYOBJECTPTR" _OWN _SUBTYPE "(src,dst,i) \ 480 | if ((___err = SCMOBJ_to_PYOBJECTPTR" _SUBTYPE "(src, &dst, i)) == ___FIX(___NO_ERR)) { 481 | #define ___END_CFUN_SCMOBJ_to_PYOBJECTPTR" _OWN _SUBTYPE "(src,dst,i) " release "} 482 | 483 | #define ___BEGIN_CFUN_PYOBJECTPTR" _OWN _SUBTYPE "_to_SCMOBJ(src,dst) \ 484 | if ((___err = PYOBJECTPTR" _OWN _SUBTYPE "_to_SCMOBJ(src, &dst, 0)) == ___FIX(___NO_ERR)) { 485 | #define ___END_CFUN_PYOBJECTPTR" _OWN _SUBTYPE "_to_SCMOBJ(src,dst) ___EXT(___release_scmobj)(dst); } 486 | 487 | #define ___BEGIN_SFUN_PYOBJECTPTR" _OWN _SUBTYPE "_to_SCMOBJ(src,dst,i) \ 488 | if ((___err = PYOBJECTPTR" _OWN _SUBTYPE "_to_SCMOBJ(src, &dst, i)) == ___FIX(___NO_ERR)) { 489 | #define ___END_SFUN_PYOBJECTPTR" _OWN _SUBTYPE "_to_SCMOBJ(src,dst,i) ___EXT(___release_scmobj)(dst); } 490 | 491 | #define ___BEGIN_SFUN_SCMOBJ_to_PYOBJECTPTR" _OWN _SUBTYPE "(src,dst) \ 492 | if ((___err = SCMOBJ_to_PYOBJECTPTR" _SUBTYPE "(src, &dst, 0)) == ___FIX(___NO_ERR)) { 493 | #define ___END_SFUN_SCMOBJ_to_PYOBJECTPTR" _OWN _SUBTYPE "(src,dst) " release "} 494 | "))) 495 | 496 | ;;;---------------------------------------------------------------------------- 497 | 498 | ;; Converter for Python* type that detects the subtype. 499 | 500 | (c-declare #<ob_type->tp_name, "builtin_function_or_method")) 613 | tag = ___C_TAG_PyObject_2a__2f_builtin__function__or__method; 614 | else 615 | #endif 616 | 617 | #ifdef ___C_TAG_PyObject_2a__2f_method 618 | if (PyMethod_Check(src)) 619 | tag = ___C_TAG_PyObject_2a__2f_method; 620 | else 621 | #endif 622 | 623 | #ifdef ___C_TAG_PyObject_2a__2f_method__descriptor 624 | if (!strcmp(src->ob_type->tp_name, "method_descriptor")) 625 | tag = ___C_TAG_PyObject_2a__2f_method__descriptor; 626 | else 627 | #endif 628 | 629 | #ifdef ___C_TAG_PyObject_2a__2f_cell 630 | if (PyCell_Check(src)) 631 | tag = ___C_TAG_PyObject_2a__2f_cell; 632 | else 633 | #endif 634 | 635 | #ifdef ___C_TAG_PyObject_2a__2f_SchemeObject 636 | if (Py_TYPE(src) == _SchemeObject_cls) 637 | tag = ___C_TAG_PyObject_2a__2f_SchemeObject; 638 | else 639 | #endif 640 | 641 | tag = ___C_TAG_PyObject_2a_; 642 | 643 | PYOBJECTPTR_REFCNT_SHOW(src, "PYOBJECTPTR_to_SCMOBJ"); 644 | 645 | return ___EXT(___NONNULLPOINTER_to_SCMOBJ)(___PSTATE, 646 | src, 647 | tag, 648 | release_PyObjectPtr, 649 | dst, 650 | arg_num); 651 | } 652 | 653 | ___SCMOBJ PYOBJECTPTR_OWN_to_SCMOBJ(PyObjectPtr src, ___SCMOBJ *dst, int arg_num) { 654 | if (src == NULL) 655 | return ___FIX(___CTOS_NONNULLPOINTER_ERR+arg_num); 656 | PYOBJECTPTR_INCREF(src, "PYOBJECTPTR_OWN_to_SCMOBJ"); 657 | return PYOBJECTPTR_to_SCMOBJ(src, dst, arg_num); 658 | } 659 | 660 | ___SCMOBJ SCMOBJ_to_PYOBJECTPTR(___SCMOBJ src, void **dst, int arg_num) { 661 | 662 | ___processor_state ___ps = ___PSTATE; 663 | 664 | #define CONVERT_TO_NONNULLPOINTER(tag) \ 665 | ___EXT(___SCMOBJ_to_NONNULLPOINTER)(___PSP src, dst, tag, arg_num) 666 | 667 | #define TRY_CONVERT_TO_NONNULLPOINTER(tag) \ 668 | if (CONVERT_TO_NONNULLPOINTER(tag) == ___FIX(___NO_ERR)) \ 669 | return ___FIX(___NO_ERR) 670 | 671 | #ifdef ___C_TAG_PyObject_2a__2f_None 672 | TRY_CONVERT_TO_NONNULLPOINTER(___C_TAG_PyObject_2a__2f_None); 673 | #endif 674 | 675 | #ifdef ___C_TAG_PyObject_2a__2f_bool 676 | TRY_CONVERT_TO_NONNULLPOINTER(___C_TAG_PyObject_2a__2f_bool); 677 | #endif 678 | 679 | #ifdef ___C_TAG_PyObject_2a__2f_int 680 | TRY_CONVERT_TO_NONNULLPOINTER(___C_TAG_PyObject_2a__2f_int); 681 | #endif 682 | 683 | #ifdef ___C_TAG_PyObject_2a__2f_float 684 | TRY_CONVERT_TO_NONNULLPOINTER(___C_TAG_PyObject_2a__2f_float); 685 | #endif 686 | 687 | #ifdef ___C_TAG_PyObject_2a__2f_complex 688 | TRY_CONVERT_TO_NONNULLPOINTER(___C_TAG_PyObject_2a__2f_complex); 689 | #endif 690 | 691 | #ifdef ___C_TAG_PyObject_2a__2f_Fraction 692 | TRY_CONVERT_TO_NONNULLPOINTER(___C_TAG_PyObject_2a__2f_Fraction); 693 | #endif 694 | 695 | #ifdef ___C_TAG_PyObject_2a__2f_bytes 696 | TRY_CONVERT_TO_NONNULLPOINTER(___C_TAG_PyObject_2a__2f_bytes); 697 | #endif 698 | 699 | #ifdef ___C_TAG_PyObject_2a__2f_bytearray 700 | TRY_CONVERT_TO_NONNULLPOINTER(___C_TAG_PyObject_2a__2f_bytearray); 701 | #endif 702 | 703 | #ifdef ___C_TAG_PyObject_2a__2f_str 704 | TRY_CONVERT_TO_NONNULLPOINTER(___C_TAG_PyObject_2a__2f_str); 705 | #endif 706 | 707 | #ifdef ___C_TAG_PyObject_2a__2f_list 708 | TRY_CONVERT_TO_NONNULLPOINTER(___C_TAG_PyObject_2a__2f_list); 709 | #endif 710 | 711 | #ifdef ___C_TAG_PyObject_2a__2f_dict 712 | TRY_CONVERT_TO_NONNULLPOINTER(___C_TAG_PyObject_2a__2f_dict); 713 | #endif 714 | 715 | #ifdef ___C_TAG_PyObject_2a__2f_frozenset 716 | TRY_CONVERT_TO_NONNULLPOINTER(___C_TAG_PyObject_2a__2f_frozenset); 717 | #endif 718 | 719 | #ifdef ___C_TAG_PyObject_2a__2f_set 720 | TRY_CONVERT_TO_NONNULLPOINTER(___C_TAG_PyObject_2a__2f_set); 721 | #endif 722 | 723 | #ifdef ___C_TAG_PyObject_2a__2f_tuple 724 | TRY_CONVERT_TO_NONNULLPOINTER(___C_TAG_PyObject_2a__2f_tuple); 725 | #endif 726 | 727 | #ifdef ___C_TAG_PyObject_2a__2f_module 728 | TRY_CONVERT_TO_NONNULLPOINTER(___C_TAG_PyObject_2a__2f_module); 729 | #endif 730 | 731 | #ifdef ___C_TAG_PyObject_2a__2f_type 732 | TRY_CONVERT_TO_NONNULLPOINTER(___C_TAG_PyObject_2a__2f_type); 733 | #endif 734 | 735 | #ifdef ___C_TAG_PyObject_2a__2f_function 736 | TRY_CONVERT_TO_NONNULLPOINTER(___C_TAG_PyObject_2a__2f_function); 737 | #endif 738 | 739 | #ifdef ___C_TAG_PyObject_2a__2f_builtin__function__or__method 740 | TRY_CONVERT_TO_NONNULLPOINTER(___C_TAG_PyObject_2a__2f_builtin__function__or__method); 741 | #endif 742 | 743 | #ifdef ___C_TAG_PyObject_2a__2f_method 744 | TRY_CONVERT_TO_NONNULLPOINTER(___C_TAG_PyObject_2a__2f_method); 745 | #endif 746 | 747 | #ifdef ___C_TAG_PyObject_2a__2f_method__descriptor 748 | TRY_CONVERT_TO_NONNULLPOINTER(___C_TAG_PyObject_2a__2f_method__descriptor); 749 | #endif 750 | 751 | #ifdef ___C_TAG_PyObject_2a__2f_cell 752 | TRY_CONVERT_TO_NONNULLPOINTER(___C_TAG_PyObject_2a__2f_cell); 753 | #endif 754 | 755 | #ifdef ___C_TAG_PyObject_2a__2f_SchemeObject 756 | TRY_CONVERT_TO_NONNULLPOINTER(___C_TAG_PyObject_2a__2f_SchemeObject); 757 | #endif 758 | 759 | return CONVERT_TO_NONNULLPOINTER(___C_TAG_PyObject_2a_); 760 | } 761 | 762 | end-of-c-declare 763 | ) 764 | 765 | (define-converter-macros "" "" "") 766 | (define-converter-macros "" "_OWN" "___EXT(___release_foreign) (src); ") 767 | 768 | ;;;---------------------------------------------------------------------------- 769 | 770 | ;; Converters for Python* subtypes. 771 | 772 | (define-macro (define-subtype-converters subtype check) 773 | (define _SUBTYPE (string-append "_" (string-upcase subtype))) 774 | (define tag (string-append "___C_TAG_PyObject_2a__2f_" subtype)) 775 | `(begin 776 | (c-declare 777 | ,(string-append " 778 | 779 | #ifdef " tag " 780 | 781 | ___SCMOBJ PYOBJECTPTR" _SUBTYPE "_to_SCMOBJ(PyObjectPtr_" subtype " src, ___SCMOBJ *dst, int arg_num) { 782 | 783 | if (src == NULL || !(" check ")) 784 | return ___FIX(___CTOS_NONNULLPOINTER_ERR+arg_num); 785 | 786 | PYOBJECTPTR_REFCNT_SHOW(src, \"PYOBJECTPTR" _SUBTYPE "_to_SCMOBJ\"); 787 | 788 | return ___EXT(___NONNULLPOINTER_to_SCMOBJ)(___PSTATE, 789 | src, 790 | " tag ", 791 | release_PyObjectPtr, 792 | dst, 793 | arg_num); 794 | } 795 | 796 | ___SCMOBJ PYOBJECTPTR_OWN" _SUBTYPE "_to_SCMOBJ(PyObjectPtr_" subtype " src, ___SCMOBJ *dst, int arg_num) { 797 | 798 | if (src == NULL || !(" check ")) 799 | return ___FIX(___CTOS_NONNULLPOINTER_ERR+arg_num); 800 | 801 | PYOBJECTPTR_INCREF(src, \"PYOBJECTPTR_OWN" _SUBTYPE "_to_SCMOBJ\"); 802 | 803 | return ___EXT(___NONNULLPOINTER_to_SCMOBJ)(___PSTATE, 804 | src, 805 | " tag ", 806 | release_PyObjectPtr, 807 | dst, 808 | arg_num); 809 | } 810 | 811 | ___SCMOBJ SCMOBJ_to_PYOBJECTPTR" _SUBTYPE "(___SCMOBJ src, void **dst, int arg_num) { 812 | 813 | return ___EXT(___SCMOBJ_to_NONNULLPOINTER)(___PSA(___PSTATE) 814 | src, 815 | dst, 816 | " tag ", 817 | arg_num); 818 | } 819 | 820 | #endif 821 | 822 | ")) 823 | (define-converter-macros ,_SUBTYPE "" "") 824 | (define-converter-macros ,_SUBTYPE "_OWN" "___EXT(___release_foreign) (src); "))) 825 | 826 | (define-subtype-converters "None" "src == Py_None") 827 | (define-subtype-converters "bool" "src == Py_False || src == Py_True") 828 | (define-subtype-converters "int" "PyLong_Check(src)") 829 | (define-subtype-converters "float" "PyFloat_Check(src)") 830 | (define-subtype-converters "complex" "PyComplex_Check(src)") 831 | (define-subtype-converters "Fraction" "Py_TYPE(src) == Fraction_cls") 832 | (define-subtype-converters "bytes" "PyBytes_Check(src)") 833 | (define-subtype-converters "bytearray" "PyByteArray_Check(src)") 834 | (define-subtype-converters "str" "PyUnicode_Check(src)") 835 | (define-subtype-converters "list" "PyList_Check(src)") 836 | (define-subtype-converters "dict" "PyDict_Check(src)") 837 | (define-subtype-converters "frozenset" "PyFrozenSet_Check(src)") 838 | (define-subtype-converters "set" "PyAnySet_Check(src) && !PyFrozenSet_Check(src)") 839 | (define-subtype-converters "tuple" "PyTuple_Check(src)") 840 | (define-subtype-converters "module" "PyModule_Check(src)") 841 | (define-subtype-converters "type" "PyType_Check(src)") 842 | (define-subtype-converters "function" "PyFunction_Check(src)") 843 | (define-subtype-converters "builtin_function_or_method" "!strcmp(src->ob_type->tp_name, \"builtin_function_or_method\")") 844 | (define-subtype-converters "method" "PyMethod_Check(src)") 845 | (define-subtype-converters "method_descriptor" "!strcmp(src->ob_type->tp_name, \"method_descriptor\")") 846 | (define-subtype-converters "cell" "PyCell_Check(src)") 847 | (define-subtype-converters "SchemeObject" "Py_TYPE(src) == _SchemeObject_cls") 848 | 849 | ;;;---------------------------------------------------------------------------- 850 | 851 | (c-declare #<string 996 | (PyObject_Repr val)) 997 | "\n" 998 | (PyObject*/str->string 999 | (PyObject_Repr tb)) 1000 | "\n" 1001 | ) 1002 | port) 1003 | ) 1004 | (cons (python-exception-proc exc) 1005 | (python-exception-args exc))))) 1006 | 1007 | (define (python-error-handler code data proc . args) 1008 | (raise (make-python-exception data proc args))) 1009 | 1010 | ;;;---------------------------------------------------------------------------- 1011 | 1012 | ;; Interface to Python API. 1013 | 1014 | (define-macro (def-api name result-type arg-types) 1015 | (let* ((result-type-str 1016 | (symbol->string result-type)) 1017 | (base-result-type-str 1018 | (if (eqv? 0 (##string-contains result-type-str "PyObject*")) 1019 | "PyObjectPtr" 1020 | result-type-str))) 1021 | `(define ,name 1022 | (c-lambda ,arg-types 1023 | ,result-type 1024 | ,(string-append "return_with_check_" 1025 | (##string->c-id base-result-type-str) 1026 | "(" 1027 | (symbol->string name) 1028 | "(" 1029 | (string-concatenate 1030 | (map (lambda (i) 1031 | (string-append "___arg" (number->string i))) 1032 | (iota (length arg-types) 1)) 1033 | ",") 1034 | "));"))))) 1035 | 1036 | (define Py_eval_input ((c-lambda () int "___return(Py_eval_input);"))) 1037 | (define Py_file_input ((c-lambda () int "___return(Py_file_input);"))) 1038 | (define Py_single_input ((c-lambda () int "___return(Py_single_input);"))) 1039 | 1040 | (def-api Py_Initialize void ()) 1041 | (def-api Py_Finalize void ()) 1042 | 1043 | (def-api PyBool_FromLong PyObject*/bool (long)) 1044 | 1045 | (def-api PyLong_FromUnicodeObject PyObject*/int (PyObject*/str int)) 1046 | 1047 | (def-api PyUnicode_FromString PyObject*/str (nonnull-UTF-8-string)) 1048 | 1049 | (def-api PyRun_SimpleString int (nonnull-UTF-8-string)) 1050 | 1051 | (def-api PyRun_String PyObject* (nonnull-UTF-8-string 1052 | int 1053 | PyObject*/dict 1054 | PyObject*/dict)) 1055 | 1056 | (def-api PyImport_AddModuleObject PyObject*/module (PyObject*/str)) 1057 | (def-api PyImport_AddModule PyObject*/module (nonnull-UTF-8-string)) 1058 | (def-api PyImport_ImportModule PyObject*/module (nonnull-UTF-8-string)) 1059 | (def-api PyImport_ImportModuleEx PyObject*/module (nonnull-UTF-8-string 1060 | PyObject*/dict 1061 | PyObject*/dict 1062 | PyObject*/list)) 1063 | 1064 | (def-api PyModule_GetDict PyObject*/dict (PyObject*/module)) 1065 | 1066 | (def-api PyDict_New PyObject*/dict ()) 1067 | (def-api PyDict_Size ssize_t (PyObject*/dict)) 1068 | (def-api PyDict_Items PyObject*/list (PyObject*/dict)) 1069 | (def-api PyDict_Keys PyObject*/list (PyObject*/dict)) 1070 | (def-api PyDict_Values PyObject*/list (PyObject*/dict)) 1071 | (def-api PyDict_GetItem PyObject* (PyObject*/dict 1072 | PyObject*)) 1073 | (def-api PyDict_SetItem int (PyObject*/dict 1074 | PyObject* 1075 | PyObject*)) 1076 | (def-api PyDict_GetItemString PyObject* (PyObject*/dict 1077 | nonnull-UTF-8-string)) 1078 | (def-api PyDict_SetItemString int (PyObject*/dict 1079 | nonnull-UTF-8-string 1080 | PyObject*)) 1081 | 1082 | (def-api PyCell_New PyObject*/cell (PyObject*)) 1083 | (def-api PyCell_Get PyObject* (PyObject*/cell)) 1084 | (def-api PyCell_Set int (PyObject*/cell 1085 | PyObject*)) 1086 | 1087 | (def-api PyList_New PyObject*/list (int)) 1088 | 1089 | (def-api PyTuple_GetItem PyObject* (PyObject*/tuple 1090 | ssize_t)) 1091 | 1092 | (def-api PyObject_CallObject PyObject* (PyObject* 1093 | PyObject*/tuple)) 1094 | (def-api PyObject_CallMethod PyObject* (PyObject* 1095 | nonnull-UTF-8-string 1096 | nonnull-UTF-8-string)) 1097 | 1098 | (def-api PyObject_GetAttrString PyObject* (PyObject* 1099 | nonnull-UTF-8-string)) 1100 | (def-api PyObject_HasAttrString int (PyObject* 1101 | nonnull-UTF-8-string)) 1102 | 1103 | (def-api PyObject_Length ssize_t (PyObject*)) 1104 | 1105 | (def-api PyObject_Repr PyObject*/str (PyObject*)) 1106 | 1107 | ;;(def-api Py_SetPath void (nonnull-wchar_t-string)) 1108 | ;;(def-api Py_SetProgramName void (nonnull-wchar_t-string)) 1109 | ;;(def-api PySys_SetArgv void (int nonnull-wchar_t-string-list)) 1110 | ;;(def-api PySys_SetArgvEx void (int nonnull-wchar_t-string-list int)) 1111 | ;;(def-api Py_SetPythonHome void (nonnull-wchar_t-string)) 1112 | 1113 | (def-api PyCallable_Check int (PyObject*)) 1114 | 1115 | ;; NOTE: Maybe migrate to `def-api' 1116 | (c-define-type PyThreadState "PyThreadState") 1117 | (c-define-type PyThreadState* (nonnull-pointer PyThreadState)) 1118 | (define Py_NewInterpreter 1119 | (c-lambda () PyThreadState* "Py_NewInterpreter")) 1120 | 1121 | ;; Get object type from struct field, no new reference. 1122 | (define PyObject*-type 1123 | (c-lambda (_PyObject*) PyTypeObject* 1124 | "___return(___arg1->ob_type);")) 1125 | 1126 | (define PyObject*-type-name 1127 | (c-lambda (_PyObject*) nonnull-UTF-8-string 1128 | "___return(___CAST(char*,___arg1->ob_type->tp_name));")) 1129 | 1130 | ;; Useful for debugging 1131 | (define _Py_REFCNT 1132 | (c-lambda (PyObject*) ssize_t 1133 | "___return(Py_REFCNT(___arg1));")) 1134 | 1135 | ;;;---------------------------------------------------------------------------- 1136 | 1137 | ;; Converters between Scheme and subtypes of Python* foreign objects. 1138 | 1139 | ;; TODO: check for errors and implement conversion of other subtypes... 1140 | 1141 | (define PyObject*/None->void 1142 | (c-lambda (PyObject*/None) scheme-object " 1143 | 1144 | ___return(___VOID); 1145 | 1146 | ")) 1147 | 1148 | (define void->PyObject*/None 1149 | (c-lambda (scheme-object) PyObject*/None " 1150 | 1151 | ___SCMOBJ src = ___arg1; 1152 | PyObjectPtr dst = NULL; 1153 | 1154 | GIL_ACQUIRE(); 1155 | 1156 | if (___EQP(src, ___VOID)) { 1157 | dst = Py_None; 1158 | PYOBJECTPTR_INCREF(dst, \"void->PyObject*/None\"); 1159 | } 1160 | 1161 | GIL_RELEASE(); 1162 | 1163 | ___return(dst); 1164 | 1165 | ")) 1166 | 1167 | (define PyObject*/bool->boolean 1168 | (c-lambda (PyObject*/bool) scheme-object " 1169 | 1170 | ___SCMOBJ dst; 1171 | 1172 | GIL_ACQUIRE(); 1173 | 1174 | dst = ___BOOLEAN(___arg1 != Py_False); 1175 | 1176 | GIL_RELEASE(); 1177 | 1178 | ___return(dst); 1179 | 1180 | ")) 1181 | 1182 | (define boolean->PyObject*/bool 1183 | (c-lambda (scheme-object) PyObject*/bool " 1184 | 1185 | ___SCMOBJ src = ___arg1; 1186 | PyObjectPtr dst = NULL; 1187 | 1188 | GIL_ACQUIRE(); 1189 | 1190 | if (___BOOLEANP(src)) { 1191 | dst = ___FALSEP(src) ? Py_False : Py_True; 1192 | PYOBJECTPTR_INCREF(dst, \"boolean->PyObject*/bool\"); 1193 | } 1194 | 1195 | GIL_RELEASE(); 1196 | 1197 | ___return(dst); 1198 | 1199 | ")) 1200 | 1201 | (define (PyObject*/int->exact-integer src) 1202 | (let ((dst 1203 | ((c-lambda (PyObject*/int) scheme-object " 1204 | 1205 | PyObjectPtr src = ___arg1; 1206 | ___SCMOBJ dst = ___FAL; 1207 | 1208 | int overflow; 1209 | ___LONGLONG val; 1210 | 1211 | GIL_ACQUIRE(); 1212 | 1213 | val = PyLong_AsLongLongAndOverflow(src, &overflow); 1214 | 1215 | if (!overflow) { 1216 | 1217 | if (___EXT(___LONGLONG_to_SCMOBJ)(___PSTATE, 1218 | val, 1219 | &dst, 1220 | ___RETURN_POS) 1221 | != ___FIX(___NO_ERR)) 1222 | dst = ___FAL; 1223 | 1224 | } else { 1225 | 1226 | size_t nb_bits = _PyLong_NumBits(src) + 1; /* add 1 for sign */ 1227 | size_t nb_adigits = (nb_bits + ___BIG_ABASE_WIDTH - 1) / ___BIG_ABASE_WIDTH; 1228 | size_t nb_bytes = nb_adigits * (___BIG_ABASE_WIDTH>>3); 1229 | 1230 | dst = ___EXT(___alloc_scmobj) (___ps, ___sBIGNUM, nb_bytes); 1231 | if (___FIXNUMP(dst)) 1232 | dst = ___FAL; 1233 | else { 1234 | if (_PyLong_AsByteArray(___CAST(PyLongObject*,src), 1235 | ___CAST(unsigned char*,___BODY_AS(dst, ___tSUBTYPED)), 1236 | nb_bytes, 1237 | #ifdef ___LITTLE_ENDIAN 1238 | 1 1239 | #else 1240 | 0 1241 | #endif 1242 | , 1 1243 | #if PY_MAJOR_VERSION == 3 && PY_MINOR_VERSION >= 13 1244 | , 0 1245 | #endif 1246 | )) { 1247 | dst = ___FAL; 1248 | } 1249 | } 1250 | 1251 | } 1252 | 1253 | GIL_RELEASE(); 1254 | 1255 | ___return(___EXT(___release_scmobj) (dst)); 1256 | 1257 | ") 1258 | src))) 1259 | (if dst 1260 | (if (##bignum? dst) 1261 | (##bignum.normalize! dst) 1262 | dst) 1263 | (error "PyObject*/int->exact-integer conversion error")))) 1264 | 1265 | (define exact-integer->PyObject*/int 1266 | (c-lambda (scheme-object) PyObject*/int " 1267 | 1268 | ___SCMOBJ src = ___arg1; 1269 | PyObjectPtr dst = NULL; 1270 | 1271 | GIL_ACQUIRE(); 1272 | 1273 | if (___FIXNUMP(src)) { 1274 | dst = PyLong_FromLongLong(___INT(src)); 1275 | } else { 1276 | 1277 | #ifdef ___LITTLE_ENDIAN 1278 | /* 1279 | * Conversion is simple when words are represented in little endian 1280 | * because bignums are also stored with the big digits from the least 1281 | * signigicant digit to the most significant digit. So when viewed 1282 | * as an array of bytes the bytes are from least significant to most 1283 | * significant. 1284 | */ 1285 | dst = _PyLong_FromByteArray( 1286 | ___CAST(const unsigned char*,___BODY_AS(src,___tSUBTYPED)), 1287 | ___HD_BYTES(___SUBTYPED_HEADER(src)), 1288 | 1, /* little_endian */ 1289 | 1); /* is_signed */ 1290 | #endif 1291 | 1292 | #ifdef ___BIG_ENDIAN 1293 | printf(\"conversion from big-endian bignum to Python int is not yet supported\\n\"); 1294 | exit(1); /* TODO: better error handling! */ 1295 | #endif 1296 | } 1297 | 1298 | PYOBJECTPTR_REFCNT_SHOW(dst, \"exact-integer->PyObject*/int\"); 1299 | 1300 | GIL_RELEASE(); 1301 | 1302 | ___return(dst); 1303 | 1304 | ")) 1305 | 1306 | (define PyObject*/float->flonum 1307 | (c-lambda (PyObject*/float) double " 1308 | 1309 | double dst; 1310 | 1311 | GIL_ACQUIRE(); 1312 | 1313 | dst = PyFloat_AS_DOUBLE(___arg1); 1314 | 1315 | GIL_RELEASE(); 1316 | 1317 | ___return(dst); 1318 | 1319 | ")) 1320 | 1321 | (define flonum->PyObject*/float 1322 | (c-lambda (double) PyObject*/float " 1323 | 1324 | PyObjectPtr dst; 1325 | 1326 | GIL_ACQUIRE(); 1327 | 1328 | dst = PyFloat_FromDouble(___arg1); 1329 | 1330 | PYOBJECTPTR_REFCNT_SHOW(dst, \"flonum->PyObject*/float\"); 1331 | 1332 | GIL_RELEASE(); 1333 | 1334 | ___return(dst); 1335 | 1336 | ")) 1337 | 1338 | (define (PyObject*/complex->cpxnum src) 1339 | (or ((c-lambda (PyObject*/complex) scheme-object " 1340 | 1341 | PyObjectPtr src = ___arg1; 1342 | ___SCMOBJ dst = ___FAL; 1343 | ___SCMOBJ real_scmobj; 1344 | ___SCMOBJ imag_scmobj; 1345 | double real; 1346 | double imag; 1347 | 1348 | GIL_ACQUIRE(); 1349 | 1350 | real = PyComplex_RealAsDouble(src); 1351 | imag = PyComplex_ImagAsDouble(src); 1352 | 1353 | ___BEGIN_SFUN_DOUBLE_TO_SCMOBJ(real,real_scmobj,___RETURN_POS) 1354 | ___BEGIN_SFUN_DOUBLE_TO_SCMOBJ(imag,imag_scmobj,___RETURN_POS) 1355 | 1356 | dst = ___EXT(___alloc_scmobj) (___ps, ___sCPXNUM, ___CPXNUM_SIZE<<___LWS); 1357 | if (___FIXNUMP(dst)) 1358 | dst = ___FAL; 1359 | else 1360 | { 1361 | ___CPXNUMREAL(dst) = real_scmobj; 1362 | ___CPXNUMIMAG(dst) = imag_scmobj; 1363 | ___EXT(___release_scmobj) (dst); 1364 | } 1365 | 1366 | ___END_SFUN_DOUBLE_TO_SCMOBJ(imag,imag_scmobj,___RETURN_POS) 1367 | ___END_SFUN_DOUBLE_TO_SCMOBJ(real,real_scmobj,___RETURN_POS) 1368 | 1369 | GIL_RELEASE(); 1370 | 1371 | ___return(dst); 1372 | 1373 | ") 1374 | src) 1375 | (error "PyObject*/complex->cpxnum conversion error"))) 1376 | 1377 | (define flonums->PyObject*/complex 1378 | (c-lambda (double double) PyObject*/complex " 1379 | 1380 | double real = ___arg1; 1381 | double imag = ___arg2; 1382 | 1383 | PyObjectPtr dst; 1384 | 1385 | GIL_ACQUIRE(); 1386 | 1387 | dst = PyComplex_FromDoubles(real, imag); 1388 | 1389 | PYOBJECTPTR_REFCNT_SHOW(dst, \"flonums->PyObject*/complex\"); 1390 | 1391 | GIL_RELEASE(); 1392 | 1393 | ___return(dst); 1394 | 1395 | ")) 1396 | 1397 | (define (PyObject*/Fraction->ratnum src) 1398 | (let ((dst 1399 | ((c-lambda (PyObject*/Fraction) scheme-object " 1400 | 1401 | PyObjectPtr src = ___arg1; 1402 | ___SCMOBJ dst = ___FAL; 1403 | ___SCMOBJ num_scmobj; 1404 | ___SCMOBJ den_scmobj; 1405 | PyObjectPtr num; 1406 | PyObjectPtr den; 1407 | 1408 | GIL_ACQUIRE(); 1409 | 1410 | num = PyObject_GetAttrString(src, \"_numerator\"); 1411 | den = PyObject_GetAttrString(src, \"_denominator\"); 1412 | 1413 | if (PYOBJECTPTR_to_SCMOBJ(num, &num_scmobj, ___RETURN_POS) 1414 | == ___FIX(___NO_ERR)) { 1415 | if (PYOBJECTPTR_to_SCMOBJ(den, &den_scmobj, ___RETURN_POS) 1416 | == ___FIX(___NO_ERR)) { 1417 | dst = ___EXT(___alloc_scmobj) (___ps, ___sVECTOR, 2<<___LWS); 1418 | if (___FIXNUMP(dst)) 1419 | dst = ___FAL; 1420 | else 1421 | { 1422 | ___VECTORELEM(dst, 0) = num_scmobj; 1423 | ___VECTORELEM(dst, 1) = den_scmobj; 1424 | ___EXT(___release_scmobj) (dst); 1425 | } 1426 | ___EXT(___release_scmobj) (den_scmobj); 1427 | } 1428 | ___EXT(___release_scmobj) (num_scmobj); 1429 | } 1430 | 1431 | GIL_RELEASE(); 1432 | 1433 | ___return(dst); 1434 | 1435 | ") 1436 | src))) 1437 | (if dst 1438 | (##/2 (PyObject*->object (vector-ref dst 0)) 1439 | (PyObject*->object (vector-ref dst 1))) 1440 | (error "PyObject*/Fraction->ratnum conversion error")))) 1441 | 1442 | (define ints->PyObject*/Fraction 1443 | (c-lambda (PyObject*/int PyObject*/int) PyObject*/Fraction " 1444 | 1445 | PyObjectPtr num = ___arg1; 1446 | PyObjectPtr den = ___arg2; 1447 | PyObjectPtr dst; 1448 | 1449 | GIL_ACQUIRE(); 1450 | 1451 | dst = PyObject_CallFunctionObjArgs(___CAST(PyObjectPtr,Fraction_cls), num, den, NULL); 1452 | 1453 | GIL_RELEASE(); 1454 | 1455 | ___return(dst); 1456 | 1457 | ")) 1458 | 1459 | (define (PyObject*/str->string src) 1460 | (or ((c-lambda (PyObject*/str) scheme-object " 1461 | 1462 | PyObjectPtr src = ___arg1; 1463 | ___SCMOBJ dst = ___FAL; 1464 | 1465 | GIL_ACQUIRE(); 1466 | 1467 | if (!PyUnicode_READY(src)) { /* convert to canonical representation */ 1468 | 1469 | Py_ssize_t len = PyUnicode_GET_LENGTH(src); 1470 | 1471 | dst = ___EXT(___alloc_scmobj) (___PSTATE, ___sSTRING, len << ___LCS); 1472 | 1473 | if (___FIXNUMP(dst)) 1474 | dst = ___FAL; 1475 | else 1476 | switch (PyUnicode_KIND(src)) { 1477 | case PyUnicode_1BYTE_KIND: 1478 | { 1479 | Py_UCS1 *data = PyUnicode_1BYTE_DATA(src); 1480 | while (len-- > 0) 1481 | ___STRINGSET(dst, ___FIX(len), ___CHR(data[len])); 1482 | break; 1483 | } 1484 | case PyUnicode_2BYTE_KIND: 1485 | { 1486 | Py_UCS2 *data = PyUnicode_2BYTE_DATA(src); 1487 | while (len-- > 0) 1488 | ___STRINGSET(dst, ___FIX(len), ___CHR(data[len])); 1489 | break; 1490 | } 1491 | case PyUnicode_4BYTE_KIND: 1492 | { 1493 | Py_UCS4 *data = PyUnicode_4BYTE_DATA(src); 1494 | while (len-- > 0) 1495 | ___STRINGSET(dst, ___FIX(len), ___CHR(data[len])); 1496 | break; 1497 | } 1498 | } 1499 | } 1500 | 1501 | GIL_RELEASE(); 1502 | 1503 | ___return(___EXT(___release_scmobj) (dst)); 1504 | 1505 | ") 1506 | src) 1507 | (error "PyObject*/str->string conversion error"))) 1508 | 1509 | (define string->PyObject*/str 1510 | (c-lambda (scheme-object) PyObject*/str " 1511 | 1512 | ___SCMOBJ src = ___arg1; 1513 | PyObjectPtr dst; 1514 | 1515 | ___SCMOBJ ___temp; // used by ___STRINGP 1516 | 1517 | GIL_ACQUIRE(); 1518 | 1519 | if (!___STRINGP(src)) { 1520 | dst = NULL; 1521 | } else { 1522 | dst = PyUnicode_FromKindAndData(___CS_SELECT(PyUnicode_1BYTE_KIND, 1523 | PyUnicode_2BYTE_KIND, 1524 | PyUnicode_4BYTE_KIND), 1525 | ___CAST(void*, 1526 | ___BODY_AS(src,___tSUBTYPED)), 1527 | ___INT(___STRINGLENGTH(src))); 1528 | PYOBJECTPTR_REFCNT_SHOW(dst, \"string->PyObject*/str\"); 1529 | } 1530 | 1531 | GIL_RELEASE(); 1532 | 1533 | ___return(dst); 1534 | 1535 | ")) 1536 | 1537 | ;; Convert from Python to Gambit kwargs notation 1538 | (define (kwargs->keywords keys vals) 1539 | (define (join i v) 1540 | (list v (string->keyword i))) 1541 | (if (pair? keys) 1542 | (let loop ((keys keys) (vals vals) (kwargs '())) 1543 | (if (pair? keys) 1544 | (loop (cdr keys) (cdr vals) (append (join (car keys) (car vals)) kwargs)) 1545 | (reverse kwargs))) 1546 | '())) 1547 | 1548 | (define object->SchemeObject 1549 | (c-lambda (scheme-object) PyObject*/SchemeObject " 1550 | 1551 | ___SCMOBJ src = ___arg1; 1552 | PyObjectPtr dst; 1553 | 1554 | void *ptr; 1555 | 1556 | GIL_ACQUIRE(); 1557 | 1558 | ptr = ___EXT(___alloc_rc)(___PSP 0); 1559 | 1560 | if (ptr == NULL) { 1561 | // Heap overflow 1562 | dst = NULL; 1563 | } else { 1564 | 1565 | ___EXT(___set_data_rc)(ptr, src); 1566 | 1567 | // Create an instance of a _SchemeObject class 1568 | PyObject* obj_capsule = PyCapsule_New(ptr, NULL, NULL); 1569 | 1570 | // TODO: check for heap overflow 1571 | dst = PyObject_CallFunctionObjArgs(___CAST(PyObjectPtr,_SchemeObject_cls), obj_capsule, NULL); 1572 | 1573 | if (dst == NULL) { 1574 | ___EXT(___release_rc)(ptr); 1575 | } 1576 | } 1577 | 1578 | GIL_RELEASE(); 1579 | 1580 | ___return(dst); 1581 | 1582 | ")) 1583 | 1584 | (define scheme object->SchemeObject) 1585 | 1586 | (define SchemeObject? 1587 | (c-lambda (PyObject*) bool " 1588 | 1589 | PyObject* src = ___arg1; 1590 | ___BOOL result; 1591 | 1592 | /* call to GIL_ACQUIRE() not needed here */ 1593 | 1594 | result = (Py_TYPE(src) == _SchemeObject_cls); 1595 | 1596 | /* call to GIL_RELEASE() not needed here */ 1597 | 1598 | ___return(result); 1599 | 1600 | ")) 1601 | 1602 | (define SchemeObject->object 1603 | (c-lambda (PyObject*/SchemeObject) scheme-object " 1604 | 1605 | PyObject *src = ___arg1; 1606 | ___SCMOBJ dst; 1607 | 1608 | GIL_ACQUIRE(); 1609 | 1610 | PyObject *capsule = PyObject_GetAttrString(src, \"obj_capsule\"); 1611 | void *rc = PyCapsule_GetPointer(capsule, NULL); 1612 | 1613 | PYOBJECTPTR_DECREF(capsule, \"SchemeObject->object\"); 1614 | 1615 | dst = ___EXT(___data_rc)(rc); 1616 | 1617 | GIL_RELEASE(); 1618 | 1619 | ___return(dst); 1620 | 1621 | ")) 1622 | 1623 | (define (procedure->PyObject*/function proc) 1624 | (PyCell_Get (python-SchemeProcedure (object->SchemeObject proc)))) 1625 | 1626 | (define (PyObject*/list->vector src) 1627 | (or ((c-lambda (PyObject*/list) scheme-object " 1628 | 1629 | PyObjectPtr src = ___arg1; 1630 | Py_ssize_t len; 1631 | ___SCMOBJ dst; 1632 | 1633 | GIL_ACQUIRE(); 1634 | 1635 | len = PyList_GET_SIZE(src); 1636 | 1637 | dst = ___EXT(___make_vector) (___PSTATE, len, ___FIX(0)); 1638 | 1639 | if (___FIXNUMP(dst)) { 1640 | dst = ___FAL; 1641 | } else { 1642 | Py_ssize_t i; 1643 | for (i=0; ivector conversion error"))) 1664 | 1665 | (define vector->PyObject*/list 1666 | (c-lambda (scheme-object) PyObject*/list " 1667 | 1668 | ___SCMOBJ src = ___arg1; 1669 | PyObjectPtr dst; 1670 | 1671 | ___SCMOBJ ___temp; // used by ___VECTORP 1672 | 1673 | GIL_ACQUIRE(); 1674 | 1675 | if (!___VECTORP(src)) { 1676 | dst = NULL; 1677 | } else { 1678 | Py_ssize_t len = ___INT(___VECTORLENGTH(src)); 1679 | dst = PyList_New(len); 1680 | if (dst != NULL) { 1681 | Py_ssize_t i; 1682 | for (i=0; iPyObject*/list\"); 1688 | PyList_SET_ITEM(dst, i, ___CAST(PyObjectPtr,item_py)); 1689 | } else { 1690 | PYOBJECTPTR_DECREF(dst, \"vector->PyObject*/list\"); 1691 | dst = NULL; 1692 | break; 1693 | } 1694 | } 1695 | PYOBJECTPTR_REFCNT_SHOW(dst, \"vector->PyObject*/list\"); 1696 | } 1697 | } 1698 | 1699 | GIL_RELEASE(); 1700 | 1701 | ___return(dst); 1702 | 1703 | ")) 1704 | 1705 | (define (PyObject*/tuple->vector src) 1706 | (or ((c-lambda (PyObject*/tuple) scheme-object " 1707 | 1708 | PyObjectPtr src = ___arg1; 1709 | Py_ssize_t len; 1710 | ___SCMOBJ dst; 1711 | 1712 | GIL_ACQUIRE(); 1713 | 1714 | len = PyTuple_GET_SIZE(src); 1715 | 1716 | dst = ___EXT(___make_vector) (___PSTATE, len, ___FIX(0)); 1717 | 1718 | if (___FIXNUMP(dst)) { 1719 | dst = ___FAL; 1720 | } else { 1721 | Py_ssize_t i; 1722 | for (i=0; ivector conversion error"))) 1745 | 1746 | (define (PyObject*/list->list src) 1747 | (vector->list (PyObject*/list->vector src))) 1748 | 1749 | (define (list->PyObject*/list src) 1750 | (vector->PyObject*/list (list->vector src))) 1751 | 1752 | (define (vector->PyObject*/tuple vect) 1753 | (vector->PyObject*/tuple-aux vect)) 1754 | 1755 | (define vector->PyObject*/tuple-aux 1756 | (c-lambda (scheme-object) PyObject*/tuple " 1757 | 1758 | ___SCMOBJ src = ___arg1; 1759 | PyObjectPtr dst; 1760 | 1761 | ___SCMOBJ ___temp; // used by ___VECTORP 1762 | 1763 | GIL_ACQUIRE(); 1764 | 1765 | if (!___VECTORP(src)) { 1766 | dst = NULL; 1767 | } else { 1768 | Py_ssize_t len = ___INT(___VECTORLENGTH(src)); 1769 | dst = PyTuple_New(len); 1770 | if (dst != NULL) { 1771 | Py_ssize_t i; 1772 | for (i=0; iPyObject*/tuple\"); 1778 | PyTuple_SET_ITEM(dst, i, ___CAST(PyObjectPtr,item_py)); 1779 | } else { 1780 | PYOBJECTPTR_DECREF(dst, \"vector->PyObject*/tuple\"); 1781 | dst = NULL; 1782 | break; 1783 | } 1784 | } 1785 | PYOBJECTPTR_REFCNT_SHOW(dst, \"vector->PyObject*/tuple\"); 1786 | } 1787 | } 1788 | 1789 | GIL_RELEASE(); 1790 | 1791 | ___return(dst); 1792 | 1793 | ")) 1794 | 1795 | (define (PyObject*/tuple->list src) 1796 | (vector->list (PyObject*/tuple->vector src))) 1797 | 1798 | (define (list->PyObject*/tuple src) 1799 | (vector->PyObject*/tuple (list->vector src))) 1800 | 1801 | (define (PyObject*/bytes->u8vector src) 1802 | (or ((c-lambda (PyObject*/bytes) scheme-object " 1803 | 1804 | PyObjectPtr src = ___arg1; 1805 | Py_ssize_t len; 1806 | ___SCMOBJ dst; 1807 | 1808 | GIL_ACQUIRE(); 1809 | 1810 | len = PyBytes_GET_SIZE(src); 1811 | 1812 | dst = ___EXT(___alloc_scmobj) (___PSTATE, ___sU8VECTOR, len); 1813 | 1814 | if (___FIXNUMP(dst)) { 1815 | dst = ___FAL; 1816 | } else { 1817 | memmove(___BODY_AS(dst,___tSUBTYPED), PyBytes_AS_STRING(src), len); 1818 | } 1819 | 1820 | GIL_RELEASE(); 1821 | 1822 | ___return(___EXT(___release_scmobj) (dst)); 1823 | 1824 | ") 1825 | src) 1826 | (error "PyObject*/bytes->u8vector conversion error"))) 1827 | 1828 | (define u8vector->PyObject*/bytes 1829 | (c-lambda (scheme-object) PyObject*/bytes " 1830 | 1831 | ___SCMOBJ src = ___arg1; 1832 | PyObjectPtr dst; 1833 | 1834 | ___SCMOBJ ___temp; // used by ___U8VECTORP 1835 | 1836 | GIL_ACQUIRE(); 1837 | 1838 | if (!___U8VECTORP(src)) { 1839 | dst = NULL; 1840 | } else { 1841 | Py_ssize_t len = ___INT(___U8VECTORLENGTH(src)); 1842 | dst = PyBytes_FromStringAndSize( 1843 | ___CAST(char*,___BODY_AS(src,___tSUBTYPED)), 1844 | len); 1845 | PYOBJECTPTR_REFCNT_SHOW(dst, \"u8vector->PyObject*/bytes\"); 1846 | } 1847 | 1848 | GIL_RELEASE(); 1849 | 1850 | ___return(dst); 1851 | 1852 | ")) 1853 | 1854 | (define s8vector->PyObject*/bytes 1855 | (c-lambda (scheme-object) PyObject*/bytes " 1856 | 1857 | ___SCMOBJ src = ___arg1; 1858 | PyObjectPtr dst; 1859 | 1860 | ___SCMOBJ ___temp; // used by ___S8VECTORP 1861 | 1862 | GIL_ACQUIRE(); 1863 | 1864 | if (!___S8VECTORP(src)) { 1865 | dst = NULL; 1866 | } else { 1867 | Py_ssize_t len = ___INT(___S8VECTORLENGTH(src)); 1868 | dst = PyBytes_FromStringAndSize( 1869 | ___CAST(char*,___BODY_AS(src,___tSUBTYPED)), 1870 | len); 1871 | PYOBJECTPTR_REFCNT_SHOW(dst, \"u8vector->PyObject*/bytes\"); 1872 | } 1873 | 1874 | GIL_RELEASE(); 1875 | 1876 | ___return(dst); 1877 | 1878 | ")) 1879 | 1880 | (define (PyObject*/bytearray->u8vector src) 1881 | (or ((c-lambda (PyObject*/bytearray) scheme-object " 1882 | 1883 | PyObjectPtr src = ___arg1; 1884 | Py_ssize_t len; 1885 | ___SCMOBJ dst; 1886 | 1887 | GIL_ACQUIRE(); 1888 | 1889 | len = PyByteArray_GET_SIZE(src); 1890 | 1891 | dst = ___EXT(___alloc_scmobj) (___PSTATE, ___sU8VECTOR, len); 1892 | 1893 | if (___FIXNUMP(dst)) { 1894 | dst = ___FAL; 1895 | } else { 1896 | memmove(___BODY_AS(dst,___tSUBTYPED), PyByteArray_AS_STRING(src), len); 1897 | } 1898 | 1899 | GIL_RELEASE(); 1900 | 1901 | ___return(___EXT(___release_scmobj) (dst)); 1902 | 1903 | ") 1904 | src) 1905 | (error "PyObject*/bytearray->u8vector conversion error"))) 1906 | 1907 | (define u8vector->PyObject*/bytearray 1908 | (c-lambda (scheme-object) PyObject*/bytearray " 1909 | 1910 | ___SCMOBJ src = ___arg1; 1911 | PyObjectPtr dst; 1912 | 1913 | ___SCMOBJ ___temp; // used by ___U8VECTORP 1914 | 1915 | GIL_ACQUIRE(); 1916 | 1917 | if (!___U8VECTORP(src)) { 1918 | dst = NULL; 1919 | } else { 1920 | Py_ssize_t len = ___INT(___U8VECTORLENGTH(src)); 1921 | dst = PyByteArray_FromStringAndSize( 1922 | ___CAST(char*,___BODY_AS(src,___tSUBTYPED)), 1923 | len); 1924 | PYOBJECTPTR_REFCNT_SHOW(dst, \"u8vector->PyObject*/bytearray\"); 1925 | } 1926 | 1927 | GIL_RELEASE(); 1928 | 1929 | ___return(dst); 1930 | 1931 | ")) 1932 | 1933 | ;;;---------------------------------------------------------------------------- 1934 | 1935 | ;; Generic converters. 1936 | 1937 | (define (PyObject*->object src) 1938 | 1939 | (define (conv src) 1940 | (case (car (##foreign-tags src)) 1941 | ((PyObject*/None) (PyObject*/None->void src)) 1942 | ((PyObject*/bool) (PyObject*/bool->boolean src)) 1943 | ((PyObject*/int) (PyObject*/int->exact-integer src)) 1944 | ((PyObject*/float) (PyObject*/float->flonum src)) 1945 | ((PyObject*/complex) (PyObject*/complex->cpxnum src)) 1946 | ((PyObject*/Fraction) (PyObject*/Fraction->ratnum src)) 1947 | ((PyObject*/str) (PyObject*/str->string src)) 1948 | ((PyObject*/bytes) (PyObject*/bytes->u8vector src)) 1949 | ((PyObject*/bytearray) (PyObject*/bytearray->u8vector src)) 1950 | ((PyObject*/list) (list-conv src)) 1951 | ((PyObject*/tuple) (vector-conv src)) 1952 | ((PyObject*/dict) (table-conv src)) 1953 | ((PyObject*/function 1954 | PyObject*/builtin_function_or_method 1955 | PyObject*/method 1956 | PyObject*/method_descriptor) (procedure-conv src)) 1957 | ((PyObject*/cell) (PyCell_Get src)) 1958 | (else 1959 | (cond ((= 1 (PyCallable_Check src)) (procedure-conv src)) 1960 | ((SchemeObject? src) (SchemeObject->object src)) 1961 | (else src))))) 1962 | 1963 | (define (list-conv src) 1964 | (let* ((vect (PyObject*/list->vector src)) 1965 | (len (vector-length vect))) 1966 | (let loop ((i (fx- len 1)) (lst '())) 1967 | (if (fx< i 0) 1968 | lst 1969 | (loop (fx- i 1) 1970 | (cons (conv (vector-ref vect i)) 1971 | lst)))))) 1972 | 1973 | (define (vector-conv src) 1974 | (let ((vect (PyObject*/tuple->vector src))) 1975 | (let loop ((i (fx- (vector-length vect) 1))) 1976 | (if (fx< i 0) 1977 | vect 1978 | (begin 1979 | (vector-set! vect i (conv (vector-ref vect i))) 1980 | (loop (fx- i 1))))))) 1981 | 1982 | (define (table-conv src) 1983 | (let ((table (make-table))) 1984 | (for-each (lambda (key) 1985 | (let ((val (PyDict_GetItem src key))) 1986 | (table-set! table 1987 | (PyObject*->object key) 1988 | (PyObject*->object val)))) 1989 | (PyObject*/list->list (PyDict_Keys src))) 1990 | table)) 1991 | 1992 | ;; TODO: Handle **kwargs 1993 | (define (procedure-conv callable) 1994 | (define (valid-kw? rest) 1995 | (and (pair? rest) 1996 | (not (keyword? (car rest))))) 1997 | (lambda (#!optional 1998 | (arg1 (macro-absent-obj)) 1999 | (arg2 (macro-absent-obj)) 2000 | (arg3 (macro-absent-obj)) 2001 | #!rest 2002 | other) 2003 | 2004 | (define (generic args) 2005 | (let loop ((args args) (*args '()) (kw-keys '()) (kw-vals '())) 2006 | (if (pair? args) 2007 | (let ((arg (car args)) 2008 | (rest (cdr args))) 2009 | (if (keyword? arg) 2010 | (if (valid-kw? rest) 2011 | (loop (cdr rest) 2012 | *args 2013 | (cons (keyword->string arg) kw-keys) 2014 | (cons (car rest) kw-vals)) 2015 | (error "Keyword argument has no value" args)) 2016 | (loop rest (cons arg *args) kw-keys kw-vals))) 2017 | (if (null? kw-keys) 2018 | (sfpc-call callable (list->vector (reverse *args))) 2019 | (sfpc-call-with-kw callable (list->vector (reverse *args)) kw-keys kw-vals))))) 2020 | 2021 | (cond ((eq? arg1 (macro-absent-obj)) 2022 | (sfpc-call callable '#())) 2023 | ((keyword? arg1) 2024 | (cond ((eq? arg2 (macro-absent-obj)) 2025 | (generic (list arg1))) 2026 | ((eq? arg3 (macro-absent-obj)) 2027 | (generic (list arg1 arg2))) 2028 | (else 2029 | (generic (cons arg1 (cons arg2 (cons arg3 other))))))) 2030 | ((eq? arg2 (macro-absent-obj)) 2031 | (sfpc-call callable (vector arg1))) 2032 | ((keyword? arg2) 2033 | (cond ((eq? arg3 (macro-absent-obj)) 2034 | (generic (list arg1 arg2))) 2035 | (else 2036 | (generic (cons arg1 (cons arg2 (cons arg3 other))))))) 2037 | ((eq? arg3 (macro-absent-obj)) 2038 | (sfpc-call callable (vector arg1 arg2))) 2039 | ((keyword? arg3) 2040 | (generic (cons arg1 (cons arg2 (cons arg3 other))))) 2041 | ((null? other) 2042 | (sfpc-call callable (vector arg1 arg2 arg3))) 2043 | (else 2044 | (generic (cons arg1 (cons arg2 (cons arg3 other)))))))) 2045 | 2046 | (if (##foreign? src) 2047 | (conv src) 2048 | src)) 2049 | 2050 | (define (PyObject*-or-subtype? tag) 2051 | (case tag 2052 | ((PyObject* 2053 | PyObject*/None 2054 | PyObject*/bool 2055 | PyObject*/int 2056 | PyObject*/float 2057 | PyObject*/complex 2058 | PyObject*/Fraction 2059 | PyObject*/bytes 2060 | PyObject*/bytearray 2061 | PyObject*/str 2062 | PyObject*/list 2063 | PyObject*/dict 2064 | PyObject*/frozenset 2065 | PyObject*/set 2066 | PyObject*/tuple 2067 | PyObject*/module 2068 | PyObject*/type 2069 | PyObject*/function 2070 | PyObject*/builtin_function_or_method 2071 | PyObject*/method 2072 | PyObject*/method_descriptor 2073 | PyObject*/cell 2074 | PyObject*/SchemeObject) 2075 | #t) 2076 | (else 2077 | #f))) 2078 | 2079 | (define (object->PyObject* src) 2080 | 2081 | (define (conv src) 2082 | (cond ((eq? src (void)) (void->PyObject*/None src)) 2083 | ((boolean? src) (boolean->PyObject*/bool src)) 2084 | ((exact-integer? src) (exact-integer->PyObject*/int src)) 2085 | ((flonum? src) (flonum->PyObject*/float src)) 2086 | ((##cpxnum? src) (flonums->PyObject*/complex 2087 | (##inexact (##cpxnum-real src)) 2088 | (##inexact (##cpxnum-imag src)))) 2089 | ((##ratnum? src) (ints->PyObject*/Fraction 2090 | (object->PyObject* (##numerator src)) 2091 | (object->PyObject* (##denominator src)))) 2092 | ((string? src) (string->PyObject*/str src)) 2093 | ((char? src) (exact-integer->PyObject*/int (char->integer src))) 2094 | ((u8vector? src) (u8vector->PyObject*/bytes src)) 2095 | ((s8vector? src) (s8vector->PyObject*/bytes src)) 2096 | ((or (null? src) (pair? src)) (list-conv src)) 2097 | ((vector? src) (vector-conv src)) 2098 | ((table? src) (table-conv src)) 2099 | ((symbol? src) (string->PyObject*/str (symbol->string src))) 2100 | ((and (##foreign? src) 2101 | (PyObject*-or-subtype? 2102 | (car (##foreign-tags src)))) 2103 | src) 2104 | ((procedure? src) (procedure->PyObject*/function src)) 2105 | (else 2106 | (error "can't convert" src)))) 2107 | 2108 | (define (list-conv src) 2109 | (let loop1 ((probe src) (len 0)) 2110 | (if (pair? probe) 2111 | (loop1 (cdr probe) (fx+ len 1)) 2112 | (let ((vect 2113 | (if (null? probe) 2114 | (make-vector len) 2115 | (make-vector (fx+ len 1) (conv probe))))) 2116 | (let loop2 ((probe src) (i 0)) 2117 | (if (and (pair? probe) (fx< i (vector-length vect))) 2118 | (begin 2119 | (vector-set! vect i (conv (car probe))) 2120 | (loop2 (cdr probe) (fx+ i 1))) 2121 | (vector->PyObject*/list vect))))))) 2122 | 2123 | (define (vector-conv src) 2124 | (let* ((len (vector-length src)) 2125 | (vect (make-vector len))) 2126 | (let loop ((i (fx- len 1))) 2127 | (if (fx< i 0) 2128 | (vector->PyObject*/tuple vect) 2129 | (begin 2130 | (vector-set! vect i (conv (vector-ref src i))) 2131 | (loop (fx- i 1))))))) 2132 | 2133 | (define (u8vector-conv src) 2134 | (let* ((len (vector-length src)) 2135 | (vect (make-vector len))) 2136 | (let loop ((i (fx- len 1))) 2137 | (if (fx< i 0) 2138 | (vector->PyObject*/tuple vect) 2139 | (begin 2140 | (vector-set! vect i (conv (vector-ref src i))) 2141 | (loop (fx- i 1))))))) 2142 | 2143 | (define (table-conv src) 2144 | (let ((dst (PyDict_New))) 2145 | (table-for-each 2146 | (lambda (key val) 2147 | (PyDict_SetItem dst 2148 | (object->PyObject* key) 2149 | (object->PyObject* val))) 2150 | src) 2151 | dst)) 2152 | 2153 | (conv src)) 2154 | 2155 | ;;;---------------------------------------------------------------------------- 2156 | 2157 | ;; TODO: get rid of this by improving Gambit C interface. 2158 | 2159 | (define dummy 2160 | (list 2161 | (c-lambda () _PyObject* "___return(NULL);") 2162 | (c-lambda () _PyObject*/None "___return(NULL);") 2163 | (c-lambda () _PyObject*/bool "___return(NULL);") 2164 | (c-lambda () _PyObject*/int "___return(NULL);") 2165 | (c-lambda () _PyObject*/float "___return(NULL);") 2166 | (c-lambda () _PyObject*/complex "___return(NULL);") 2167 | (c-lambda () _PyObject*/Fraction "___return(NULL);") 2168 | (c-lambda () _PyObject*/bytes "___return(NULL);") 2169 | (c-lambda () _PyObject*/bytearray "___return(NULL);") 2170 | (c-lambda () _PyObject*/str "___return(NULL);") 2171 | (c-lambda () _PyObject*/list "___return(NULL);") 2172 | (c-lambda () _PyObject*/dict "___return(NULL);") 2173 | (c-lambda () _PyObject*/frozenset "___return(NULL);") 2174 | (c-lambda () _PyObject*/set "___return(NULL);") 2175 | (c-lambda () _PyObject*/tuple "___return(NULL);") 2176 | (c-lambda () _PyObject*/module "___return(NULL);") 2177 | (c-lambda () _PyObject*/type "___return(NULL);") 2178 | (c-lambda () _PyObject*/function "___return(NULL);") 2179 | (c-lambda () _PyObject*/builtin_function_or_method "___return(NULL);") 2180 | (c-lambda () _PyObject*/method "___return(NULL);") 2181 | (c-lambda () _PyObject*/method_descriptor "___return(NULL);") 2182 | (c-lambda () _PyObject*/cell "___return(NULL);") 2183 | (c-lambda () _PyObject*/SchemeObject "___return(NULL);"))) 2184 | 2185 | ;;;---------------------------------------------------------------------------- 2186 | 2187 | ;; Call Python callables from Scheme. 2188 | 2189 | (define (PyObject_CallFunctionObjArgs callable . args) 2190 | (PyObject_CallFunctionObjArgs* callable args)) 2191 | 2192 | ;; TODO: Handle **kwargs in Python call 2193 | (define (PyObject_CallFunctionObjArgs* callable args) 2194 | (if (not (pair? args)) 2195 | (PyObject_CallFunctionObjArgs0 callable) 2196 | (let ((arg1 (car args)) 2197 | (rest (cdr args))) 2198 | (if (not (pair? rest)) 2199 | (PyObject_CallFunctionObjArgs1 callable arg1) 2200 | (let ((arg2 (car rest)) 2201 | (rest (cdr rest))) 2202 | (if (not (pair? rest)) 2203 | (PyObject_CallFunctionObjArgs2 callable arg1 arg2) 2204 | (let ((arg3 (car rest)) 2205 | (rest (cdr rest))) 2206 | (if (not (pair? rest)) 2207 | (PyObject_CallFunctionObjArgs3 callable arg1 arg2 arg3) 2208 | (let ((arg4 (car rest)) 2209 | (rest (cdr rest))) 2210 | (if (not (pair? rest)) 2211 | (PyObject_CallFunctionObjArgs4 callable arg1 arg2 arg3 arg4) 2212 | (PyObject_CallObject 2213 | callable 2214 | (list->PyObject*/tuple args)))))))))))) 2215 | 2216 | (define PyObject_CallFunctionObjArgs0 2217 | (c-lambda (PyObject*) PyObject* " 2218 | 2219 | return_with_check_PyObjectPtr(PyObject_CallFunctionObjArgs(___arg1, NULL)); 2220 | 2221 | ")) 2222 | 2223 | (define PyObject_CallFunctionObjArgs1 2224 | (c-lambda (PyObject* PyObject*) PyObject* " 2225 | 2226 | return_with_check_PyObjectPtr(PyObject_CallFunctionObjArgs(___arg1, ___arg2, NULL)); 2227 | 2228 | ")) 2229 | 2230 | (define PyObject_CallFunctionObjArgs2 2231 | (c-lambda (PyObject* PyObject* PyObject*) PyObject* " 2232 | 2233 | return_with_check_PyObjectPtr(PyObject_CallFunctionObjArgs(___arg1, ___arg2, ___arg3, NULL)); 2234 | 2235 | ")) 2236 | 2237 | (define PyObject_CallFunctionObjArgs3 2238 | (c-lambda (PyObject* PyObject* PyObject* PyObject*) PyObject* " 2239 | 2240 | return_with_check_PyObjectPtr(PyObject_CallFunctionObjArgs(___arg1, ___arg2, ___arg3, ___arg4, NULL)); 2241 | 2242 | ")) 2243 | 2244 | (define PyObject_CallFunctionObjArgs4 2245 | (c-lambda (PyObject* PyObject* PyObject* PyObject* PyObject*) PyObject* " 2246 | 2247 | return_with_check_PyObjectPtr(PyObject_CallFunctionObjArgs(___arg1, ___arg2, ___arg3, ___arg4, ___arg5, NULL)); 2248 | 2249 | ")) 2250 | 2251 | ;;;---------------------------------------------------------------------------- 2252 | 2253 | ;; Foreign procedure call implementation. 2254 | 2255 | (c-declare #< 2259 | 2260 | 2261 | /* converters */ 2262 | 2263 | ___SCMOBJ convert_from_python(PyObject *val) { 2264 | 2265 | ___SCMOBJ result; 2266 | 2267 | #ifdef DEBUG_LOWLEVEL 2268 | printf("convert_from_python() enter\n"); 2269 | #endif 2270 | 2271 | GIL_ACQUIRE(); 2272 | 2273 | ___SCMOBJ err = PYOBJECTPTR_to_SCMOBJ(val, &result, ___RETURN_POS); 2274 | 2275 | if (err != ___FIX(___NO_ERR)) { 2276 | printf("could not convert PyObject* to SCMOBJ\n"); 2277 | exit(1); /* TODO: better error handling! */ 2278 | } 2279 | 2280 | #ifdef DEBUG_LOWLEVEL 2281 | printf("convert_from_python() exit\n"); 2282 | #endif 2283 | 2284 | GIL_RELEASE(); 2285 | 2286 | return result; 2287 | } 2288 | 2289 | PyObject *convert_to_python(___SCMOBJ val) { 2290 | 2291 | void *ptr; 2292 | PyObject *result; 2293 | 2294 | #ifdef DEBUG_LOWLEVEL 2295 | printf("convert_to_python() enter\n"); 2296 | #endif 2297 | 2298 | GIL_ACQUIRE(); 2299 | 2300 | ___SCMOBJ err = SCMOBJ_to_PYOBJECTPTR(val, &ptr, ___RETURN_POS); 2301 | 2302 | if (err != ___FIX(___NO_ERR)) { 2303 | printf("could not convert SCMOBJ to PyObject*\n"); 2304 | exit(1); /* TODO: better error handling! */ 2305 | } 2306 | 2307 | result = ptr; 2308 | 2309 | PYOBJECTPTR_REFCNT_SHOW(result, "convert_to_python"); 2310 | 2311 | #ifdef DEBUG_LOWLEVEL 2312 | printf("convert_to_python() exit\n"); 2313 | #endif 2314 | 2315 | GIL_RELEASE(); 2316 | 2317 | return result; 2318 | } 2319 | 2320 | 2321 | typedef struct fpc_state_struct 2322 | { 2323 | ___procedural_interrupt_header header; /* used as a procedural interrupt */ 2324 | ___processor_state pstate; /* Gambit processor */ 2325 | PyObject *message; /* inter-realm message */ 2326 | PyObject *capsule; /* Python ref to this fpc_state */ 2327 | ___MUTEX_DECL(wait_mut); /* for waiting for peer's message */ 2328 | ___thread python_thread; /* OS thread that runs Python code */ 2329 | } fpc_state; 2330 | 2331 | 2332 | const char *python_code = "\ 2333 | \n\ 2334 | _sys = __import__(\"sys\")\n\ 2335 | _threading = __import__(\"threading\")\n\ 2336 | _pfpc = __import__(\"pfpc\")\n\ 2337 | _fractions = __import__(\"fractions\")\n\ 2338 | _empty_dict = dict()\n\ 2339 | \n\ 2340 | def _pfpc_get_fpc_state():\n\ 2341 | ct = _threading.current_thread()\n\ 2342 | if not hasattr(ct, \"_fpc_state\"):\n\ 2343 | ct._fpc_state = _pfpc.start_buddy()\n\ 2344 | _pfpc_loop(ct._fpc_state) # wait for buddy thread to be started\n\ 2345 | return ct._fpc_state\n\ 2346 | \n\ 2347 | _pfpc_send = _pfpc.send\n\ 2348 | _pfpc_recv = _pfpc.recv\n\ 2349 | \n\ 2350 | #_op_return = 'return'\n\ 2351 | #_op_call = 'call'\n\ 2352 | #_op_raise = 'raise'\n\ 2353 | #_op_error = 'error'\n\ 2354 | #_op_get_eval = 'get-eval'\n\ 2355 | #_op_get_exec = 'get-exec'\n\ 2356 | #_op_terminate = 'terminate'\n\ 2357 | \n\ 2358 | _op_return = 0\n\ 2359 | _op_call = 1\n\ 2360 | _op_raise = 2\n\ 2361 | _op_error = 3\n\ 2362 | _op_get_eval = 4\n\ 2363 | _op_get_exec = 5\n\ 2364 | _op_terminate = 6\n\ 2365 | \n\ 2366 | def _pfpc_loop(fpc_state):\n\ 2367 | while True:\n\ 2368 | message = _pfpc_recv(fpc_state)\n\ 2369 | # print(\"pfpc_loop message =\", repr(message))\n\ 2370 | op = message[0]\n\ 2371 | if op == _op_call:\n\ 2372 | try:\n\ 2373 | if len(message) > 3:\n\ 2374 | message = (_op_return, message[1](*message[2], **dict(zip(message[3], message[4]))))\n\ 2375 | else:\n\ 2376 | message = (_op_return, message[1](*message[2]))\n\ 2377 | except BaseException as exc:\n\ 2378 | message = (_op_raise, exc, repr(exc))\n\ 2379 | elif op == _op_return:\n\ 2380 | return message[1]\n\ 2381 | elif op == _op_raise:\n\ 2382 | raise message[1]\n\ 2383 | elif op == _op_get_eval:\n\ 2384 | message = (_op_return, lambda e: eval(e, globals()))\n\ 2385 | elif op == _op_get_exec:\n\ 2386 | message = (_op_return, lambda e: exec(e, globals()))\n\ 2387 | elif op == _op_terminate:\n\ 2388 | _sys.exit()\n\ 2389 | else:\n\ 2390 | message = (_op_error, op)\n\ 2391 | _pfpc_send(fpc_state, message)\n\ 2392 | message = None\n\ 2393 | \n\ 2394 | def _pfpc_call(fn, args, kw_keys, kw_vals):\n\ 2395 | fpc_state = _pfpc_get_fpc_state()\n\ 2396 | _pfpc_send(fpc_state, (_op_call, fn, args, kw_keys, kw_vals))\n\ 2397 | return _pfpc_loop(fpc_state)\n\ 2398 | \n\ 2399 | def _pfpc_start(fpc_state):\n\ 2400 | _threading.current_thread()._fpc_state = fpc_state\n\ 2401 | _pfpc_loop(fpc_state)\n\ 2402 | \n\ 2403 | def _SchemeProcedure(scheme_proc):\n\ 2404 | def fun(*args, **kwargs):\n\ 2405 | kw_keys = list(kwargs.keys())\n\ 2406 | kw_vals = list(kwargs.values())\n\ 2407 | return _pfpc_call(scheme_proc, args, kw_keys, kw_vals)\n\ 2408 | return foreign(fun)\n\ 2409 | \n\ 2410 | foreign = lambda x: (lambda:x).__closure__[0]\n\ 2411 | \n\ 2412 | class _SchemeObject(BaseException):\n\ 2413 | def __init__(self, obj_capsule):\n\ 2414 | self.obj_capsule = obj_capsule\n\ 2415 | def __del__(self):\n\ 2416 | _pfpc.free(self.obj_capsule)\n\ 2417 | \n\ 2418 | def set_global(k, v):\n\ 2419 | globals()[k] = v\n\ 2420 | \n\ 2421 | "; 2422 | 2423 | 2424 | void python_thread_main(___thread *self) { 2425 | 2426 | /* TODO: add error checking */ 2427 | 2428 | fpc_state *python_fpc_state = ___CAST(fpc_state*, self->data_ptr); 2429 | 2430 | GIL_ACQUIRE(); 2431 | 2432 | PyObject *m = PyImport_AddModule("__main__"); 2433 | PyObject *v = PyObject_GetAttrString(m, "_pfpc_start"); 2434 | 2435 | PyObject_CallFunctionObjArgs(v, python_fpc_state->capsule, NULL); /* call _pfpc_start */ 2436 | 2437 | GIL_RELEASE(); 2438 | } 2439 | 2440 | 2441 | ___SCMOBJ procedural_interrupt_execute_fn(void *self, ___SCMOBJ op) { 2442 | 2443 | #ifdef DEBUG_LOWLEVEL 2444 | printf("procedural_interrupt_execute_fn() enter\n"); 2445 | #endif 2446 | 2447 | if (op != ___FAL) { 2448 | 2449 | fpc_state *python_fpc_state = ___CAST(fpc_state*, self); 2450 | 2451 | ___SCMOBJ scheme_fpc_state = 2452 | ___EXT(___data_rc)(___CAST(void*,python_fpc_state)); 2453 | 2454 | if (scheme_fpc_state == ___FAL) { 2455 | 2456 | ___processor_state ___ps = python_fpc_state->pstate; /* same as ___PSTATE */ 2457 | ___SCMOBJ python_fpc_state_scmobj; 2458 | 2459 | scheme_fpc_state = ___EXT(___make_vector)(___ps, 4, ___NUL); 2460 | 2461 | if (___FIXNUMP(scheme_fpc_state)) { 2462 | printf("heap overflow\n"); 2463 | exit(1); /* TODO: better error handling! */ 2464 | } 2465 | 2466 | ___EXT(___set_data_rc)(python_fpc_state, scheme_fpc_state); 2467 | 2468 | ___EXT(___register_rc)(___PSP python_fpc_state); 2469 | 2470 | ___VECTORELEM(scheme_fpc_state, 1) = ___GLO__23__23_start_2d_buddy; 2471 | 2472 | if (___EXT(___POINTER_to_SCMOBJ)(___ps, 2473 | ___CAST(void*,python_fpc_state), 2474 | ___C_TAG_fpc__state_2a_, 2475 | ___RELEASE_POINTER, 2476 | &python_fpc_state_scmobj, 2477 | ___RETURN_POS) 2478 | != ___FIX(___NO_ERR)) { 2479 | printf("could not convert python_fpc_state to foreign\n"); 2480 | exit(1); /* TODO: better error handling! */ 2481 | } 2482 | 2483 | ___VECTORELEM(scheme_fpc_state, 3) = python_fpc_state_scmobj; 2484 | 2485 | #if 0 2486 | ___EXT(___release_scmobj)(python_fpc_state_scmobj); 2487 | #endif 2488 | } 2489 | 2490 | #ifdef DEBUG_LOWLEVEL 2491 | printf("procedural_interrupt_execute_fn() calling ___raise_high_level_interrupt_pstate\n"); 2492 | #endif 2493 | 2494 | ___EXT(___raise_high_level_interrupt_pstate)(python_fpc_state->pstate, 2495 | scheme_fpc_state); 2496 | } 2497 | 2498 | #ifdef DEBUG_LOWLEVEL 2499 | printf("procedural_interrupt_execute_fn() exit\n"); 2500 | #endif 2501 | 2502 | return ___FIX(___NO_ERR); 2503 | } 2504 | 2505 | 2506 | fpc_state *alloc_python_fpc_state(___processor_state ___ps) { 2507 | 2508 | PyObject *capsule; 2509 | 2510 | fpc_state *python_fpc_state = ___EXT(___alloc_rc_no_register)(sizeof(fpc_state)); 2511 | 2512 | if (python_fpc_state == NULL) { 2513 | printf("could not allocate python_fpc_state\n"); 2514 | exit(1); /* TODO: better error handling! */ 2515 | } 2516 | 2517 | ___EXT(___init_procedural_interrupt)(___CAST(void*, python_fpc_state), 2518 | procedural_interrupt_execute_fn); 2519 | 2520 | python_fpc_state->pstate = ___ps; 2521 | 2522 | GIL_ACQUIRE(); 2523 | 2524 | capsule = PyCapsule_New(python_fpc_state, NULL, NULL); 2525 | 2526 | GIL_RELEASE(); 2527 | 2528 | if (capsule == NULL) { 2529 | printf("could not allocate capsule\n"); 2530 | ___EXT(___release_rc)(python_fpc_state); 2531 | exit(1); /* TODO: better error handling! */ 2532 | } 2533 | 2534 | PYOBJECTPTR_REFCNT_SHOW(capsule, "alloc_python_fpc_state"); 2535 | 2536 | python_fpc_state->capsule = capsule; 2537 | 2538 | #ifdef DEBUG_LOWLEVEL 2539 | printf("alloc_python_fpc_state() calling ___MUTEX_LOCK(python_fpc_state->wait_mut);\n"); 2540 | #endif 2541 | 2542 | ___MUTEX_INIT(python_fpc_state->wait_mut); 2543 | ___MUTEX_LOCK(python_fpc_state->wait_mut); 2544 | 2545 | python_fpc_state->python_thread.data_ptr = ___CAST(void*, python_fpc_state); 2546 | 2547 | return python_fpc_state; 2548 | } 2549 | 2550 | void setup_python_fpc_state(___SCMOBJ scheme_fpc_state) { 2551 | 2552 | ___processor_state ___ps = ___PSTATE; 2553 | fpc_state *python_fpc_state; 2554 | 2555 | #ifdef DEBUG_LOWLEVEL 2556 | printf("setup_python_fpc_state() enter\n"); 2557 | #endif 2558 | 2559 | python_fpc_state = alloc_python_fpc_state(___PSTATE); 2560 | 2561 | ___FOREIGN_PTR_FIELD(___VECTORELEM(scheme_fpc_state, 3)) = ___CAST(___WORD, python_fpc_state); 2562 | 2563 | ___EXT(___set_data_rc)(python_fpc_state, scheme_fpc_state); 2564 | 2565 | ___EXT(___register_rc)(___PSP python_fpc_state); 2566 | 2567 | /* Start the buddy Python thread */ 2568 | 2569 | python_fpc_state->python_thread.start_fn = python_thread_main; 2570 | 2571 | if (___EXT(___thread_create)(&python_fpc_state->python_thread) 2572 | != ___FIX(___NO_ERR)) { 2573 | printf("can't create Python thread (was Gambit configured with --enable-thread-system?)\n"); 2574 | exit(1); /* TODO: better error handling! */ 2575 | } 2576 | 2577 | #ifdef DEBUG_LOWLEVEL 2578 | printf("setup_python_fpc_state() exit\n"); 2579 | #endif 2580 | } 2581 | 2582 | 2583 | void cleanup_python_fpc_state(___SCMOBJ scheme_fpc_state) { 2584 | 2585 | fpc_state *python_fpc_state = 2586 | ___CAST(fpc_state*,___FOREIGN_PTR_FIELD(___VECTORELEM(scheme_fpc_state, 3))); 2587 | 2588 | #ifdef DEBUG_LOWLEVEL 2589 | printf("cleanup_python_fpc_state() enter\n"); 2590 | #endif 2591 | 2592 | if (___EXT(___thread_join)(&python_fpc_state->python_thread) 2593 | != ___FIX(___NO_ERR)) { 2594 | printf("can't join Python thread\n"); 2595 | exit(1); /* TODO: better error handling! */ 2596 | } 2597 | 2598 | #ifdef DEBUG_LOWLEVEL 2599 | printf("cleanup_python_fpc_state() exit\n"); 2600 | #endif 2601 | } 2602 | 2603 | 2604 | void sfpc_send(___SCMOBJ scheme_fpc_state, PyObject *message) { 2605 | 2606 | PYOBJECTPTR_INCREF(message, "sfpc_send"); 2607 | 2608 | fpc_state *python_fpc_state = 2609 | ___CAST(fpc_state*,___FOREIGN_PTR_FIELD(___VECTORELEM(scheme_fpc_state, 3))); 2610 | 2611 | #ifdef DEBUG_LOWLEVEL 2612 | printf("sfpc_send() setting python_fpc_state->message\n"); 2613 | #endif 2614 | 2615 | python_fpc_state->message = message; 2616 | 2617 | #ifdef DEBUG_LOWLEVEL 2618 | printf("sfpc_send() calling ___MUTEX_UNLOCK(python_fpc_state->wait_mut);\n"); 2619 | #endif 2620 | 2621 | ___MUTEX_UNLOCK(python_fpc_state->wait_mut); 2622 | } 2623 | 2624 | 2625 | PyObject *sfpc_recv(___SCMOBJ scheme_fpc_state) { 2626 | 2627 | fpc_state *python_fpc_state = 2628 | ___CAST(fpc_state*,___FOREIGN_PTR_FIELD(___VECTORELEM(scheme_fpc_state, 3))); 2629 | 2630 | #ifdef DEBUG_LOWLEVEL 2631 | PYOBJECTPTR_REFCNT_SHOW(python_fpc_state->message, "sfpc_recv() returning python_fpc_state->message"); 2632 | #endif 2633 | 2634 | return python_fpc_state->message; 2635 | } 2636 | 2637 | 2638 | static PyObject *pfpc_send(PyObject *self, PyObject *args) { 2639 | 2640 | PyObject *capsule; 2641 | PyObject *message; 2642 | PyArg_ParseTuple(args, "OO", &capsule, &message); 2643 | 2644 | PYOBJECTPTR_REFCNT_SHOW(capsule, "pfpc_send"); 2645 | PYOBJECTPTR_REFCNT_SHOW(message, "pfpc_send"); 2646 | 2647 | fpc_state *python_fpc_state = 2648 | ___CAST(fpc_state*, PyCapsule_GetPointer(capsule, NULL)); 2649 | 2650 | #ifdef DEBUG_LOWLEVEL 2651 | printf("pfpc_send() enter\n"); 2652 | #endif 2653 | 2654 | /* send message to Scheme thread */ 2655 | 2656 | #ifdef DEBUG_LOWLEVEL 2657 | printf("pfpc_send() setting python_fpc_state->message\n"); 2658 | #endif 2659 | 2660 | PYOBJECTPTR_INCREF(message, "pfpc_send"); 2661 | 2662 | python_fpc_state->message = message; 2663 | 2664 | #ifdef DEBUG_LOWLEVEL 2665 | printf("pfpc_send() calling ___raise_procedural_interrupt_pstate\n"); 2666 | #endif 2667 | 2668 | ___EXT(___raise_procedural_interrupt_pstate)(python_fpc_state->pstate, 2669 | ___CAST(void*,python_fpc_state)); 2670 | 2671 | #ifdef DEBUG_LOWLEVEL 2672 | printf("pfpc_send() exit\n"); 2673 | #endif 2674 | 2675 | Py_INCREF(Py_None); 2676 | 2677 | return Py_None; 2678 | } 2679 | 2680 | 2681 | static PyObject *pfpc_recv(PyObject *self, PyObject *args) { 2682 | 2683 | PyObject *capsule; 2684 | PyArg_ParseTuple(args, "O", &capsule); 2685 | 2686 | PYOBJECTPTR_REFCNT_SHOW(capsule, "pfpc_recv"); 2687 | 2688 | fpc_state *python_fpc_state = 2689 | ___CAST(fpc_state*, PyCapsule_GetPointer(capsule, NULL)); 2690 | 2691 | #ifdef DEBUG_LOWLEVEL 2692 | printf("pfpc_recv() calling ___MUTEX_LOCK(python_fpc_state->wait_mut);\n"); 2693 | #endif 2694 | 2695 | Py_BEGIN_ALLOW_THREADS 2696 | ___MUTEX_LOCK(python_fpc_state->wait_mut); 2697 | Py_END_ALLOW_THREADS 2698 | 2699 | #ifdef DEBUG_LOWLEVEL 2700 | PYOBJECTPTR_REFCNT_SHOW(python_fpc_state->message, "pfpc_recv() returning python_fpc_state->message"); 2701 | #endif 2702 | 2703 | return python_fpc_state->message; 2704 | } 2705 | 2706 | 2707 | static PyObject *pfpc_free(PyObject *self, PyObject *args) { 2708 | 2709 | PyObject *capsule; 2710 | PyArg_ParseTuple(args, "O", &capsule); 2711 | 2712 | PYOBJECTPTR_REFCNT_SHOW(capsule, "pfpc_free"); 2713 | 2714 | void *ptr = PyCapsule_GetPointer(capsule, NULL); 2715 | 2716 | PYOBJECTPTR_DECREF(capsule, "pfpc_free"); 2717 | 2718 | #ifdef DEBUG_LOWLEVEL 2719 | printf("pfpc_free calling ___release_rc(%p)\n", ptr); 2720 | #endif 2721 | 2722 | ___EXT(___release_rc)(ptr); 2723 | 2724 | Py_INCREF(Py_None); 2725 | 2726 | return Py_None; 2727 | } 2728 | 2729 | 2730 | static PyObject *pfpc_start_buddy(PyObject *self, PyObject *args) { 2731 | 2732 | ___processor_state ___ps = 2733 | ___PSTATE_FROM_PROCESSOR_ID(0, &___GSTATE->vmstate0); 2734 | 2735 | fpc_state *python_fpc_state; 2736 | PyObject *capsule; 2737 | 2738 | #ifdef DEBUG_LOWLEVEL 2739 | printf("pfpc_start_buddy() enter\n"); 2740 | #endif 2741 | 2742 | python_fpc_state = alloc_python_fpc_state(___ps); 2743 | 2744 | ___EXT(___thread_init_from_self)(&python_fpc_state->python_thread); 2745 | 2746 | 2747 | ___EXT(___raise_procedural_interrupt_pstate)(___ps, 2748 | ___CAST(void*,python_fpc_state)); 2749 | 2750 | #ifdef DEBUG_LOWLEVEL 2751 | printf("pfpc_start_buddy() exit\n"); 2752 | #endif 2753 | 2754 | return python_fpc_state->capsule; 2755 | } 2756 | 2757 | 2758 | static PyMethodDef pfpc_methods[] = { 2759 | {"send", pfpc_send, METH_VARARGS, "Send to buddy thread."}, 2760 | {"recv", pfpc_recv, METH_VARARGS, "Receive from buddy thread."}, 2761 | {"free", pfpc_free, METH_VARARGS, "Free Scheme object."}, 2762 | {"start_buddy", pfpc_start_buddy, METH_VARARGS, "Start buddy Scheme thread."}, 2763 | {NULL, NULL, 0, NULL} 2764 | }; 2765 | 2766 | 2767 | static struct PyModuleDef pfpc_module = { 2768 | PyModuleDef_HEAD_INIT, 2769 | "pfpc", /* name of module */ 2770 | NULL, /* module documentation, may be NULL */ 2771 | -1, /* size of per-interpreter state of the module, 2772 | or -1 if the module keeps state in global variables. */ 2773 | pfpc_methods 2774 | }; 2775 | 2776 | 2777 | PyMODINIT_FUNC PyInit_pfpc(void) { 2778 | return PyModule_Create(&pfpc_module); 2779 | } 2780 | 2781 | 2782 | ___BOOL initialize(void) { 2783 | 2784 | if (PyImport_AppendInittab("pfpc", PyInit_pfpc) == -1) return 0; 2785 | 2786 | Py_Initialize(); 2787 | 2788 | PyRun_SimpleString(python_code); 2789 | 2790 | PyObject *__main__ = PyImport_AddModule("__main__"); 2791 | PyObject *_fractions = PyObject_GetAttrString(__main__, "_fractions"); 2792 | 2793 | _SchemeObject_cls = ___CAST(PyTypeObject*, PyObject_GetAttrString(__main__, "_SchemeObject")); 2794 | Fraction_cls = ___CAST(PyTypeObject*, PyObject_GetAttrString(_fractions, "Fraction")); 2795 | 2796 | PyEval_SaveThread(); 2797 | 2798 | return 1; 2799 | } 2800 | 2801 | 2802 | void finalize(void) { 2803 | Py_Finalize(); 2804 | } 2805 | 2806 | 2807 | end-of-c-declare 2808 | ) 2809 | 2810 | ;;;---------------------------------------------------------------------------- 2811 | 2812 | ;;(define PyObject*-converters (make-table)) 2813 | 2814 | ;;(define (PyObject*-register-converter type-name conv) 2815 | ;; (let ((val (table-ref PyObject*-converters type-name #f))) 2816 | ;; (if val 2817 | ;; (begin 2818 | ;; (table-set! PyObject*-converters type-name #f) 2819 | ;; (table-set! PyObject*-converters type-name conv)) 2820 | ;; (table-set! PyObject*-converters type-name conv)))) 2821 | 2822 | (define (##py-function-memoized descr) 2823 | (let* ((x (##unbox descr))) 2824 | (if (##string? x) 2825 | (let ((host-fn (python-eval x))) 2826 | (##set-box! descr host-fn) 2827 | host-fn) 2828 | x))) 2829 | 2830 | ;;;---------------------------------------------------------------------------- 2831 | 2832 | (define initialize 2833 | (c-lambda () bool "initialize")) 2834 | 2835 | (define finalize 2836 | (c-lambda () void "finalize")) 2837 | 2838 | (c-define-type fpc_state* (pointer "fpc_state")) 2839 | 2840 | (define (make-null-fpc_state*) 2841 | (let ((x ((c-lambda () fpc_state* "___return(___CAST(void*,1));")))) 2842 | ((c-lambda (scheme-object) void "___FOREIGN_PTR_FIELD(___ARG1) = ___CAST(___WORD,NULL);") x) 2843 | x)) 2844 | 2845 | (define scheme-fpc-state-table #f) 2846 | 2847 | (define (get-scheme-fpc-state!) 2848 | (let ((thread (current-thread))) 2849 | (or (table-ref scheme-fpc-state-table thread #f) 2850 | (let ((scheme-fpc-state (make-scheme-fpc-state thread))) 2851 | (table-set! scheme-fpc-state-table thread scheme-fpc-state) 2852 | scheme-fpc-state)))) 2853 | 2854 | (define (make-scheme-fpc-state thread) 2855 | (let ((scheme-fpc-state 2856 | (let ((mut (make-mutex))) 2857 | (mutex-lock! mut) ;; must be locked, to block at next mutex-lock! 2858 | (vector '() 2859 | (lambda (self) 2860 | (let ((mut (vector-ref self 2))) 2861 | (mutex-unlock! mut))) 2862 | mut 2863 | (make-null-fpc_state*))))) 2864 | (table-set! scheme-fpc-state-table thread scheme-fpc-state) 2865 | ((c-lambda (scheme-object) void "setup_python_fpc_state") 2866 | scheme-fpc-state) 2867 | scheme-fpc-state)) 2868 | 2869 | (define (##start-buddy scheme-fpc-state) 2870 | (declare (not interrupts-enabled)) 2871 | (let ((mut (make-mutex))) 2872 | (mutex-lock! mut) ;; must be locked, to block at next mutex-lock! 2873 | (vector-set! scheme-fpc-state 2874 | 1 2875 | (lambda (self) 2876 | (let ((mut (vector-ref self 2))) 2877 | (mutex-unlock! mut)))) 2878 | (vector-set! scheme-fpc-state 2879 | 2 2880 | mut) 2881 | (let ((thread 2882 | (##make-root-thread 2883 | (lambda () 2884 | (with-exception-catcher 2885 | (lambda (e) 2886 | ;; (pp (list 'start-buddy-got-exception e)) 2887 | ;; (print "e=") (display-exception e) 2888 | #f) 2889 | (lambda () 2890 | (sfpc-send scheme-fpc-state (vector op-return (void))) ;; signal thread is started 2891 | (sfpc-loop scheme-fpc-state)))) 2892 | 'buddy))) 2893 | (table-set! scheme-fpc-state-table thread scheme-fpc-state) 2894 | (thread-start! thread)))) 2895 | 2896 | (define (cleanup-scheme-fpc-state thread) 2897 | (let ((scheme-fpc-state (table-ref scheme-fpc-state-table thread #f))) 2898 | (and scheme-fpc-state 2899 | (begin 2900 | (sfpc-send scheme-fpc-state (vector op-terminate)) 2901 | ((c-lambda (scheme-object) void "cleanup_python_fpc_state") 2902 | scheme-fpc-state))))) 2903 | 2904 | (define (sfpc-send scheme-fpc-state message) 2905 | ;; (pp (list 'sfpc-send scheme-fpc-state message)) 2906 | (let ((python-message (object->PyObject* message))) 2907 | ((c-lambda (scheme-object PyObject*) void "sfpc_send") 2908 | scheme-fpc-state 2909 | python-message) 2910 | )) 2911 | 2912 | (define (sfpc-recv scheme-fpc-state) 2913 | ;; (pp (list 'sfpc-recv scheme-fpc-state)) 2914 | (mutex-lock! (vector-ref scheme-fpc-state 2)) 2915 | ((c-lambda (scheme-object) PyObject* "sfpc_recv") 2916 | scheme-fpc-state)) 2917 | 2918 | #; 2919 | (begin 2920 | (define op-return "return") 2921 | (define op-call "call") 2922 | (define op-raise "raise") 2923 | (define op-error "error") 2924 | (define op-get-eval "get-eval") 2925 | (define op-get-exec "get-exec") 2926 | (define op-terminate "terminate")) 2927 | 2928 | (begin 2929 | (define op-return 0) 2930 | (define op-call 1) 2931 | (define op-raise 2) 2932 | (define op-error 3) 2933 | (define op-get-eval 4) 2934 | (define op-get-exec 5) 2935 | (define op-terminate 6)) 2936 | 2937 | (define (sfpc-loop scheme-fpc-state) 2938 | ;; (pp (list 'sfpc-loop scheme-fpc-state)) 2939 | (let loop () 2940 | (let* ((python-message (sfpc-recv scheme-fpc-state)) 2941 | (message (PyObject*->object python-message)) 2942 | (op (vector-ref message 0))) 2943 | (cond ((equal? op op-return) 2944 | (vector-ref message 1)) 2945 | ((equal? op op-call) 2946 | ;; (pp (list 'sfpc-loop-message= message)) 2947 | (sfpc-send 2948 | scheme-fpc-state 2949 | (with-exception-catcher 2950 | (lambda (e) 2951 | ;; (pp (list 'sfpc-loop-got-exception e)) 2952 | ;; (print "e=") (display-exception e) 2953 | (vector op-raise e)) 2954 | (lambda () 2955 | (let* ((fn (vector-ref message 1)) 2956 | (args (vector-ref message 2)) 2957 | (kw-keys (vector-ref message 3)) 2958 | (kw-vals (vector-ref message 4)) 2959 | (result (apply fn (append (vector->list args) (kwargs->keywords kw-keys kw-vals))))) 2960 | (vector op-return result))))) 2961 | (loop)) 2962 | ((equal? op op-raise) 2963 | (raise (cons (vector-ref message 1) (vector-ref message 2)))) 2964 | ((equal? op op-error) 2965 | (error "_pfpc_loop got an unknown message" (vector-ref message 1))) 2966 | (else 2967 | (error "sfpc-loop got an unknown message" message)))))) 2968 | 2969 | (define (sfpc-send-recv scheme-fpc-state msg) 2970 | (sfpc-send scheme-fpc-state msg) 2971 | (sfpc-loop scheme-fpc-state)) 2972 | 2973 | (define (sfpc-call-with-kw fn args kw-keys kw-vals) 2974 | (let ((scheme-fpc-state (get-scheme-fpc-state!))) 2975 | (sfpc-send-recv scheme-fpc-state (vector op-call fn args kw-keys kw-vals)))) 2976 | 2977 | (define (sfpc-call fn args) 2978 | (let ((scheme-fpc-state (get-scheme-fpc-state!))) 2979 | (sfpc-send-recv scheme-fpc-state (vector op-call fn args)))) 2980 | 2981 | (define (setup-fpc) 2982 | 2983 | ;; start dummy thread to prevent deadlock detection (TODO: find a fix) 2984 | (thread-start! (make-thread (lambda () (thread-sleep! +inf.0)))) 2985 | 2986 | (set! scheme-fpc-state-table (make-table test: eq? weak-keys: #t)) 2987 | 2988 | (initialize)) 2989 | 2990 | (define (cleanup-fpc) 2991 | (##tty-mode-reset) 2992 | ((c-lambda () void "exit(0);")) ;; TODO: why does the below cause a segfault? 2993 | (for-each 2994 | cleanup-scheme-fpc-state 2995 | (map car (table->list scheme-fpc-state-table))) 2996 | (finalize)) 2997 | 2998 | ;;;---------------------------------------------------------------------------- 2999 | 3000 | ;; Misc 3001 | 3002 | ;; (define (PyObject*-register-foreign-write-handler t) 3003 | ;; (##readtable-foreign-write-handler-register! 3004 | ;; ##main-readtable 3005 | ;; t 3006 | ;; (lambda (we obj) 3007 | ;; (##wr-sn* we obj t PyObject*-wr-str)))) 3008 | 3009 | ;; (define (PyObject*-wr-str we obj) 3010 | ;; (let* ((repr (PyObject_Repr obj)) 3011 | ;; (s (PyObject*/str->string repr))) 3012 | ;; (##wr-str we (string-append " " s)))) 3013 | 3014 | ;; (define (register-foreign-write-handlers) 3015 | ;; (define python-subtypes 3016 | ;; '(PyObject* 3017 | ;; PyObject*/None 3018 | ;; PyObject*/bool 3019 | ;; PyObject*/int 3020 | ;; PyObject*/float 3021 | ;; PyObject*/complex 3022 | ;; PyObject*/Fraction 3023 | ;; PyObject*/bytes 3024 | ;; PyObject*/bytearray 3025 | ;; PyObject*/str 3026 | ;; PyObject*/list 3027 | ;; PyObject*/dict 3028 | ;; PyObject*/frozenset 3029 | ;; PyObject*/set 3030 | ;; PyObject*/tuple 3031 | ;; PyObject*/module 3032 | ;; PyObject*/type 3033 | ;; PyObject*/function 3034 | ;; PyObject*/builtin_function_or_method 3035 | ;; PyObject*/method 3036 | ;; PyObject*/method_descriptor 3037 | ;; PyObject*/cell 3038 | ;; PyObject*/SchemeObject 3039 | ;; )) 3040 | ;; (for-each PyObject*-register-foreign-write-handler python-subtypes)) 3041 | 3042 | (define (pip-install module) 3043 | (shell-command 3044 | (string-append (path-expand "pip" python-venv-bin-dir) 3045 | " install " 3046 | module)) 3047 | (void)) 3048 | 3049 | (define (pip-uninstall module) 3050 | (shell-command 3051 | (string-append (path-expand "pip" python-venv-bin-dir) 3052 | " uninstall " 3053 | module)) 3054 | (void)) 3055 | 3056 | ;;;---------------------------------------------------------------------------- 3057 | 3058 | ;; Setup 3059 | 3060 | (setup-fpc) 3061 | 3062 | (define python-eval 3063 | (sfpc-send-recv (get-scheme-fpc-state!) (vector op-get-eval))) 3064 | 3065 | (define python-exec 3066 | (sfpc-send-recv (get-scheme-fpc-state!) (vector op-get-exec))) 3067 | 3068 | ;; Create a _SchemeProcedure instance. 3069 | ;; obj is a SchemeObject that contains a pointer to a Scheme function. 3070 | (define python-SchemeProcedure 3071 | (let ((_SchemeProcedure (python-eval "foreign(_SchemeProcedure)"))) 3072 | (lambda (obj) 3073 | (PyObject_CallFunctionObjArgs1 _SchemeProcedure obj)))) 3074 | 3075 | ((python-eval "__import__('sys').path.append") 3076 | (path-expand "site-packages" python-venv-lib-dir)) 3077 | 3078 | ;; (register-foreign-write-handlers) 3079 | 3080 | ;;;============================================================================ 3081 | -------------------------------------------------------------------------------- /python.sld: -------------------------------------------------------------------------------- 1 | ;;;============================================================================ 2 | 3 | ;;; File: "python.sld" 4 | 5 | ;;; Copyright (c) 2020-2025 by Marc Feeley, All Rights Reserved. 6 | ;;; Copyright (c) 2020-2022 by Marc-André Bélanger, All Rights Reserved. 7 | 8 | ;;;============================================================================ 9 | 10 | (define-library (python) 11 | 12 | (namespace "github.com/gambit/python#") 13 | 14 | (export 15 | 16 | ;; Constants 17 | Py_eval_input 18 | Py_file_input 19 | Py_single_input 20 | 21 | ;; Initialization, Finalization, and Threads 22 | Py_Initialize 23 | Py_Finalize 24 | 25 | ;; These are no longer available: 26 | ;; Py_SetPath 27 | ;; Py_SetProgramName 28 | ;; Py_SetPythonHome 29 | ;; PySys_SetArgv 30 | ;; PySys_SetArgvEx 31 | 32 | ;; PyRun_* 33 | PyRun_SimpleString 34 | PyRun_String 35 | 36 | ;; PyImport_* 37 | PyImport_AddModuleObject 38 | PyImport_AddModule 39 | PyImport_ImportModule 40 | PyImport_ImportModuleEx 41 | 42 | ;; PyModule_* 43 | PyModule_GetDict 44 | 45 | ;; PyDict_* 46 | PyDict_New 47 | PyDict_Size 48 | PyDict_Items 49 | PyDict_Keys 50 | PyDict_Values 51 | PyDict_GetItem 52 | PyDict_SetItem 53 | PyDict_GetItemString 54 | PyDict_SetItemString 55 | 56 | ;; PyList_* 57 | PyList_New 58 | 59 | ;; PyTuple_* 60 | PyTuple_GetItem 61 | 62 | ;; PyBool_* 63 | PyBool_FromLong 64 | 65 | ;; PyLong_* 66 | PyLong_FromUnicodeObject 67 | 68 | ;; PyUnicode_* 69 | PyUnicode_FromString 70 | 71 | ;; PyObject_* 72 | PyObject_CallMethod 73 | PyObject_GetAttrString 74 | PyObject_Length 75 | PyObject_Repr 76 | PyObject*-type 77 | PyObject*-type-name 78 | 79 | ;; Call Python callables 80 | PyObject_CallObject 81 | PyObject_CallFunctionObjArgs 82 | PyObject_CallFunctionObjArgs* 83 | PyObject_CallFunctionObjArgs0 84 | PyObject_CallFunctionObjArgs1 85 | PyObject_CallFunctionObjArgs2 86 | PyObject_CallFunctionObjArgs3 87 | PyObject_CallFunctionObjArgs4 88 | 89 | ;; Converters 90 | PyObject*/None->void 91 | void->PyObject*/None 92 | PyObject*/bool->boolean 93 | boolean->PyObject*/bool 94 | PyObject*/int->exact-integer 95 | exact-integer->PyObject*/int 96 | PyObject*/float->flonum 97 | flonum->PyObject*/float 98 | PyObject*/complex->cpxnum 99 | flonums->PyObject*/complex 100 | PyObject*/Fraction->ratnum 101 | ints->PyObject*/Fraction 102 | PyObject*/str->string 103 | string->PyObject*/str 104 | PyObject*/bytes->u8vector 105 | u8vector->PyObject*/bytes 106 | s8vector->PyObject*/bytes 107 | PyObject*/bytearray->u8vector 108 | u8vector->PyObject*/bytearray 109 | PyObject*/list->vector 110 | vector->PyObject*/list 111 | PyObject*/list->list 112 | list->PyObject*/list 113 | PyObject*/tuple->vector 114 | vector->PyObject*/tuple 115 | PyObject*/tuple->list 116 | list->PyObject*/tuple 117 | PyObject*->object 118 | object->PyObject* 119 | procedure->PyObject*/function 120 | SchemeObject->object 121 | object->SchemeObject 122 | 123 | ;; Misc 124 | pip-install 125 | pip-uninstall 126 | python-eval 127 | python-exec 128 | cleanup-fpc 129 | 130 | scheme 131 | 132 | ) 133 | 134 | (include "python.scm")) 135 | -------------------------------------------------------------------------------- /test/leaks.scm: -------------------------------------------------------------------------------- 1 | ;;;============================================================================ 2 | 3 | ;;; File: "test-for-leaks.scm" 4 | 5 | ;;; Copyright (c) 2022 by Marc Feeley, All Rights Reserved. 6 | 7 | ;;;============================================================================ 8 | 9 | (import (github.com/gambit/python)) (##add-exit-job! cleanup-fpc) 10 | 11 | ;;;---------------------------------------------------------------------------- 12 | 13 | (define (get-rss) ;; returns process' RSS in bytes 14 | (call-with-input-string 15 | (cdr (shell-command 16 | (string-append "ps -o rss -p " (number->string (##os-getpid))) 17 | #t)) 18 | (lambda (port) 19 | (read-line port) ;; skip first line 20 | (* 1024 (read port))))) 21 | 22 | (define (sweep) 23 | (let loop ((i 10000000) (r #f)) 24 | (if (> i 0) 25 | (loop (- i 1) (cons i i))))) 26 | 27 | (define (bytes-leaked thunk) 28 | (define chunk 1000) 29 | (let* ((start-time (time->seconds (current-time))) 30 | (start-rss (get-rss))) 31 | (let loop1 ((iters 0)) 32 | (##gc) 33 | (let ((end-time (time->seconds (current-time)))) 34 | (if (< (- end-time start-time) 5) 35 | (let loop2 ((i chunk)) 36 | (if (> i 0) 37 | (begin 38 | (thunk) 39 | (loop2 (- i 1))) 40 | (loop1 (+ iters chunk)))) 41 | (let* ((end-rss (get-rss)) 42 | (leak (- end-rss start-rss))) 43 | ;; (pp (list leak: (inexact (/ leak iters)))) 44 | (inexact (/ leak iters)))))))) 45 | 46 | (define (test name thunk) 47 | (let ((n (bytes-leaked thunk))) 48 | (if (>= n 8) 49 | (println "***** " n " bytes leaked by " name) 50 | (println "----- no bytes leaked by " name)))) 51 | 52 | (sweep) 53 | 54 | ;;;---------------------------------------------------------------------------- 55 | 56 | (let* ((f (lambda () (void->PyObject*/None (void)))) 57 | (obj (f))) 58 | (test 'void->PyObject*/None f) 59 | (test 'PyObject*/None->void (lambda () (PyObject*/None->void obj)))) 60 | 61 | (let* ((f (lambda () (boolean->PyObject*/bool #f))) 62 | (obj (f))) 63 | (test 'boolean->PyObject*/bool f) 64 | (test 'PyObject*/bool->boolean (lambda () (PyObject*/bool->boolean obj)))) 65 | 66 | (let* ((f (lambda () (boolean->PyObject*/bool #t))) 67 | (obj (f))) 68 | (test 'boolean->PyObject*/bool f) 69 | (test 'PyObject*/bool->boolean (lambda () (PyObject*/bool->boolean obj)))) 70 | 71 | (let* ((f (lambda () (exact-integer->PyObject*/int 123456))) 72 | (obj (f))) 73 | (test 'exact-integer->PyObject*/int f) 74 | (test 'PyObject*/int->exact-integer (lambda () (PyObject*/int->exact-integer obj)))) 75 | 76 | (let* ((f (lambda () (exact-integer->PyObject*/int 12345678901234567890))) 77 | (obj (f))) 78 | (test 'exact-integer->PyObject*/int f) 79 | (test 'PyObject*/int->exact-integer (lambda () (PyObject*/int->exact-integer obj)))) 80 | 81 | (let* ((f (lambda () (flonum->PyObject*/float 1.2))) 82 | (obj (f))) 83 | (test 'flonum->PyObject*/float f) 84 | (test 'PyObject*/float->flonum (lambda () (PyObject*/float->flonum obj)))) 85 | 86 | (let* ((f (lambda () (flonums->PyObject*/complex 1.2 3.4))) 87 | (obj (f))) 88 | (test 'flonums->PyObject*/complex f) 89 | (test 'PyObject*/complex->cpxnum (lambda () (PyObject*/complex->cpxnum obj)))) 90 | 91 | (let* ((num (exact-integer->PyObject*/int 123456)) 92 | (den (exact-integer->PyObject*/int 654321)) 93 | (f (lambda () (ints->PyObject*/Fraction num den))) 94 | (obj (f))) 95 | (test 'ints->PyObject*/Fraction f) 96 | (test 'PyObject*/Fraction->ratnum (lambda () (PyObject*/Fraction->ratnum obj)))) 97 | 98 | (let* ((f (lambda () (string->PyObject*/str "abc"))) 99 | (obj (f))) 100 | (test 'string->PyObject*/str f) 101 | (test 'PyObject*/str->string (lambda () (PyObject*/str->string obj)))) 102 | 103 | (let* ((f (lambda () (object->SchemeObject (list 1 2 3)))) 104 | (obj (f))) 105 | (test 'object->SchemeObject f) 106 | (test 'SchemeObject->object (lambda () (SchemeObject->object obj)))) 107 | 108 | (let* ((f (lambda () (procedure->PyObject*/function sqrt))) 109 | (obj (f))) 110 | (test 'procedure->PyObject*/function f)) 111 | 112 | (let* ((elem0 (exact-integer->PyObject*/int 0)) 113 | (elem1 (exact-integer->PyObject*/int 1)) 114 | (elem2 (exact-integer->PyObject*/int 2)) 115 | (x (list elem0 elem1 elem2)) 116 | (f (lambda () (list->PyObject*/list x))) 117 | (obj (f))) 118 | (test 'list->PyObject*/list f) 119 | (test 'PyObject*/list->list (lambda () (PyObject*/list->list obj)))) 120 | 121 | (let* ((elem0 (exact-integer->PyObject*/int 0)) 122 | (elem1 (exact-integer->PyObject*/int 1)) 123 | (elem2 (exact-integer->PyObject*/int 2)) 124 | (x (vector elem0 elem1 elem2)) 125 | (f (lambda () (vector->PyObject*/list x))) 126 | (obj (f))) 127 | (test 'vector->PyObject*/list f) 128 | (test 'PyObject*/list->vector (lambda () (PyObject*/list->vector obj)))) 129 | 130 | (let* ((elem0 (exact-integer->PyObject*/int 0)) 131 | (elem1 (exact-integer->PyObject*/int 1)) 132 | (elem2 (exact-integer->PyObject*/int 2)) 133 | (x (list elem0 elem1 elem2)) 134 | (f (lambda () (list->PyObject*/tuple x))) 135 | (obj (f))) 136 | (test 'list->PyObject*/tuple f) 137 | (test 'PyObject*/tuple->list (lambda () (PyObject*/tuple->list obj)))) 138 | 139 | (let* ((elem0 (exact-integer->PyObject*/int 0)) 140 | (elem1 (exact-integer->PyObject*/int 1)) 141 | (elem2 (exact-integer->PyObject*/int 2)) 142 | (x (vector elem0 elem1 elem2)) 143 | (f (lambda () (vector->PyObject*/tuple x))) 144 | (obj (f))) 145 | (test 'vector->PyObject*/tuple f) 146 | (test 'PyObject*/tuple->vector (lambda () (PyObject*/tuple->vector obj)))) 147 | 148 | (let* ((f (lambda () (u8vector->PyObject*/bytes '#u8(1 2 3)))) 149 | (obj (f))) 150 | (test 'u8vector->PyObject*/bytes f) 151 | (test 'PyObject*/bytes->u8vector (lambda () (PyObject*/bytes->u8vector obj)))) 152 | 153 | (let* ((f (lambda () (s8vector->PyObject*/bytes '#s8(1 2 3)))) 154 | (obj (f))) 155 | (test 's8vector->PyObject*/bytes f)) 156 | 157 | (let* ((f (lambda () (u8vector->PyObject*/bytearray '#u8(1 2 3)))) 158 | (obj (f))) 159 | (test 'u8vector->PyObject*/bytearray f) 160 | (test 'PyObject*/bytearray->u8vector (lambda () (PyObject*/bytearray->u8vector obj)))) 161 | 162 | ;;;============================================================================ 163 | -------------------------------------------------------------------------------- /test/test.scm: -------------------------------------------------------------------------------- 1 | ;;;============================================================================ 2 | 3 | ;;; File: "test.scm" 4 | 5 | ;;; Copyright (c) 2022 by Marc Feeley, All Rights Reserved. 6 | 7 | ;;;============================================================================ 8 | 9 | (import (_six python)) 10 | (import (github.com/gambit/python)) 11 | (import _test) 12 | 13 | ;;;---------------------------------------------------------------------------- 14 | 15 | ;; test basic Python to Scheme conversions 16 | 17 | (test-equal (void) \None) 18 | 19 | (test-equal #f \False) 20 | (test-equal #t \True) 21 | 22 | (test-equal 1 \1) 23 | (test-equal 0 \0) 24 | (test-equal -1 \-1) 25 | (test-equal 123456 \123456) ;; fixnum 26 | (test-equal 12345678901234567890 \12345678901234567890) ;; bignum 27 | (test-equal 1.0 \1.0) 28 | (test-equal 0.0 \0.0) 29 | (test-equal -0.0 \-0.0) 30 | (test-equal -1.0 \-1.0) 31 | (test-equal 1.234e56 \1.234e56) 32 | (test-equal 1e308 \1e308) 33 | (test-equal +inf.0 \float("+inf")) 34 | (test-equal -inf.0 \float("-inf")) 35 | (test-assert (nan? \float("nan"))) 36 | (test-equal 1.2+3.4i \complex("1.2+3.4j")) 37 | (test-equal -1.2-3.4i \complex("-1.2-3.4j")) 38 | (test-equal -2/3 \__import__("fractions").Fraction(-2, 3)) 39 | (test-equal 2/3 \__import__("fractions").Fraction(2, 3)) 40 | (test-equal -2/3 \__import__("fractions").Fraction(-2, 3)) 41 | 42 | (test-equal '() \list()) 43 | (test-equal '(0) \list(range(1))) 44 | (test-equal '(0 1 2 3) \list(range(4))) 45 | 46 | (test-equal '#() \tuple()) 47 | (test-equal '#(0) \tuple(range(1))) 48 | (test-equal '#(0 1 2 3) \tuple(range(4))) 49 | 50 | (test-equal '#u8() \bytes()) 51 | (test-equal '#u8(0) \bytes(range(1))) 52 | (test-equal '#u8(0 1 2 3) \bytes(range(4))) 53 | 54 | (test-equal "" \"") 55 | (test-equal "a" \"a") 56 | (test-equal "A B" \"A B") 57 | 58 | (test-equal (list->table '()) \dict()) 59 | (test-equal (list->table '(("a" . 11))) \dict([tuple(["a", 11])])) 60 | (let ((t \dict([tuple(["a", 11]), tuple(["b", 22])]))) 61 | (test-equal 2 (table-length t)) 62 | (test-equal 11 (table-ref t "a" #f)) 63 | (test-equal 22 (table-ref t "b" #f))) 64 | 65 | ;; Procedure conversions 66 | (let ((p (python-eval "foreign(lambda x: x)"))) 67 | \s=`p 68 | (test-assert \s==`p)) 69 | (let ((p (lambda (x) x))) 70 | \s=`(scheme p) 71 | (test-assert (eq? \s p))) 72 | (test-equal (cos 0) \(`cos)(0)) 73 | 74 | ;; *args and **kwargs 75 | (let ((p (python-eval "lambda x, *args, **kwargs: args if x else kwargs"))) 76 | (test-equal #(1 2 3) (p #t 1 2 3)) 77 | (test-equal (list->table '(("k" . 0) ("t" . 1))) (p #f k: 0 t: 1))) 78 | 79 | ;;;---------------------------------------------------------------------------- 80 | 81 | ;; test basic Scheme to Python conversions 82 | 83 | (test-assert \None==`(void)) 84 | 85 | (test-assert \False==`#f) 86 | (test-assert \True==`#t) 87 | 88 | (test-assert \1==`1) 89 | (test-assert \0==`0) 90 | (test-assert \-1==`-1) 91 | (test-assert \123456==`123456) ;; fixnum 92 | (test-assert \12345678901234567890==`12345678901234567890) ;; bignum 93 | 94 | (test-assert \1.0==`1.0) 95 | (test-assert \0.0==`0.0) 96 | (test-assert \-0.0==`-0.0) 97 | (test-assert \-1.0==`-1.0) 98 | (test-assert \1.234e56==`1.234e56) 99 | (test-assert \1e308==`1e308) 100 | (test-assert \float("+inf")==`+inf.0) 101 | (test-assert \float("-inf")==`-inf.0) 102 | (test-assert (nan? \float("nan"))) 103 | (test-assert \complex("1.2+3.4j")==`1.2+3.4i) 104 | (test-assert \complex("-1.2-3.4j")==`-1.2-3.4i) 105 | (test-assert \__import__("fractions").Fraction(-2, 3)==`-2/3) 106 | (test-assert \__import__("fractions").Fraction(2, 3)==`2/3) 107 | (test-assert \__import__("fractions").Fraction(-2, 3)==`-2/3) 108 | 109 | (test-assert \list()==`'()) 110 | (test-assert \list(range(1))==`'(0)) 111 | (test-assert \list(range(4))==`'(0 1 2 3)) 112 | 113 | (test-assert \tuple()==`'#()) 114 | (test-assert \tuple(range(1))==`'#(0)) 115 | (test-assert \tuple(range(4))==`'#(0 1 2 3)) 116 | 117 | (test-assert \bytes()==`'#u8()) 118 | (test-assert \bytes(range(1))==`'#u8(0)) 119 | (test-assert \bytes(range(4))==`'#u8(0 1 2 3)) 120 | 121 | (test-assert \""==`"") 122 | (test-assert \"a"==`"a") 123 | (test-assert \"A B"==`"A B") 124 | 125 | (test-assert \dict()==`(list->table '())) 126 | (test-assert \dict([tuple(["a", 11])])==`(list->table '(("a" . 11)))) 127 | (test-assert \dict([tuple(["a", 11]),tuple(["b", 22])])==`(list->table '(("a" . 11) ("b" . 22)))) 128 | 129 | ;;;============================================================================ 130 | ;(shell-command (string-append "kill -9 " (number->string (##os-getpid)))) 131 | --------------------------------------------------------------------------------