Fix GC deadlock in debug REPL and IPC server
ober
88590c7b65ff7d5199c76a51f392638489534a2b
--- a/Makefile +++ b/Makefile @@ -4,15 +4,18 @@ JSH = $(HOME)/mine/jerboa-shell/src GHERKIN = $(HOME)/mine/gherkin/src LIBDIRS = --libdirs lib:$(JERBOA)/lib:$(JSH):$(GHERKIN):$(HOME)/mine/chez-pcre2:$(HOME)/mine/chez-scintilla/src:$(HOME)/mine/chez-qt JERBUILD = $(SCHEME) --libdirs $(JERBOA)/lib --script $(JERBOA)/jerbuild.ss -export LD_LIBRARY_PATH := $(HOME)/mine/chez-pcre2:$(HOME)/mine/chez-scintilla:$(HOME)/mine/chez-qt:$(HOME)/mine/jerboa-shell:$(LD_LIBRARY_PATH) +export LD_LIBRARY_PATH := $(HOME)/mine/chez-pcre2:$(HOME)/mine/chez-scintilla:$(HOME)/mine/chez-qt:$(HOME)/mine/gerbil-qt/vendor:$(HOME)/mine/jerboa-shell:$(LD_LIBRARY_PATH) export CHEZ_SCINTILLA_LIB := $(HOME)/mine/chez-scintilla export CHEZ_PCRE2_LIB := $(HOME)/mine/chez-pcre2 +export CHEZ_QT_LIB := $(HOME)/mine/chez-qt +export CHEZ_QT_SHIM_DIR := $(HOME)/mine/gerbil-qt/vendor .PHONY: all build rebuild run test-tier0 test-tier2 test-tier3 test-tier4 test-tier5 test-org test-extra test clean clean-generated \ test-org-duration test-org-element test-org-fold test-org-footnote \ test-org-lint test-org-num test-org-property test-org-src test-org-tempo \ - test-vtscreen test-debug-repl test-qt build-qt \ - test-emacs test-functional test-term-hang + test-vtscreen test-debug-repl test-qt build-qt binary binary-qt \ + test-emacs test-functional test-term-hang \ + docker-deps static-qt clean-docker check-root build-jemacs-qt-static all: build test @@ -163,8 +166,8 @@ test-vtscreen: test-debug-repl: $(SCHEME) $(LIBDIRS) --program tests/test-debug-repl.ss -test-qt: - $(SCHEME) $(LIBDIRS) --script tests/test-qt.ss +test-qt: build + QT_QPA_PLATFORM=offscreen $(SCHEME) $(LIBDIRS) --script tests/test-qt.ss test-emacs: $(SCHEME) $(LIBDIRS) --program tests/test-emacs.ss @@ -175,6 +178,124 @@ test-functional: test-term-hang: $(SCHEME) $(LIBDIRS) --program tests/test-term-hang.ss +binary: build + $(SCHEME) $(LIBDIRS) --script build-binary.ss + +binary-qt: build + $(SCHEME) $(LIBDIRS) --script build-binary-qt.ss + +# ============================================================================= +# Static binary builds (Docker-based, Alpine musl) +# ============================================================================= + +ARCH := $(shell uname -m) +UID := $(shell id -u) +GID := $(shell id -g) + +# Dependency source directories (all ~/mine/* local checkouts) +JERBOA_SRC ?= $(HOME)/mine/jerboa +GHERKIN_SRC ?= $(HOME)/mine/gherkin +JSH_SRC ?= $(HOME)/mine/jerboa-shell +PCRE2_SRC ?= $(HOME)/mine/chez-pcre2 +SCI_SRC ?= $(HOME)/mine/chez-scintilla +QT_SRC ?= $(HOME)/mine/chez-qt +QTSHIM_SRC ?= $(HOME)/mine/gerbil-qt + +DEPS_IMAGE := jemacs-deps:$(ARCH) + +# Build intermediate deps Docker image (run once, or when deps change). +# Takes ~45-60 min: Qt6 static + QScintilla + Chez Scheme + all shims. +docker-deps: + DOCKER_BUILDKIT=1 docker build \ + --build-arg ARCH=$(ARCH) \ + --build-context jerboa-src=$(JERBOA_SRC) \ + --build-context gherkin-src=$(GHERKIN_SRC) \ + --build-context jsh-src=$(JSH_SRC) \ + --build-context pcre2-src=$(PCRE2_SRC) \ + --build-context sci-src=$(SCI_SRC) \ + --build-context qt-src=$(QT_SRC) \ + --build-context qtshim-src=$(QTSHIM_SRC) \ + -t $(DEPS_IMAGE) \ + $(CURDIR) + +# Fast static Qt binary via Docker (requires deps image from `make docker-deps`). +# Builds only jemacs-qt itself (~5-10 min). Output: ./jemacs-qt (static ELF). +static-qt: linux-static-qt-docker + +clean-docker: + -docker run --rm -v $(CURDIR):/src:z alpine sh -c "rm -rf /src/jemacs-qt /src/jemacs-qt.boot /src/qt-main.so /src/qt-main.wpo /src/jemacs-qt-all.so 2>/dev/null; true" + +check-root: + @if [ "$$(id -u)" = "0" ]; then \ + git config --global --add safe.directory '*'; \ + fi + +# In-container build target (called by linux-static-qt-docker) +# Chez machine type on Alpine x86_64 is ta6le (same as glibc Linux). +# Auto-detect the versioned csv* subdirectory (e.g. csv10.4.0-pre-release.3/ta6le). +CHEZ_MT ?= ta6le +CHEZ_MUSL_DIR ?= $(shell ls -d /opt/chez/lib/csv*/$(CHEZ_MT) 2>/dev/null | head -1) + +build-jemacs-qt-static: check-root + cd /src && make build SCHEME=/opt/chez/bin/scheme JERBOA=/deps/jerboa && \ + if [ -f /src/vendor/qt_shim.cpp ]; then \ + echo "Rebuilding libqt_shim.a from updated qt_shim.cpp..." && \ + QT_CFLAGS=$$(pkg-config --cflags Qt6Widgets 2>/dev/null || \ + echo "-I/opt/qt6-static/include -I/opt/qt6-static/include/QtCore \ + -I/opt/qt6-static/include/QtGui -I/opt/qt6-static/include/QtWidgets") && \ + QSCI_FLAGS="-DQT_SCINTILLA_AVAILABLE -I/opt/qt6-static/include -I/opt/qt6-static/include/Qsci" && \ + cp /src/vendor/qt_shim.cpp /deps/gerbil-qt/vendor/qt_shim.cpp && \ + g++ -c -fPIC -std=c++17 $$QT_CFLAGS $$QSCI_FLAGS \ + /deps/gerbil-qt/vendor/qt_shim.cpp \ + -o /deps/gerbil-qt/vendor/qt_shim_static.o && \ + ar rcs /deps/gerbil-qt/vendor/libqt_shim.a \ + /deps/gerbil-qt/vendor/qt_shim_static.o; \ + fi && \ + cp /src/vendor/chez-qt-ffi-static.ss /deps/chez-qt/chez-qt/ffi.ss && \ + cp /src/vendor/chez-qt-qt.ss /deps/chez-qt/chez-qt/qt.ss && \ + /opt/chez/bin/scheme --libdirs /deps/chez-qt \ + --compile-imported-libraries --script /deps/chez-qt/compile-libs.ss && \ + rm -f /deps/chez-qt/chez-qt/*.wpo && \ + cp /src/vendor/chez-pcre2-ffi-static.ss /deps/chez-pcre2/chez-pcre2/ffi.ss && \ + /opt/chez/bin/scheme --libdirs /deps/chez-pcre2 \ + --compile-imported-libraries --script /src/vendor/chez-pcre2-compile-libs.ss && \ + rm -f /deps/chez-pcre2/chez-pcre2/*.wpo && \ + cp /src/vendor/chez-scintilla-ffi-static.sls /deps/chez-scintilla/src/chez-scintilla/ffi.sls && \ + JEMACS_STATIC=1 /opt/chez/bin/scheme --libdirs /deps/chez-scintilla/src \ + --compile-imported-libraries --script /src/vendor/chez-scintilla-compile-libs.ss && \ + rm -f /deps/chez-scintilla/src/chez-scintilla/*.wpo && \ + cp /src/vendor/jerboa-net-tcp-static.sls /deps/jerboa/lib/std/net/tcp.sls && \ + rm -f /deps/jerboa/lib/std/net/*.wpo && \ + JEMACS_STATIC=1 /opt/chez/bin/scheme --libdirs /deps/jerboa/lib \ + --compile-imported-libraries --script /src/vendor/jerboa-compile-tcp.ss && \ + rm -f /deps/jerboa/lib/std/net/*.wpo && \ + JEMACS_STATIC=1 \ + CHEZ_DIR=$(CHEZ_MUSL_DIR) \ + JERBOA_DIR=/deps/jerboa/lib \ + JSH_DIR=/deps/jsh/src \ + GHERKIN_DIR=/deps/gherkin/src \ + CHEZ_PCRE2_DIR=/deps/chez-pcre2 \ + CHEZ_SCINTILLA_DIR=/deps/chez-scintilla/src \ + CHEZ_QT_DIR=/deps/chez-qt \ + CHEZ_QT_SHIM_DIR=/deps/gerbil-qt/vendor \ + PKG_CONFIG_PATH=/opt/qt6-static/lib/pkgconfig \ + /opt/chez/bin/scheme \ + --libdirs lib:/deps/jerboa/lib:/deps/jsh/src:/deps/gherkin/src:/deps/chez-pcre2:/deps/chez-scintilla/src:/deps/chez-qt \ + --script build-binary-qt.ss + +linux-static-qt-docker: + @docker image inspect $(DEPS_IMAGE) >/dev/null 2>&1 || \ + { echo "ERROR: Deps image '$(DEPS_IMAGE)' not found. Run 'make docker-deps' first."; exit 1; } + docker run --rm \ + --ulimit nofile=8192:8192 \ + -v $(CURDIR):/src:z \ + $(DEPS_IMAGE) \ + sh -c "chmod 755 /root && \ + chown -R $(UID):$(GID) /opt/ /deps && \ + mkdir -p /tmp/jemacs-build && chown $(UID):$(GID) /tmp/jemacs-build && \ + exec su-exec $(UID):$(GID) env HOME=/tmp/jemacs-build sh -c '\ + cd /src && make build-jemacs-qt-static'" + clean: find lib -name '*.so' -delete 2>/dev/null; true --- a/lib/jerboa-emacs/debug-repl.sls +++ b/lib/jerboa-emacs/debug-repl.sls @@ -8,152 +8,207 @@ (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex mutex? mutex-name) - (std sugar) (std srfi srfi-13) (std net tcp) (jerboa core) - (jerboa runtime)) - (def *debug-repl-server* #f) - (def *debug-repl-actual-port* #f) - (def *debug-repl-port-file* + (std sugar) (std srfi srfi-13) (jerboa repl-socket) + (jerboa-emacs async) (jerboa core) (jerboa runtime)) + (def *repl-listen-fd* #f) + (def *repl-client-fd* #f) + (def *repl-line-buf* "") + (def *repl-actual-port* #f) + (def *repl-token* #f) + (def *repl-authed* #f) + (def *repl-prompted* #f) + (def *repl-port-file* (string-append (getenv "HOME") "/.jerboa-repl-port")) (def (write-repl-port-file! port-num) (delete-repl-port-file!) (call-with-output-file - *debug-repl-port-file* + *repl-port-file* (lambda (p) (display "PORT=" p) (display port-num p) (newline p)))) (def (delete-repl-port-file!) - (when (file-exists? *debug-repl-port-file*) + (when (file-exists? *repl-port-file*) (with-catch (lambda _ (void)) - (lambda () (delete-file *debug-repl-port-file*))))) + (lambda () (delete-file *repl-port-file*))))) + (def (repl-send! str) + "Send a string to the connected client. No-op if no client." + (when *repl-client-fd* + (unless (repl-socket-write *repl-client-fd* str) + (repl-disconnect!)))) + (def (repl-disconnect!) + "Close the client connection and reset state for next accept." + (when *repl-client-fd* + (with-catch + (lambda _ (void)) + (lambda () (repl-socket-close *repl-client-fd*)))) + (set! *repl-client-fd* #f) (set! *repl-line-buf* "") + (set! *repl-authed* #f) (set! *repl-prompted* #f)) (def help-text - " ,help This help message\n ,threads List active threads\n ,buffers List open buffers\n ,state Show state summary\n ,gc Force GC and show heap info\n ,quit Close this REPL connection\n <expr> Evaluate arbitrary Chez Scheme expression\n") - (def (read-line-safe port) - "Read a line safely; return #f on error or EOF." - (with-catch - (lambda (e) #f) - (lambda () - (let ([line (get-line port)]) - (if (eof-object? line) #f line))))) - (def (write-safe port str) - "Write a string to port, flushing afterward; ignore errors." - (with-catch - (lambda _ (void)) - (lambda () (put-string port str) (flush-output-port port)))) - (def (handle-client! in-port out-port token) - (when token - (let ([line (read-line-safe in-port)]) - (unless (and (string? line) - (string=? (string-trim-both line) token)) - (write-safe out-port "Access denied.\n") - (with-catch - (lambda _ (void)) - (lambda () (close-port in-port))) - (with-catch - (lambda _ (void)) - (lambda () (close-port out-port))) - (error "debug-repl" "access denied")))) - (write-safe - out-port - "jerboa debug REPL — type ,help for commands\n") - (let loop () - (write-safe out-port "jerboa-dbg> \n") - (let ([line (read-line-safe in-port)]) - (when (and line (not (eof-object? line))) - (let ([cmd (string-trim-both line)]) - (cond - [(string=? cmd "") (loop)] - [(string=? cmd ",quit") - (write-safe out-port "Connection closed.\n")] - [(string=? cmd ",help") - (write-safe out-port help-text) - (loop)] - [(string=? cmd ",threads") - (write-safe out-port " debug-repl accept (active)\n") - (loop)] - [(string=? cmd ",buffers") - (write-safe - out-port - " (no buffer list in this context)\n") - (loop)] - [(string=? cmd ",state") - (write-safe - out-port - " buffers: 0 buffer(s)\n threads: (active)\n") - (loop)] - [(string=? cmd ",gc") - (write-safe - out-port - (string-append - " GC done. bytes-allocated: " - (number->string (bytes-allocated)) - "\n")) - (loop)] - [else - (with-catch - (lambda (e) - (let ([msg (with-catch - (lambda (e2) "unknown error") - (lambda () - (with-output-to-string - "" - (lambda () - (display-condition - e - (current-output-port))))))]) - (write-safe - out-port - (string-append "ERROR: " msg "\n")))) - (lambda () - (let* ([result (eval - (read (open-input-string cmd)) - (interaction-environment))] - [out (open-output-string)]) - (write result out) - (write-safe - out-port - (string-append (get-output-string out) "\n"))))) - (loop)])))))) - (def (accept-loop srv token) + " ,help This help message\n ,threads List active threads\n ,state Show state summary\n ,gc Force GC and show heap info\n ,quit Close this REPL connection\n <expr> Evaluate arbitrary Chez Scheme expression\n") + (def (process-repl-line! line) + "Process one REPL command line. Returns #t to continue, #f to disconnect." + (let ([cmd (string-trim-both line)]) + (cond + [(string=? cmd "") #t] + [(string=? cmd ",quit") + (repl-send! "Connection closed.\n") + #f] + [(string=? cmd ",help") (repl-send! help-text) #t] + [(string=? cmd ",threads") + (with-catch + (lambda (e) (repl-send! " (error listing threads)\n")) + (lambda () (repl-send! " master-timer (active)\n"))) + #t] + [(string=? cmd ",state") + (repl-send! + (string-append " listen-fd: " (number->string (or *repl-listen-fd* -1)) + "\n client-fd: " (number->string (or *repl-client-fd* -1)) + "\n bytes-allocated: " (number->string (bytes-allocated)) + "\n")) + #t] + [(string=? cmd ",gc") + (with-catch + (lambda (e) + (repl-send! + (string-append + " GC skipped (would deadlock). bytes-allocated: " + (number->string (bytes-allocated)) + "\n"))) + (lambda () + (collect 0) + (repl-send! + (string-append + " GC done (gen 0). bytes-allocated: " + (number->string (bytes-allocated)) + "\n")))) + #t] + [else + (with-catch + (lambda (e) + (let ([msg (with-catch + (lambda (e2) "unknown error") + (lambda () + (with-output-to-string + (lambda () + (display-condition + e + (current-output-port))))))]) + (repl-send! (string-append "ERROR: " msg "\n")))) + (lambda () + (let* ([result (eval + (read (open-input-string cmd)) + (interaction-environment))] + [out (open-output-string)]) + (write result out) + (repl-send! + (string-append (get-output-string out) "\n"))))) + #t]))) + (def (debug-repl-tick!) + "Non-blocking REPL poll. Called from the master timer.\n Tries to accept a connection or read data from an existing client." + (when *repl-listen-fd* + (with-catch + (lambda (e) (void)) + (lambda () + (cond + [(not *repl-client-fd*) + (let ([cfd (repl-socket-accept *repl-listen-fd*)]) + (when cfd + (set! *repl-client-fd* cfd) + (set! *repl-line-buf* "") + (set! *repl-prompted* #f) + (if *repl-token* + (begin + (set! *repl-authed* #f) + (repl-send! "token: ")) + (begin + (set! *repl-authed* #t) + (repl-send! + "jerboa debug REPL — type ,help for commands\n")))))] + [*repl-client-fd* + (when (and *repl-authed* (not *repl-prompted*)) + (repl-send! "jerboa-dbg> \n") + (set! *repl-prompted* #t)) + (let ([data (repl-socket-read *repl-client-fd*)]) + (cond + [(string? data) + (set! *repl-line-buf* + (string-append *repl-line-buf* data)) + (repl-process-lines!)] + [(eq? data 'eof) (repl-disconnect!)]))]))))) + (def (repl-process-lines!) + "Extract and process complete lines from *repl-line-buf*." (let loop () - (let ([ok? (with-catch - (lambda (e) *debug-repl-server*) - (lambda () - (let-values ([(in-port out-port) (tcp-accept srv)]) - (fork-thread - (lambda () - (with-catch - (lambda _ (void)) - (lambda () - (handle-client! in-port out-port token) - (with-catch - (lambda _ (void)) - (lambda () (close-port in-port))) - (with-catch - (lambda _ (void)) - (lambda () (close-port out-port))))))) - #t)))]) - (when ok? (loop))))) + (let ([nl (repl-string-index *repl-line-buf* #\newline)]) + (when nl + (let ([line (substring *repl-line-buf* 0 nl)] + [rest (substring + *repl-line-buf* + (+ nl 1) + (string-length *repl-line-buf*))]) + (set! *repl-line-buf* rest) + (let ([line (if (and (> (string-length line) 0) + (char=? + (string-ref + line + (- (string-length line) 1)) + #\return)) + (substring + line + 0 + (- (string-length line) 1)) + line)]) + (if *repl-authed* + (let ([continue? (process-repl-line! line)]) + (if continue? + (begin (set! *repl-prompted* #f) (loop)) + (repl-disconnect!))) + (let ([tok (string-trim-both line)]) + (if (string=? tok *repl-token*) + (begin + (set! *repl-authed* #t) + (repl-send! + "jerboa debug REPL — type ,help for commands\n") + (set! *repl-prompted* #f) + (loop)) + (begin + (repl-send! "Access denied.\n") + (repl-disconnect!))))))))))) + (def (repl-string-index str ch) + "Return the index of the first occurrence of ch in str, or #f." + (let ([len (string-length str)]) + (let loop ([i 0]) + (cond + [(>= i len) #f] + [(char=? (string-ref str i) ch) i] + [else (loop (+ i 1))])))) (def (start-debug-repl! port-num . args) - "Start the TCP debug REPL on 127.0.0.1:port-num.\n Optional second argument: token string for authentication.\n Use port 0 for OS-assigned ephemeral port.\n Returns the actual port number and writes ~/.jerboa-repl-port." + "Start the TCP debug REPL on 127.0.0.1:port-num.\n Optional second argument: token string for authentication.\n Use port 0 for OS-assigned ephemeral port.\n Returns the actual port number and writes ~/.jerboa-repl-port.\n\n THREAD-FREE: Registers a periodic tick with the master timer instead\n of creating a background thread. All socket I/O is non-blocking." + (stop-debug-repl!) (let ([token (if (null? args) #f (car args))]) - (let ([srv (tcp-listen "127.0.0.1" port-num)]) - (set! *debug-repl-server* srv) - (let ([actual-port (tcp-server-port srv)]) - (set! *debug-repl-actual-port* actual-port) - (write-repl-port-file! actual-port) - (fork-thread (lambda () (accept-loop srv token))) - actual-port)))) + (let-values ([(fd actual-port) + (repl-socket-listen "127.0.0.1" port-num)]) + (set! *repl-listen-fd* fd) + (set! *repl-actual-port* actual-port) + (set! *repl-token* token) + (set! *repl-authed* (not token)) + (set! *repl-client-fd* #f) + (set! *repl-line-buf* "") + (set! *repl-prompted* #f) + (write-repl-port-file! actual-port) + (schedule-periodic! 'debug-repl 100 debug-repl-tick!) + actual-port))) (def (stop-debug-repl!) - "Stop the debug REPL server and clean up the port file." - (when *debug-repl-server* + "Stop the debug REPL server and clean up." + (repl-disconnect!) + (when *repl-listen-fd* (with-catch (lambda _ (void)) - (lambda () (tcp-close *debug-repl-server*))) - (set! *debug-repl-server* #f) - (set! *debug-repl-actual-port* #f)) + (lambda () (repl-socket-close *repl-listen-fd*))) + (set! *repl-listen-fd* #f) + (set! *repl-actual-port* #f)) (delete-repl-port-file!)) (def (debug-repl-port) "Return the actual port number the debug REPL is listening on, or #f if stopped." - *debug-repl-actual-port*)) + *repl-actual-port*)) --- a/lib/jerboa-emacs/pty.sls +++ b/lib/jerboa-emacs/pty.sls @@ -26,11 +26,17 @@ ;;; Load the C shim shared library ;;; ======================================================================== + (define static-build? + (let ((v (getenv "JEMACS_STATIC"))) + (and v (not (string=? v "")) (not (string=? v "0"))))) + (define pty-shim-loaded - (load-shared-object - (let ((dir (or (getenv "JERBOA_EMACS_SUPPORT") - (string-append (or (getenv "HOME") ".") "/mine/jerboa-emacs/support")))) - (string-append dir "/pty_shim.so")))) + (if static-build? + #f ; symbols already linked in via Sforeign_symbol registration + (load-shared-object + (let ((dir (or (getenv "JERBOA_EMACS_SUPPORT") + (string-append (or (getenv "HOME") ".") "/mine/jerboa-emacs/support")))) + (string-append dir "/pty_shim.so"))))) ;;; ======================================================================== ;;; FFI bindings --- a/lib/jerboa-emacs/qt/app.sls +++ b/lib/jerboa-emacs/qt/app.sls @@ -3,12 +3,68 @@ ;;; Source: src/jerboa-emacs/qt/app.ss (library (jerboa-emacs qt app) - (export qt-main qt-open-file!) + (export qt-main qt-open-file! qt-do-init!) (import (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex mutex? mutex-name) - (std sugar) (std misc string) (jerboa-emacs qt sci-shim) + (std sugar) (std misc string) (chez-scintilla constants) + (jerboa-emacs qt sci-shim) + (except (chez-qt qt) QT_MOD_NONE QT_MOD_SHIFT QT_MOD_CONTROL + QT_MOD_ALT QT_MOD_META QT_KEY_ESCAPE QT_KEY_BACKSPACE + QT_KEY_RETURN QT_KEY_ENTER QT_KEY_DELETE QT_KEY_TAB + QT_KEY_BACKTAB QT_KEY_INSERT QT_KEY_HOME QT_KEY_END + QT_KEY_LEFT QT_KEY_RIGHT QT_KEY_UP QT_KEY_DOWN + QT_KEY_PAGE_UP QT_KEY_PAGE_DOWN QT_KEY_SPACE QT_KEY_F1 + QT_KEY_F2 QT_KEY_F3 QT_KEY_F4 QT_KEY_F5 QT_KEY_F6 QT_KEY_F7 + QT_KEY_F8 QT_KEY_F9 QT_KEY_F10 QT_KEY_F11 QT_KEY_F12 + QT_CURSOR_UP QT_CURSOR_DOWN QT_CURSOR_START QT_CURSOR_END + QT_CURSOR_START_OF_BLOCK QT_CURSOR_END_OF_BLOCK + QT_CURSOR_NEXT_CHAR QT_CURSOR_NEXT_WORD + QT_CURSOR_PREVIOUS_CHAR QT_CURSOR_PREVIOUS_WORD + qt-plain-text-edit-create qt-plain-text-edit-set-text! + qt-plain-text-edit-text qt-plain-text-edit-append! + qt-plain-text-edit-clear! qt-plain-text-edit-set-read-only! + qt-plain-text-edit-read-only? + qt-plain-text-edit-set-placeholder! + qt-plain-text-edit-line-count + qt-plain-text-edit-set-max-block-count! + qt-plain-text-edit-cursor-line + qt-plain-text-edit-cursor-column + qt-plain-text-edit-set-line-wrap! + qt-plain-text-edit-cursor-position + qt-plain-text-edit-set-cursor-position! + qt-plain-text-edit-move-cursor! + qt-plain-text-edit-select-all! + qt-plain-text-edit-selected-text + qt-plain-text-edit-selection-start + qt-plain-text-edit-selection-end + qt-plain-text-edit-set-selection! + qt-plain-text-edit-has-selection? + qt-plain-text-edit-insert-text! + qt-plain-text-edit-remove-selected-text! + qt-plain-text-edit-undo! qt-plain-text-edit-redo! + qt-plain-text-edit-can-undo? qt-plain-text-edit-cut! + qt-plain-text-edit-copy! qt-plain-text-edit-paste! + qt-plain-text-edit-text-length qt-plain-text-edit-text-range + qt-plain-text-edit-line-from-position + qt-plain-text-edit-line-end-position + qt-plain-text-edit-find-text + qt-plain-text-edit-ensure-cursor-visible! + qt-plain-text-edit-center-cursor! qt-text-document-create + qt-plain-text-document-create qt-text-document-destroy! + qt-plain-text-edit-document qt-plain-text-edit-set-document! + qt-text-document-modified? qt-text-document-set-modified! + qt-syntax-highlighter-create qt-syntax-highlighter-destroy! + qt-syntax-highlighter-add-rule! + qt-syntax-highlighter-add-keywords! + qt-syntax-highlighter-add-multiline-rule! + qt-syntax-highlighter-clear-rules! + qt-syntax-highlighter-rehighlight! + qt-line-number-area-create qt-line-number-area-destroy! + qt-line-number-area-set-visible! + qt-line-number-area-set-bg-color! + qt-line-number-area-set-fg-color!) (jerboa-emacs core) (jerboa-emacs async) (jerboa-emacs editor) (only (jerboa-emacs persist) init-file-load! detect-major-mode @@ -338,12 +394,10 @@ (string-length (qt-plain-text-edit-text ed))) (qt-plain-text-edit-ensure-cursor-visible! ed))) (loop (cdr wins))))))]))) - (def (qt-do-init! qt-app args) (init-gemacs-log!) + (def (qt-do-init! qt-app args) (init-jemacs-log!) (when (member "--verbose" args) (let ([vpath (init-verbose-log!)]) - (qt-verbose-log-enable! vpath) - (verbose-log! - "gemacs-qt verbose mode ON (C-level BQC tracing also active)"))) + (verbose-log! "gemacs-qt verbose mode ON"))) (define-standard-faces!) (let-values ([(saved-theme saved-font-family saved-font-size) (theme-settings-load!)]) @@ -359,17 +413,17 @@ (load-theme! *current-theme*) (custom-faces-load!) (qt-app-set-style-sheet! qt-app (theme-stylesheet)) (let* ([win (qt-main-window-create)] - [central (qt-widget-create 'parent: win)] + [central (qt-widget-create win)] [layout (qt-vbox-layout-create central)] - [tab-bar (qt-widget-create 'parent: central)] + [tab-bar (qt-widget-create central)] [tab-layout (qt-hbox-layout-create tab-bar)] - [splitter (qt-splitter-create QT_VERTICAL 'parent: central)] + [splitter (qt-splitter-create QT_VERTICAL central)] [_ (begin (qt-splitter-set-handle-width! splitter 3) (qt-widget-set-style-sheet! splitter "QSplitter::handle { background: #51afef; }"))] - [echo-label (qt-label-create "" 'parent: central)] + [echo-label (qt-label-create "" central)] [fr (qt-frame-init! win splitter)] [app (new-app-state fr)]) (qt-widget-set-minimum-height! tab-bar 26) @@ -411,7 +465,7 @@ (setup-default-bindings!) (setup-command-docs!) (qt-register-all-commands!) - (gemacs-log! + (jemacs-log! "commands registered: " (number->string (hash-length *all-commands*)) " total") @@ -1204,7 +1258,7 @@ 'auto-save 30000 (lambda () - (let ([save-jobs (list)]) + (let ([save-jobs '()]) (for-each (lambda (buf) (let ([path (buffer-file-path buf)]) @@ -1221,9 +1275,7 @@ [auto-path (qt-make-auto-save-path path)]) (set! save-jobs - (cons - (list auto-path . text) - save-jobs))) + (cons (cons auto-path text) save-jobs))) (loop (cdr wins)))))))) (buffer-list)) (when (pair? save-jobs) @@ -1234,7 +1286,7 @@ (lambda (job) (with-catch (lambda (e) - (gemacs-log! + (jemacs-log! "Auto-save error: " (object->string e))) (lambda () @@ -1441,7 +1493,8 @@ (for-each (lambda (entry) (let ([path (car entry)] [pos (cdr entry)]) - (when (file-exists? path) + (when (and (file-exists? path) + (not (file-directory? path))) (qt-open-file! app path @@ -1507,7 +1560,7 @@ (let ([qt-app (qt-app-create)]) (try (qt-do-init! qt-app args) (qt-app-exec! qt-app) (lsp-stop!) (stop-ipc-server!) (stop-debug-repl!) - (finally (qt-app-destroy! qt-app))))) + (finally (qt-app-quit! qt-app) (qt-app-destroy! qt-app))))) (def (qt-open-file! app filename (on-loaded #f)) "Open a file or directory in a new buffer, or view an image.\n Optional on-loaded callback is called with (app buf) after text is loaded." (recent-files-add! filename) --- a/lib/jerboa-emacs/qt/buffer.sls +++ b/lib/jerboa-emacs/qt/buffer.sls @@ -8,8 +8,9 @@ (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex mutex? mutex-name) - (std sugar) (jerboa-emacs qt sci-shim) (jerboa-emacs core) - (jerboa core) (jerboa runtime)) + (std sugar) (chez-scintilla constants) + (jerboa-emacs qt sci-shim) (jerboa-emacs core) (jerboa core) + (jerboa runtime)) (def (qt-buffer-create! name editor (file-path #f)) "Create buffer with a new Scintilla document." (verbose-log! --- a/lib/jerboa-emacs/qt/commands-aliases.sls +++ b/lib/jerboa-emacs/qt/commands-aliases.sls @@ -17,7 +17,9 @@ (except (std srfi srfi-13) string-join string-trim string-prefix? string-suffix? string-contains string-index) (std misc string) (only (std misc ports) read-all-as-string) - (only (jerboa-emacs pregexp-compat) pregexp pregexp-match) + (only (jerboa-emacs pregexp-compat) pregexp pregexp-match + pregexp-match-positions pregexp-replace pregexp-replace* + pregexp-split) (only (jerboa-emacs persist) *which-key-mode* *electric-pair-mode* *copilot-mode* *centered-cursor-mode* *abbrev-mode-enabled* *auto-fill-mode*) --- a/lib/jerboa-emacs/qt/commands-aliases2.sls +++ b/lib/jerboa-emacs/qt/commands-aliases2.sls @@ -51,11 +51,13 @@ (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex mutex? mutex-name sort sort!) - (std sugar) (std sort) + (std sugar) (chez-scintilla constants) (std sort) (except (std srfi srfi-13) string-join string-trim string-prefix? string-suffix? string-contains string-index) (std misc string) (only (std misc ports) read-all-as-string) - (only (jerboa-emacs pregexp-compat) pregexp pregexp-match) + (only (jerboa-emacs pregexp-compat) pregexp pregexp-match + pregexp-match-positions pregexp-replace pregexp-replace* + pregexp-split) (jerboa-emacs qt sci-shim) (jerboa-emacs core) (jerboa-emacs editor) (jerboa-emacs qt buffer) (jerboa-emacs qt window) (jerboa-emacs qt echo) --- a/lib/jerboa-emacs/qt/commands-config.sls +++ b/lib/jerboa-emacs/qt/commands-config.sls @@ -28,7 +28,8 @@ (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex mutex? mutex-name sort sort!) - (std sugar) (std sort) (std srfi srfi-13) (std text base64) + (std sugar) (chez-scintilla constants) (std sort) + (std srfi srfi-13) (std text base64) (jerboa-emacs qt sci-shim) (jerboa-emacs core) (jerboa-emacs async) (jerboa-emacs snippets) (only (jerboa-emacs persist) record-face-customization! @@ -790,38 +791,26 @@ (define *qt-profiler-start-stats*--cell (vector #f)) (define *profiler-data*--cell (vector (hash))) (def (cmd-profiler-start app) - "Start profiling (records start time and GC stats)." + "Start profiling (records start time)." (set! *qt-profiler-running* #t) - (set! *qt-profiler-start-stats* (process-statistics)) + (set! *qt-profiler-start-stats* + (time->seconds (current-time))) (echo-message! (app-state-echo app) "Profiler started")) (def (cmd-profiler-stop app) "Stop profiler and show timing report." (if *qt-profiler-running* - (let* ([end-stats (process-statistics)] + (let* ([end-time (time->seconds (current-time))] [start *qt-profiler-start-stats*] - [wall (- (f64vector-ref end-stats 2) - (f64vector-ref start 2))] - [user (- (f64vector-ref end-stats 0) - (f64vector-ref start 0))] - [sys (- (f64vector-ref end-stats 1) - (f64vector-ref start 1))] - [gc (- (f64vector-ref end-stats 5) - (f64vector-ref start 5))] - [alloc (inexact->exact - (- (f64vector-ref end-stats 4) - (f64vector-ref start 4)))] + [wall (- end-time (if (number? start) start end-time))] [fmt (lambda (v) (number->string (/ (round (* v 1000)) 1000.0)))] - [report (string-append "=== Profiler Report ===\n\n" "Wall time: " - (fmt wall) "s\n" "User CPU: " (fmt user) - "s\n" "System CPU: " (fmt sys) "s\n" - "GC time: " (fmt gc) "s\n" "Allocated: " - (number->string alloc) " bytes\n")]) + [report (string-append + "=== Profiler Report ===\n\n" + "Wall time: " + (fmt wall) + "s\n")]) (set! *qt-profiler-running* #f) (hash-put! *profiler-data* "wall-time" wall) - (hash-put! *profiler-data* "user-cpu" user) - (hash-put! *profiler-data* "system-cpu" sys) - (hash-put! *profiler-data* "gc-time" gc) (let* ([ed (current-qt-editor app)] [fr (app-state-frame app)] [buf (or (buffer-by-name "*Profiler Report*") @@ -889,7 +878,6 @@ (with-catch (lambda (e) (let ([msg (with-output-to-string - "" (lambda () (display-exception e)))]) (gemacs-log! "cmd-term: gsh init failed: " msg) (verbose-log! "cmd-term: gsh init FAILED: " msg) --- a/lib/jerboa-emacs/qt/commands-config2.sls +++ b/lib/jerboa-emacs/qt/commands-config2.sls @@ -42,8 +42,9 @@ (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex mutex? mutex-name sort sort!) - (std sugar) (std sort) (std srfi srfi-13) - (jerboa-emacs qt sci-shim) (jerboa-emacs core) + (std sugar) (chez-scintilla constants) (std sort) + (std srfi srfi-13) (jerboa-emacs qt sci-shim) + (jerboa-emacs core) (only (jerboa-emacs persist) *fill-column*) (jerboa-emacs async) (jerboa-emacs editor) (jerboa-emacs qt buffer) (jerboa-emacs qt window) @@ -752,9 +753,9 @@ (lambda () *hl-todo-keywords*) (lambda (v) (set! *hl-todo-keywords* - (string-tokenize - v - (char-set-complement (char-set #\,))))))) + (filter + (lambda (s) (> (string-length s) 0)) + (string-split v #\,)))))) ("so-long-threshold" (cons (lambda () *so-long-threshold*) @@ -1236,7 +1237,7 @@ (if (null? output) (echo-message! echo "No uncommitted changes") (let* ([hunks (filter - identity + (lambda (x) x) (map (lambda (line) (if (and (>= (string-length line) --- a/lib/jerboa-emacs/qt/commands-core.sls +++ b/lib/jerboa-emacs/qt/commands-core.sls @@ -11,11 +11,11 @@ *qt-app-ptr* *tab-bar-visible* qt-kill-ring-push! qt-clipboard-or-kill-ring *current-theme* theme-color load-theme! load-theme define-theme! theme-stylesheet - apply-theme! make-auto-save-path *buffer-recent* - buffer-touch! buffer-names-mru *global-auto-revert-mode* - *file-mtimes* *auto-revert-tail-buffers* file-mtime - file-mtime-record! file-mtime-changed? *dir-locals-cache* - find-dir-locals-file read-dir-locals update-mark-region! + apply-theme! *buffer-recent* buffer-touch! buffer-names-mru + *global-auto-revert-mode* *file-mtimes* + *auto-revert-tail-buffers* file-mtime file-mtime-record! + file-mtime-changed? *dir-locals-cache* find-dir-locals-file + read-dir-locals update-mark-region! collapse-selection-to-caret! cmd-forward-char cmd-backward-char eshell-on-input-line? eshell-current-input eshell-replace-input! cmd-next-line cmd-previous-line @@ -42,15 +42,15 @@ (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex mutex? mutex-name sort sort!) - (std sugar) (std sort) (std srfi srfi-13) (std text base64) - (std text json) (std net uri) (jerboa-emacs qt sci-shim) - (jerboa-emacs core) (jerboa-emacs subprocess) - (jerboa-emacs editor) (jerboa-emacs repl) - (jerboa-emacs eshell) (jerboa-emacs shell) - (jerboa-emacs terminal) (jerboa-emacs qt buffer) - (jerboa-emacs qt window) (jerboa-emacs persist) - (jerboa-emacs qt echo) (jerboa-emacs qt highlight) - (jerboa-emacs qt modeline) + (std sugar) (chez-scintilla constants) (std sort) + (std srfi srfi-13) (std text base64) (std text json) + (jerboa-emacs qt sci-shim) (jerboa-emacs core) + (jerboa-emacs subprocess) (jerboa-emacs editor) + (jerboa-emacs repl) (jerboa-emacs eshell) + (jerboa-emacs shell) (jerboa-emacs terminal) + (jerboa-emacs qt buffer) (jerboa-emacs qt window) + (jerboa-emacs persist) (jerboa-emacs qt echo) + (jerboa-emacs qt highlight) (jerboa-emacs qt modeline) (only (jerboa-emacs editor-core) paredit-delimiter? @@ -285,10 +285,6 @@ (for-each (lambda (buf) (qt-setup-highlighting! app buf)) (buffer-list)))) - (def (make-auto-save-path path) - (let* ([dir (path-directory path)] - [name (path-strip-directory path)]) - (path-expand (string-append "#" name "#") dir))) (define *buffer-recent*--cell (vector (list))) (def (buffer-touch! buf) "Record buffer as most recently used." --- a/lib/jerboa-emacs/qt/commands-core2.sls +++ b/lib/jerboa-emacs/qt/commands-core2.sls @@ -12,23 +12,23 @@ cmd-toggle-centered-cursor-mode *qt-tab-width* cmd-tab-to-tab-stop cmd-set-tab-width qt-json-pretty-print cmd-json-format-buffer cmd-json-minify-buffer - cmd-json-pretty-print-region cmd-url-encode-region - cmd-url-decode-region qt-reverse-lines-in-string - cmd-reverse-lines qt-shuffle cmd-shuffle-lines - cmd-xml-format qt-find-url-at-point cmd-open-url-at-point - cmd-compare-windows cmd-dedent-region cmd-count-words-line - cmd-diff-goto-source cmd-find-file-by-path - cmd-insert-date-iso cmd-org-schedule cmd-org-deadline - cmd-org-insert-src-block *qt-org-clock-line* - *qt-org-clock-heading* qt-count-lines-before - cmd-org-clock-in cmd-org-clock-out cmd-org-clock-cancel - cmd-org-clock-goto) + cmd-json-pretty-print-region uri-encode uri-decode + cmd-url-encode-region cmd-url-decode-region + qt-reverse-lines-in-string cmd-reverse-lines qt-shuffle + cmd-shuffle-lines cmd-xml-format qt-find-url-at-point + cmd-open-url-at-point cmd-compare-windows cmd-dedent-region + cmd-count-words-line cmd-diff-goto-source + cmd-find-file-by-path cmd-insert-date-iso cmd-org-schedule + cmd-org-deadline cmd-org-insert-src-block + *qt-org-clock-line* *qt-org-clock-heading* + qt-count-lines-before cmd-org-clock-in cmd-org-clock-out + cmd-org-clock-cancel cmd-org-clock-goto) (import (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex mutex? mutex-name sort sort!) (std sugar) (std sort) (std srfi srfi-13) (std text base64) - (std text json) (std net uri) (jerboa-emacs qt sci-shim) + (std text json) (jerboa-emacs qt sci-shim) (jerboa-emacs core) (jerboa-emacs subprocess) (jerboa-emacs editor) (jerboa-emacs repl) (jerboa-emacs eshell) (jerboa-emacs shell) @@ -322,6 +322,54 @@ (echo-message! (app-state-echo app) "JSON formatted")))))))) + (def (uri-encode str) + (let ([out (open-output-string)]) + (string-for-each + (lambda (ch) + (let ([code (char->integer ch)]) + (if (or (and (>= code 65) (<= code 90)) + (and (>= code 97) (<= code 122)) + (and (>= code 48) (<= code 57)) + (char=? ch #\-) + (char=? ch #\_) + (char=? ch #\.) + (char=? ch #\~)) + (write-char ch out) + (begin + (write-char #\% out) + (let ([hi (arithmetic-shift code -4)] + [lo (bitwise-and code 15)]) + (write-char (string-ref "0123456789ABCDEF" hi) out) + (write-char + (string-ref "0123456789ABCDEF" lo) + out)))))) + str) + (get-output-string out))) + (def (uri-decode str) + (let ([len (string-length str)] [out (open-output-string)]) + (let loop ([i 0]) + (if (>= i len) + (get-output-string out) + (let ([ch (string-ref str i)]) + (cond + [(char=? ch #\%) + (if (>= (+ i 2) len) + (begin (write-char ch out) (loop (+ i 1))) + (let* ([h (string-ref str (+ i 1))] + [l (string-ref str (+ i 2))] + [hex (string h l)] + [code (string->number hex 16)]) + (if code + (begin + (write-char (integer->char code) out) + (loop (+ i 3))) + (begin + (write-char ch out) + (loop (+ i 1))))))] + [(char=? ch #\+) + (write-char #\space out) + (loop (+ i 1))] + [else (write-char ch out) (loop (+ i 1))])))))) (def (cmd-url-encode-region app) "URL-encode the selected region." (let* ([ed (current-qt-editor app)] --- a/lib/jerboa-emacs/qt/commands-edit.sls +++ b/lib/jerboa-emacs/qt/commands-edit.sls @@ -40,7 +40,8 @@ (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex mutex? mutex-name sort sort!) - (std sugar) (std sort) (std srfi srfi-13) (std text base64) + (std sugar) (chez-scintilla constants) (std sort) + (std srfi srfi-13) (std text base64) (jerboa-emacs qt sci-shim) (jerboa-emacs core) (jerboa-emacs async) (jerboa-emacs subprocess) (jerboa-emacs gsh-subprocess) (jerboa-emacs editor) @@ -895,7 +896,6 @@ (with-catch (lambda (e) (let ([msg (with-output-to-string - "" (lambda () (display-exception e)))]) (gemacs-log! "cmd-shell: gsh init failed: " msg) (echo-error! --- a/lib/jerboa-emacs/qt/commands-edit2.sls +++ b/lib/jerboa-emacs/qt/commands-edit2.sls @@ -36,7 +36,8 @@ (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex