Replace ~/mine/chez-* paths with configurable CHEZ_EXT_DIR, add GitHub links
ober
f98477c21c51a86d487222a2078bcceea74b430b
--- a/Makefile +++ b/Makefile @@ -1,9 +1,11 @@ SCHEME = scheme LIBDIRS = lib +# Base directory for chez-* repos (clone from github.com/ober/chez-*) +CHEZ_EXT_DIR ?= $(HOME)/src # External chez-* library paths for wrapper modules -CHEZ_EXT_LIBDIRS = $(HOME)/mine/chez-https/src:$(HOME)/mine/chez-ssl/src:$(HOME)/mine/chez-zlib/src:$(HOME)/mine/chez-pcre2:$(HOME)/mine/chez-yaml:$(HOME)/mine/chez-leveldb:$(HOME)/mine/chez-epoll/src:$(HOME)/mine/chez-inotify/src:$(HOME)/mine/chez-crypto/src:$(HOME)/mine/chez-sqlite/src:$(HOME)/mine/chez-postgresql/src +CHEZ_EXT_LIBDIRS = $(CHEZ_EXT_DIR)/chez-https/src:$(CHEZ_EXT_DIR)/chez-ssl/src:$(CHEZ_EXT_DIR)/chez-zlib/src:$(CHEZ_EXT_DIR)/chez-pcre2:$(CHEZ_EXT_DIR)/chez-yaml:$(CHEZ_EXT_DIR)/chez-leveldb:$(CHEZ_EXT_DIR)/chez-epoll/src:$(CHEZ_EXT_DIR)/chez-inotify/src:$(CHEZ_EXT_DIR)/chez-crypto/src:$(CHEZ_EXT_DIR)/chez-sqlite/src:$(CHEZ_EXT_DIR)/chez-postgresql/src # Shared object paths for FFI-based chez-* libraries -CHEZ_EXT_LDPATH = $(HOME)/mine/chez-ssl:$(HOME)/mine/chez-zlib:$(HOME)/mine/chez-pcre2:$(HOME)/mine/chez-leveldb:$(HOME)/mine/chez-epoll:$(HOME)/mine/chez-inotify:$(HOME)/mine/chez-crypto:$(HOME)/mine/chez-sqlite:$(HOME)/mine/chez-postgresql +CHEZ_EXT_LDPATH = $(CHEZ_EXT_DIR)/chez-ssl:$(CHEZ_EXT_DIR)/chez-zlib:$(CHEZ_EXT_DIR)/chez-pcre2:$(CHEZ_EXT_DIR)/chez-leveldb:$(CHEZ_EXT_DIR)/chez-epoll:$(CHEZ_EXT_DIR)/chez-inotify:$(CHEZ_EXT_DIR)/chez-crypto:$(CHEZ_EXT_DIR)/chez-sqlite:$(CHEZ_EXT_DIR)/chez-postgresql .PHONY: test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-wrappers clean @@ -48,13 +50,13 @@ test-wrappers: @LD_LIBRARY_PATH="$(CHEZ_EXT_LDPATH):$$LD_LIBRARY_PATH" \ $(SCHEME) --libdirs "$(LIBDIRS):$(CHEZ_EXT_LIBDIRS)" --script tests/test-wrapper-zlib.ss 2>/dev/null \ || echo " zlib: SKIP (requires chez_zlib_shim.so)" - @ln -sf $(HOME)/mine/chez-ssl/chez_ssl_shim.so ./chez_ssl_shim.so 2>/dev/null; \ + @ln -sf $(CHEZ_EXT_DIR)/chez-ssl/chez_ssl_shim.so ./chez_ssl_shim.so 2>/dev/null; \ LD_LIBRARY_PATH="$(CHEZ_EXT_LDPATH):$$LD_LIBRARY_PATH" \ $(SCHEME) --libdirs "$(LIBDIRS):$(CHEZ_EXT_LIBDIRS)" --script tests/test-wrapper-ssl.ss 2>/dev/null \ && $(SCHEME) --libdirs "$(LIBDIRS):$(CHEZ_EXT_LIBDIRS)" --script tests/test-wrapper-request.ss 2>/dev/null; \ rm -f ./chez_ssl_shim.so \ || echo " ssl/request: SKIP (requires chez_ssl_shim.so)" - @LD_LIBRARY_PATH="$(CHEZ_EXT_LDPATH):$$LD_LIBRARY_PATH" CHEZ_PCRE2_LIB="$(HOME)/mine/chez-pcre2" \ + @LD_LIBRARY_PATH="$(CHEZ_EXT_LDPATH):$$LD_LIBRARY_PATH" CHEZ_PCRE2_LIB="$(CHEZ_EXT_DIR)/chez-pcre2" \ $(SCHEME) --libdirs "$(LIBDIRS):$(CHEZ_EXT_LIBDIRS)" --script tests/test-wrapper-pcre2.ss 2>/dev/null \ || echo " pcre2: SKIP (requires pcre2_shim.so)" @LD_LIBRARY_PATH="$(CHEZ_EXT_LDPATH):$$LD_LIBRARY_PATH" \ --- a/README.md +++ b/README.md @@ -111,13 +111,18 @@ scheme --libdirs lib --script your-file.ss ### External Library Wrappers (require [chez-*](https://github.com/ober) libraries) | Module | Wraps | Provides | |--------|-------|----------| -| `(std net request)` | chez-https | `http-get`, `http-post`, `http-put`, `http-delete`, `url-encode` | -| `(std net httpd)` | chez-httpd | `httpd-start`, `httpd-route`, `http-respond-json`, etc. | -| `(std net ssl)` | chez-ssl | `ssl-connect`, `tcp-connect`, `tcp-listen`, TLS/TCP networking | -| `(std compress zlib)` | chez-zlib | `gzip-bytevector`, `gunzip-bytevector`, `deflate-bytevector` | -| `(std text yaml)` | chez-yaml | `yaml-load`, `yaml-dump`, `yaml-load-string`, `yaml-dump-string` | -| `(std db leveldb)` | chez-leveldb | `leveldb-open`, `leveldb-put`, `leveldb-get`, iterators, batches | -| `(std pcre2)` | chez-pcre2 | `pcre2-compile`, `pcre2-search`, `pcre2-replace`, JIT regex | +| `(std net request)` | [chez-https](https://github.com/ober/chez-https) | `http-get`, `http-post`, `http-put`, `http-delete`, `url-encode` | +| `(std net httpd)` | [chez-https](https://github.com/ober/chez-https) | `httpd-start`, `httpd-route`, `http-respond-json`, etc. | +| `(std net ssl)` | [chez-ssl](https://github.com/ober/chez-ssl) | `ssl-connect`, `tcp-connect`, `tcp-listen`, TLS/TCP networking | +| `(std compress zlib)` | [chez-zlib](https://github.com/ober/chez-zlib) | `gzip-bytevector`, `gunzip-bytevector`, `deflate-bytevector` | +| `(std text yaml)` | [chez-yaml](https://github.com/ober/chez-yaml) | `yaml-load`, `yaml-dump`, `yaml-load-string`, `yaml-dump-string` | +| `(std db leveldb)` | [chez-leveldb](https://github.com/ober/chez-leveldb) | `leveldb-open`, `leveldb-put`, `leveldb-get`, iterators, batches | +| `(std db sqlite)` | [chez-sqlite](https://github.com/ober/chez-sqlite) | `sqlite-open`, `sqlite-query`, `sqlite-eval`, prepared statements | +| `(std db postgresql)` | [chez-postgresql](https://github.com/ober/chez-postgresql) | `pg-connect`, `pg-query`, `pg-eval`, parameterized queries | +| `(std pcre2)` | [chez-pcre2](https://github.com/ober/chez-pcre2) | `pcre2-compile`, `pcre2-search`, `pcre2-replace`, JIT regex | +| `(std os epoll)` | [chez-epoll](https://github.com/ober/chez-epoll) | `epoll-create`, `epoll-add!`, `epoll-wait`, edge-triggered I/O | +| `(std os inotify)` | [chez-inotify](https://github.com/ober/chez-inotify) | `inotify-init`, `inotify-add-watch!`, `inotify-read-events` | +| `(std crypto *)` | [chez-crypto](https://github.com/ober/chez-crypto) | `sha256`, `hmac-sha256`, `aes-encrypt`, `rsa-sign`, key derivation | ### FFI (`(jerboa ffi)`) - `c-lambda` → `foreign-procedure` with automatic type translation @@ -151,7 +156,7 @@ Runs 289 tests across reader, core macros, runtime, standard library, FFI, modul ## Requirements - [Chez Scheme](https://cisco.github.io/ChezScheme/) 10.x (stock, unmodified) -- Optional: [chez-*](https://github.com/ober) libraries for networking, compression, PCRE2, YAML, LevelDB +- Optional: [chez-*](https://github.com/ober) libraries for networking, compression, PCRE2, YAML, LevelDB, SQLite, PostgreSQL, epoll, inotify, crypto ## Project Structure @@ -197,16 +202,26 @@ lib/ temporaries.sls # :std/os/temporaries signal.sls # :std/os/signal fdio.sls # :std/os/fdio + epoll.sls # :std/os/epoll (wraps chez-epoll) + inotify.sls # :std/os/inotify (wraps chez-inotify) net/ request.sls # :std/net/request (wraps chez-https) - httpd.sls # :std/net/httpd (wraps chez-httpd) + httpd.sls # :std/net/httpd (wraps chez-https) ssl.sls # :std/net/ssl (wraps chez-ssl) compress/ zlib.sls # :std/compress/zlib (wraps chez-zlib) db/ leveldb.sls # :std/db/leveldb (wraps chez-leveldb) + sqlite.sls # :std/db/sqlite (wraps chez-sqlite) + postgresql.sls # :std/db/postgresql (wraps chez-postgresql) crypto/ digest.sls # :std/crypto/digest + cipher.sls # :std/crypto/cipher (wraps chez-crypto) + hmac.sls # :std/crypto/hmac (wraps chez-crypto) + pkey.sls # :std/crypto/pkey (wraps chez-crypto) + kdf.sls # :std/crypto/kdf (wraps chez-crypto) + etc.sls # :std/crypto/etc (wraps chez-crypto) + foreign.sls # :std/foreign — FFI DSL cli/ getopt.sls # :std/cli/getopt srfi/ --- a/docs/compiling-gerbil-projects.md +++ b/docs/compiling-gerbil-projects.md @@ -8,13 +8,13 @@ Scheme project and compiling it to run on Chez Scheme via Jerboa. 1. **Chez Scheme 10.x** with threads (`./configure --threads && make && make install`) 2. **Jerboa** built and ready: ```bash - git clone https://github.com/ober/jerboa ~/mine/jerboa - cd ~/mine/jerboa && make + git clone https://github.com/ober/jerboa ~/src/jerboa + cd ~/src/jerboa && make ``` 3. **Gerbil source tree** (for the modules your project imports): ```bash # Only needed if your project imports :std/* modules - git clone https://github.com/mighty-gerbils/gerbil ~/mine/gerbil + git clone https://github.com/mighty-gerbils/gerbil ~/src/gerbil ``` ## Project Layout @@ -44,7 +44,7 @@ my-jerboa-project/ ```makefile SCHEME = scheme -JERBOA = $(or $(JERBOA_DIR),$(HOME)/mine/jerboa/src) +JERBOA = $(or $(JERBOA_DIR),$(HOME)/src/jerboa/src) LIBDIRS = src:$(JERBOA) COMPILE = $(SCHEME) -q --libdirs $(LIBDIRS) --compile-imported-libraries new file mode 100644 --- /dev/null +++ b/lib/std/foreign.sls @@ -0,0 +1,303 @@ +#!chezscheme +;;; (std foreign) — Zero-overhead FFI DSL for Chez Scheme +;;; +;;; Eliminates boilerplate from chez-* FFI libraries with declarative macros: +;;; define-ffi-library — load shared objects + bind foreign procedures +;;; define-foreign — single foreign-procedure binding with type mapping +;;; define-foreign/check — foreign-procedure + automatic error checking +;;; define-const — fetch C #define constants at load time +;;; define-foreign-type — pointer type with GC-triggered destructor +;;; with-foreign-resource — deterministic cleanup via dynamic-wind +;;; define-callback — Scheme→C callback with GC safety + +(library (std foreign) + (export + define-ffi-library + define-foreign + define-foreign/check + define-const + define-foreign-type + with-foreign-resource + define-callback + ;; Re-export essentials from Chez for convenience + foreign-alloc foreign-free foreign-ref foreign-set! + foreign-sizeof + load-shared-object + ;; Guardian-based cleanup + start-guardian-thread! stop-guardian-thread!) + (import (chezscheme)) + + ;; ========== Type Mapping ========== + + ;; Translate user-friendly types to Chez foreign types at expand time + (meta define (translate-type type) + (case type + ;; Integer types + [(int) 'int] + [(unsigned-int uint) 'unsigned] + [(int8) 'integer-8] + [(uint8) 'unsigned-8] + [(int16) 'integer-16] + [(uint16) 'unsigned-16] + [(int32) 'integer-32] + [(uint32) 'unsigned-32] + [(int64) 'integer-64] + [(uint64) 'unsigned-64] + [(size_t size-t) 'size_t] + [(ssize_t ssize-t) 'ssize_t] + [(short) 'short] + [(unsigned-short) 'unsigned-short] + [(long) 'long] + [(unsigned-long) 'unsigned-long] + ;; Float types + [(float) 'float] + [(double) 'double] + [(double-float) 'double-float] + ;; Other types + [(char) 'char] + [(wchar wchar_t) 'wchar] + [(bool boolean) 'boolean] + [(void) 'void] + [(string char* nonnull-char-string char-string) 'string] + [(u8* u8vector) 'u8*] + [(void* ptr pointer) 'void*] + [(scheme-object) 'scheme-object] + [else + ;; Pass through — may already be a Chez type + type])) + + ;; ========== define-foreign ========== + ;; + ;; (define-foreign name c-name (arg-types ...) -> ret-type) + ;; (define-foreign name (arg-types ...) -> ret-type) ; c-name = scheme name + ;; + ;; Expands to: (define name (foreign-procedure "c_name" (chez-types ...) chez-ret)) + + (define-syntax define-foreign + (lambda (stx) + (syntax-case stx (->) + ;; With explicit C name + [(k name c-name (arg-type ...) -> ret-type) + (string? (syntax->datum #'c-name)) + (let ([chez-args (map (lambda (t) (translate-type (syntax->datum t))) + (syntax->list #'(arg-type ...)))] + [chez-ret (translate-type (syntax->datum #'ret-type))]) + (with-syntax ([(ct ...) (datum->syntax #'k chez-args)] + [rt (datum->syntax #'k chez-ret)]) + #'(define name (foreign-procedure c-name (ct ...) rt))))] + ;; No C name — derive from scheme name + [(k name (arg-type ...) -> ret-type) + (identifier? #'name) + (let ([c-name (symbol->string (syntax->datum #'name))]) + (with-syntax ([cn (datum->syntax #'k c-name)]) + #'(define-foreign name cn (arg-type ...) -> ret-type)))]))) + + ;; ========== define-foreign/check ========== + ;; + ;; (define-foreign/check name c-name (arg-types ...) -> ret-type + ;; (check: pred) + ;; (error: handler)) + ;; + ;; Like define-foreign but wraps the call: if (pred result) is #f, call (handler result). + ;; If no error: clause, raises a generic error. + + (define-syntax define-foreign/check + (lambda (stx) + (syntax-case stx (-> check: error:) + ;; With both check and error + [(k name c-name (arg-type ...) -> ret-type + (check: check-pred) + (error: error-handler)) + (string? (syntax->datum #'c-name)) + (let ([chez-args (map (lambda (t) (translate-type (syntax->datum t))) + (syntax->list #'(arg-type ...)))] + [chez-ret (translate-type (syntax->datum #'ret-type))]) + (with-syntax ([(ct ...) (datum->syntax #'k chez-args)] + [rt (datum->syntax #'k chez-ret)] + [(param ...) (generate-temporaries #'(arg-type ...))]) + #'(define (name param ...) + (let ([rc ((foreign-procedure c-name (ct ...) rt) param ...)]) + (if (check-pred rc) + rc + (error-handler rc))))))] + ;; Check only, generic error + [(k name c-name (arg-type ...) -> ret-type + (check: check-pred)) + #'(define-foreign/check name c-name (arg-type ...) -> ret-type + (check: check-pred) + (error: (lambda (rc) + (error 'name + (format "FFI call ~a failed" c-name) + rc))))]))) + + ;; ========== define-const ========== + ;; + ;; (define-const NAME type) + ;; (define-const NAME type c-name) + ;; + ;; Fetches a C constant at library load time via a zero-arg foreign-procedure. + ;; The C shim must expose a `chez_CONSTNAME() -> type` function. + + (define-syntax define-const + (lambda (stx) + (syntax-case stx () + ;; Explicit C accessor name + [(k name type c-name) + (string? (syntax->datum #'c-name)) + (let ([chez-ret (translate-type (syntax->datum #'type))]) + (with-syntax ([rt (datum->syntax #'k chez-ret)]) + #'(define name ((foreign-procedure c-name () rt)))))] + ;; Auto-derive: NAME -> "chez_NAME" + [(k name type) + (identifier? #'name) + (let ([c-name (string-append "chez_" (symbol->string (syntax->datum #'name)))]) + (with-syntax ([cn (datum->syntax #'k c-name)]) + #'(define-const name type cn)))]))) + + ;; ========== define-ffi-library ========== + ;; + ;; (define-ffi-library lib-name "shared-object.so" + ;; (define-const ...) + ;; (define-foreign ...) + ;; (define-foreign/check ...)) + ;; + ;; Wraps shared-object loading around a body of FFI definitions. + ;; Accepts one or more shared object paths. + + (define-syntax define-ffi-library + (syntax-rules () + ;; Single shared object + [(_ lib-name shared-obj body ...) + (string? 'unused) ;; just for documentation + (begin + (define lib-name (load-shared-object shared-obj)) + body ...)] + ;; Multiple shared objects (variadic — pass as list) + )) + + ;; Overload: support list of shared objects + (define-syntax define-ffi-library + (lambda (stx) + (syntax-case stx () + ;; Single shared-object string + [(k lib-name shared-obj body ...) + (string? (syntax->datum #'shared-obj)) + #'(begin + (define lib-name (load-shared-object shared-obj)) + body ...)] + ;; Multiple shared-object strings in a list + [(k lib-name (shared-obj ...) body ...) + (for-all (lambda (s) (string? (syntax->datum s))) + (syntax->list #'(shared-obj ...))) + (with-syntax ([(loader ...) + (map (lambda (s i) + (with-syntax ([s s] + [id (datum->syntax #'k + (string->symbol + (format "_lib~a" i)))]) + #'(define id (load-shared-object s)))) + (syntax->list #'(shared-obj ...)) + (iota (length (syntax->list #'(shared-obj ...)))))]) + #'(begin + loader ... + (define lib-name (void)) + body ...))]))) + + ;; ========== Resource Management ========== + + ;; Guardian for pointer types with destructors + (define *ffi-guardian* (make-guardian)) + (define *guardian-thread* #f) + (define *guardian-running* #f) + + ;; Register a pointer with its destructor + (define (register-destructor! ptr destructor) + (*ffi-guardian* (cons ptr destructor))) + + ;; Run the guardian, calling destructors for GC'd pointers + (define (run-guardian!) + (let loop () + (let ([entry (*ffi-guardian*)]) + (when entry + (let ([ptr (car entry)] + [dtor (cdr entry)]) + (guard (exn [#t (void)]) ;; don't crash on destructor errors + (dtor ptr))) + (loop))))) + + ;; Start a background thread that periodically runs the guardian + (define (start-guardian-thread!) + (unless *guardian-running* + (set! *guardian-running* #t) + (set! *guardian-thread* + (fork-thread + (lambda () + (let loop () + (sleep (make-time 'time-duration 0 1)) ;; every 1 second + (run-guardian!) + (when *guardian-running* + (loop)))))))) + + ;; Stop the guardian thread + (define (stop-guardian-thread!) + (set! *guardian-running* #f)) + + ;; ========== define-foreign-type ========== + ;; + ;; (define-foreign-type type-name void* + ;; (destructor: cleanup-proc)) + ;; + ;; Creates a wrapped pointer type. When the pointer becomes unreachable, + ;; the destructor is called by the guardian thread. + ;; Returns the raw pointer for FFI compatibility. + + (define-syntax define-foreign-type + (syntax-rules (destructor:) + [(_ type-name base-type (destructor: dtor)) + (begin + ;; Constructor: wrap and register + (define (type-name ptr) + (register-destructor! ptr dtor) + ptr))] + ;; No destructor — just a type alias + [(_ type-name base-type) + (define (type-name ptr) ptr)])) + + ;; ========== with-foreign-resource ========== + ;; + ;; (with-foreign-resource (var expr cleanup-proc) body ...) + ;; + ;; Deterministic cleanup: runs cleanup-proc on scope exit (normal or exception). + + (define-syntax with-foreign-resource + (syntax-rules () + [(_ (var expr cleanup) body ...) + (let ([var expr]) + (dynamic-wind + void + (lambda () body ...) + (lambda () (cleanup var))))])) + + ;; ========== define-callback ========== + ;; + ;; (define-callback name (arg-types ... -> ret-type) proc) + ;; + ;; Creates a GC-safe C-callable function pointer from a Scheme procedure. + ;; The code address is locked so GC won't move it. + + (define-syntax define-callback + (lambda (stx) + (syntax-case stx (->) + [(k name (arg-type ... -> ret-type) proc) + (let ([chez-args (map (lambda (t) (translate-type (syntax->datum t))) + (syntax->list #'(arg-type ...)))] + [chez-ret (translate-type (syntax->datum #'ret-type))]) + (with-syntax ([(ct ...) (datum->syntax #'k chez-args)] + [rt (datum->syntax #'k chez-ret)]) + #'(begin + (define name + (let ([cb (foreign-callable proc (ct ...) rt)]) + (lock-object cb) + (foreign-callable-entry-point cb))))))]))) + + ) ;; end library --- a/libraries.md +++ b/libraries.md @@ -24,22 +24,22 @@ Gerbil has ~438 `:std/*` modules. Jerboa currently implements 51. This document | Library | Wraps | Jerboa Modules | |---------|-------|---------------| -| chez-ssl | OpenSSL TLS/TCP | `(std net ssl)` | -| chez-https | HTTP client+server | `(std net request)`, `(std net httpd)` | -| chez-zlib | zlib compression | `(std compress zlib)` | -| chez-pcre2 | PCRE2 regex | `(std pcre2)` | -| chez-yaml | YAML parser | `(std text yaml)` | -| chez-leveldb | LevelDB | `(std db leveldb)` | +| [chez-ssl](https://github.com/ober/chez-ssl) | OpenSSL TLS/TCP | `(std net ssl)` | +| [chez-https](https://github.com/ober/chez-https) | HTTP client+server | `(std net request)`, `(std net httpd)` | +| [chez-zlib](https://github.com/ober/chez-zlib) | zlib compression | `(std compress zlib)` | +| [chez-pcre2](https://github.com/ober/chez-pcre2) | PCRE2 regex | `(std pcre2)` | +| [chez-yaml](https://github.com/ober/chez-yaml) | YAML parser | `(std text yaml)` | +| [chez-leveldb](https://github.com/ober/chez-leveldb) | LevelDB | `(std db leveldb)` | ### Completed (New) | Library | Wraps | Jerboa Modules | Status | |---------|-------|---------------|--------| -| chez-epoll | Linux epoll | `(std os epoll)` | Done | -| chez-inotify | Linux inotify | `(std os inotify)` | Done | -| chez-crypto | OpenSSL EVP | `(std crypto cipher)`, `(std crypto hmac)`, `(std crypto pkey)`, `(std crypto kdf)`, `(std crypto etc)` | Done | -| chez-sqlite | SQLite3 | `(std db sqlite)` | Done | -| chez-postgresql | libpq | `(std db postgresql)` | Done | +| [chez-epoll](https://github.com/ober/chez-epoll) | Linux epoll | `(std os epoll)` | Done | +| [chez-inotify](https://github.com/ober/chez-inotify) | Linux inotify | `(std os inotify)` | Done | +| [chez-crypto](https://github.com/ober/chez-crypto) | OpenSSL EVP | `(std crypto cipher)`, `(std crypto hmac)`, `(std crypto pkey)`, `(std crypto kdf)`, `(std crypto etc)` | Done | +| [chez-sqlite](https://github.com/ober/chez-sqlite) | SQLite3 | `(std db sqlite)` | Done | +| [chez-postgresql](https://github.com/ober/chez-postgresql) | libpq | `(std db postgresql)` | Done | ## Pure Scheme Modules (No External Deps)