├── conversions ├── gen-unicode-wide-lowest.ss ├── gen-unicode-wide-highest.ss ├── gen-unicode-wide-default.ss ├── unicode.ss ├── gen-unicode-wide-set.ss └── download_generate_unicode_wide.ss ├── .gitignore ├── doc ├── screenshot-1.png ├── screenshot-2.png ├── notes.md ├── repl_init.ss.example ├── schemesh_as_library.md ├── posix │ ├── replacements.md │ └── dir.md ├── lineedit │ ├── lineedit.md │ └── ansi.md ├── shell │ └── env.md └── comparison_with_other_shells.md ├── chezscheme.h ├── test ├── test_file.sh ├── test_file.ss ├── test.ss └── test.c ├── utils ├── find_chez_scheme_dir.sh ├── find_chez_scheme_kernel.sh ├── show_system_info.sh ├── compile_chez_batteries.ss ├── import.ss ├── countdown.c └── benchmark_async_signal_handler.c ├── wire ├── bwp.ss ├── misc.ss └── vector.ss ├── ipc ├── ipc.ss ├── fifo-common.ss └── fifo-nothread.ss ├── lineedit ├── all.ss ├── ansi.ss └── parenmatcher.ss ├── examples ├── example_schemesh_script.sh ├── example_signal_handler.ss ├── example_fd_read_u8.ss ├── example_caller.ss ├── benchmark_sort.ss └── example_multitasking.ss ├── shell ├── shell.ss ├── status.ss ├── parameters.ss ├── fds.ss ├── parameter1.ss ├── options.ss └── aliases.ss ├── bootstrap ├── chez-compat-test.rkt ├── arrow.ss └── chez-compat.rkt ├── containers ├── replacements.ss ├── containers.ss ├── containers.h ├── hashtable-accessors.ss ├── bitmap.ss ├── fxvector.ss └── macros.ss ├── default.nix ├── load.h ├── posix ├── tty.ss ├── posix.h ├── posix.ss ├── wire-status.ss ├── thread-nothread.ss ├── pid.ss └── rlimit.ss ├── .clang-format ├── eval.h ├── parser ├── r6rs.ss ├── scheme.ss └── parser.ss ├── srfi └── 18-multithreading.ss ├── port ├── http.h └── stdio.ss ├── repl └── answers.ss ├── vscreen ├── writer.ss └── vhistory.ss ├── libschemesh.ss ├── eval.c └── libscheme2k.ss /conversions/gen-unicode-wide-lowest.ss: -------------------------------------------------------------------------------- 1 | 4352 -------------------------------------------------------------------------------- /conversions/gen-unicode-wide-highest.ss: -------------------------------------------------------------------------------- 1 | 262143 -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /countdown 2 | /schemesh 3 | /schemesh_test 4 | /.vscode 5 | *.o 6 | *.so 7 | -------------------------------------------------------------------------------- /doc/screenshot-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cosmos72/schemesh/HEAD/doc/screenshot-1.png -------------------------------------------------------------------------------- /doc/screenshot-2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cosmos72/schemesh/HEAD/doc/screenshot-2.png -------------------------------------------------------------------------------- /chezscheme.h: -------------------------------------------------------------------------------- 1 | 2 | #ifndef CHEZ_SCHEME_H 3 | #define CHEZ_SCHEME_H 4 | 5 | /* system-wide scheme.h usually does not contain include guards. add them. */ 6 | #include 7 | 8 | #endif /* CHEZ_SCHEME_H */ 9 | -------------------------------------------------------------------------------- /doc/notes.md: -------------------------------------------------------------------------------- 1 | ## unexpected places that require a shell 2 | programs that start the login shell to run a program, 3 | instead of directly running the desired program: 4 | 5 | * scp runs "$SHELL -c ../ftp-server..." 6 | * gdb runs "$SHELL ? TARGET_PROGRAM_AND_ARGS" 7 | -------------------------------------------------------------------------------- /test/test_file.sh: -------------------------------------------------------------------------------- 1 | 2 | # test file read by (sh-read-file) in tests executed by test.c 3 | # contains some random shell commands that are only read, not executed 4 | 5 | BAR= 6 | foo "a b" c | bar $BAR && { echo `baz --quiet` &1 || fail --verbose } 7 | 8 | #!scheme 9 | (set! a 42) 10 | -------------------------------------------------------------------------------- /test/test_file.ss: -------------------------------------------------------------------------------- 1 | 2 | ;; test file read by (sh-read-file) in tests executed by test.c 3 | ;; contains some random Scheme source that is only read, not compiled or evaluated 4 | 5 | #!r6rs 6 | (define (fib n) 7 | (let %fib ((i n)) 8 | (if (fx>? i 2) 9 | (fx+ (%fib (fx1- i)) 10 | (%fib (fx- i 2))) 11 | 1))) 12 | 13 | #!shell 14 | FOO=bar 15 | -------------------------------------------------------------------------------- /doc/repl_init.ss.example: -------------------------------------------------------------------------------- 1 | #!shell 2 | 3 | # example file containing schemesh repl customization. 4 | # 5 | # to automatically load this file every time schemesh starts a repl, 6 | # copy it to ~/.config/schemesh/repl_init.ss 7 | 8 | alias gdb gdb -q 9 | alias grep grep --color=tty 10 | 11 | alias m less 12 | alias j jed 13 | 14 | alias b exec bash 15 | alias s exec schemesh 16 | -------------------------------------------------------------------------------- /utils/find_chez_scheme_dir.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | ( chez-scheme --verbose || chezscheme --verbose || chez --verbose || scheme --verbose ) &1 \ 3 | | grep -E '(chez|scheme)\.boot\.\.\.opened' \ 4 | | sed -e 's,^trying ,,g' \ 5 | -e 's,/chezscheme.boot...opened,,g' -e 's,/chez-scheme.boot...opened,,g' \ 6 | -e 's,/chez.boot...opened,,g' -e 's,/scheme.boot...opened,,g' 7 | -------------------------------------------------------------------------------- /utils/find_chez_scheme_kernel.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | DIR="$1" 3 | if [ "x$DIR" = "x" ]; then 4 | echo "Usage: $0 CHEZ_SCHEME_DIR" 1>&2 5 | exit 1 6 | elif [ -r "$DIR/libkernel.a" ]; then 7 | echo "-lkernel" 8 | elif [ -r "$DIR/kernel.o" ]; then 9 | echo "$DIR/kernel.o" 10 | else 11 | echo "Cannot find libkernel.a or kernel.o in Chez Scheme installation directory '$DIR'" 1>&2 12 | exit 1 13 | fi 14 | -------------------------------------------------------------------------------- /conversions/gen-unicode-wide-default.ss: -------------------------------------------------------------------------------- 1 | (or 2 | (char<=? #\x2F00 ch #\x2FD5) 3 | (char<=? #\x3250 ch #\xA48C) 4 | (char<=? #\xAC00 ch #\xD7A3) 5 | (char<=? #\xF900 ch #\xFAFF) 6 | (char<=? #\x17000 ch #\x187F7) 7 | (char<=? #\x18800 ch #\x18CD5) 8 | (char<=? #\x1B000 ch #\x1B122) 9 | (char<=? #\x1B170 ch #\x1B2FB) 10 | (char<=? #\x1F442 ch #\x1F4FC) 11 | (char<=? #\x1F947 ch #\x1F9FF) 12 | (char<=? #\x20000 ch #\x3FFFF) 13 | ) 14 | -------------------------------------------------------------------------------- /wire/bwp.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | ;; this file should be included only by file wire/get.ss 9 | 10 | (define (bwp-object) #!bwp) 11 | -------------------------------------------------------------------------------- /ipc/ipc.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | ;; define (scheme2k ipc) as a library that exports all its imported bindings 9 | (library-reexport (scheme2k ipc (0 9 2)) 10 | (import 11 | (scheme2k ipc channel) 12 | (scheme2k ipc fifo))) 13 | -------------------------------------------------------------------------------- /utils/show_system_info.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | echo "----------- lsb_release -a --------------" 3 | lsb_release -a 4 | echo "----------- uname -a --------------------" 5 | uname -a 6 | echo "----------- make --version --------------" 7 | ( make --version || gmake --version ) 2>/dev/null 8 | echo "----------- cc --version ----------------" 9 | cc --version 10 | echo "----------- chezscheme --verbose --------" 11 | ( chez-scheme --verbose || chezscheme --verbose || chez --verbose || scheme --verbose ) /dev/null 12 | echo "----------- git log -1 ------------------" 13 | git log -1 14 | -------------------------------------------------------------------------------- /lineedit/all.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | ;; define (scheme2k lineedit) as a library that exports all imported bindings 11 | (library-reexport (scheme2k lineedit (0 9 2)) 12 | (import 13 | (scheme2k lineedit ansi) 14 | (scheme2k lineedit lineedit) 15 | (scheme2k lineedit paren) 16 | (scheme2k lineedit parenmatcher) 17 | (scheme2k lineedit parser))) 18 | -------------------------------------------------------------------------------- /examples/example_schemesh_script.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env schemesh 2 | 3 | find -type f -name '*.ss' -ls 4 | 5 | $(format #t 6 | "\nrunning inside $(): \n\ 7 | sh-job-control? ~s\n\ 8 | sh-job-control-available? ~s\n\ 9 | sh-current-job ~s\n\ 10 | current-output-port ~s\n" 11 | (sh-job-control?) (sh-job-control-available?) (sh-current-job) (current-output-port)) 12 | 13 | #!scheme 14 | (format #t 15 | "\nrunning inside (): \n\ 16 | sh-job-control? ~s\n\ 17 | sh-job-control-available? ~s\n\ 18 | sh-current-job ~s\n\ 19 | current-output-port ~s\n\n" 20 | (sh-job-control?) (sh-job-control-available?) (sh-current-job) (current-output-port)) 21 | -------------------------------------------------------------------------------- /shell/shell.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | ;; define (schemesh shell) as a library that exports all its imported bindings 11 | (library-reexport (schemesh shell (0 9 2)) 12 | (import 13 | (schemesh shell autocomplete) 14 | (schemesh shell eval) 15 | (schemesh shell fds) 16 | (schemesh shell job) 17 | (schemesh shell macros) 18 | (schemesh shell parameters) 19 | (schemesh shell paths) 20 | (schemesh shell utils))) 21 | -------------------------------------------------------------------------------- /utils/compile_chez_batteries.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | ;; pure Scheme implementation of test/test.c that only compiles libchez_batteries_0.9.2.so 9 | ;; 10 | ;; It has the defect of requiring to find the correct Chez Scheme executable. 11 | 12 | 13 | ;; (top-level-program 14 | 15 | (import (chezscheme)) 16 | 17 | (parameterize ((optimize-level 2)) 18 | (compile-file "libchez_batteries.ss" "libchez_batteries_temp.so") 19 | (strip-fasl-file "libchez_batteries_temp.so" "libchez_batteries_0.9.2.so" 20 | (fasl-strip-options inspector-source source-annotations profile-source))) 21 | 22 | ;;) ; close top-level-program 23 | -------------------------------------------------------------------------------- /bootstrap/chez-compat-test.rkt: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | ;; this file can be executed with "plt-r6rs chez-compat-test.rkt" 4 | ;; 5 | ;; after installing (chez compat) library as described in sibling file "chez-compat.rkt" 6 | ;; 7 | (import (rnrs) 8 | (chez compat)) 9 | 10 | (for-each 11 | (lambda (p) (display p) (newline)) 12 | (list append! 13 | check-interrupts current-time 14 | chez:car chez:cdr chez:cons chez:list chez:pair? 15 | fx1+ fx1- fx/ #|foreign-procedure|# format 16 | list-copy #|list-head|# load-shared-object lock-object 17 | #|pariah|# 18 | read-token register-signal-handler reverse! 19 | top-level-syntax unlock-object unread-char 20 | time-second time-nanosecond tree->chez:tree 21 | void)) 22 | 23 | (call/cc 24 | (lambda (k) 25 | (with-exception-handler 26 | (lambda (ex) 27 | (display ex) 28 | (k)) 29 | (lambda () 30 | (display (foreign-procedure "Sbox" (ptr) ptr)))))) 31 | (newline) 32 | -------------------------------------------------------------------------------- /containers/replacements.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | (library (scheme2k containers replacements (0 9 2)) 11 | ;; the following functions *intentionally* conflict with R6RS and Chez Scheme 12 | ;; functions with the same names, 13 | ;; 14 | ;; because they are intended as replacements 15 | (export (rename (bytevector-sint-ref* bytevector-sint-ref) 16 | (bytevector-sint-set*! bytevector-sint-set!) 17 | (bytevector-uint-ref* bytevector-uint-ref) 18 | (bytevector-uint-set*! bytevector-uint-set!))) 19 | 20 | (import (only (scheme2k containers bytevector) 21 | bytevector-sint-ref* bytevector-sint-set*! 22 | bytevector-uint-ref* bytevector-uint-set*!))) 23 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import {} }: 2 | let 3 | versionLatest = 4 | builtins.head 5 | (builtins.match ".*Schemesh Version ([0-9.]+).*" 6 | (builtins.readFile ./bootstrap/functions.ss)); 7 | in 8 | pkgs.stdenv.mkDerivation { 9 | name = "schemesh"; 10 | version = versionLatest; 11 | src = ./.; 12 | 13 | buildInputs = [ 14 | pkgs.chez # Ubuntu: chezscheme-dev 15 | pkgs.lz4 # Ubuntu: liblz4-dev 16 | pkgs.ncurses # Ubuntu: libncurses-dev 17 | pkgs.libuuid # Ubuntu: uuid-dev 18 | pkgs.zlib # Ubuntu: zlib1g-dev 19 | ]; 20 | 21 | nativeBuildInputs = [ 22 | pkgs.patchelf 23 | ]; 24 | 25 | buildPhase = '' 26 | make -j prefix=$out 27 | ''; 28 | 29 | installPhase = '' 30 | mkdir -p $out/bin $out/lib/schemesh 31 | 32 | cp schemesh $out/bin/schemesh 33 | cp "libschemesh_${versionLatest}.so" $out/lib/schemesh/ 34 | chmod +x $out/bin/schemesh 35 | 36 | patchelf $out/bin/schemesh --set-rpath \ 37 | "${pkgs.lib.makeLibraryPath [ pkgs.ncurses pkgs.libuuid pkgs.lz4 pkgs.zlib ]}" 38 | ''; 39 | } 40 | -------------------------------------------------------------------------------- /doc/schemesh_as_library.md: -------------------------------------------------------------------------------- 1 | ## Loading schemesh as a library from plain Chez Scheme 2 | 3 | Works at least on Linux.
4 | On other systems, the commands for compiling a C shared library may differ. 5 | 6 | First, download schemesh following the [build instructions](../README.md#build-instructions) for your system.
7 | For example, on Debian Linux one would do: 8 | ```shell 9 | sudo apt update 10 | sudo apt install build-essential chezscheme-dev liblz4-dev libncurses-dev git uuid-dev zlib1g-dev 11 | git clone https://github.com/cosmos72/schemesh 12 | cd schemesh 13 | ``` 14 | 15 | Then compile schemesh as a pair of libraries: a C shared library, and a scheme one.
16 | The following commands work at least on Linux, on other systems they may differ. 17 | ```shell 18 | make clean 19 | make -j schemesh_so scheme2k_c_so 20 | ``` 21 | 22 | Finally, from Chez Scheme REPL: 23 | ```lisp 24 | (load-shared-object "./libscheme2k_c_0.9.2.so") 25 | ((foreign-procedure "scheme2k_register_c_functions" () int)) ; should return 0 26 | (load "./libschemesh_0.9.2.so") 27 | (import (schemesh)) 28 | (repl) ; optional, user can also continue with Chez Scheme REPL 29 | ``` 30 | -------------------------------------------------------------------------------- /examples/example_signal_handler.ss: -------------------------------------------------------------------------------- 1 | (library (scheme2k example signal handler (0 9 2)) 2 | (export check-interrupts init-signal-handlers) 3 | (import 4 | (rnrs) 5 | (rnrs mutable-pairs) 6 | (only (chezscheme) $primitive console-error-port format register-signal-handler top-level-bound?)) 7 | 8 | 9 | (define check-interrupts ($primitive 3 $event)) 10 | 11 | 12 | (define (handle-signal int) 13 | (let ((port (console-error-port))) 14 | (format port "received signal: ~a\n" int) 15 | (flush-output-port port))) 16 | 17 | 18 | (define (init-signal-handlers) 19 | (register-signal-handler 3 handle-signal) ; SIGQUIT on Linux 20 | (register-signal-handler 17 handle-signal) ; SIGCHLD on Linux 21 | (register-signal-handler 20 handle-signal)) ; SIGTSTP on Linux 22 | 23 | 24 | ) ; close library 25 | 26 | (when (top-level-bound? 'sh-version) 27 | (display (console-error-port) 28 | "; warning: this signal handler example should be run from vanilla Chez Scheme.\n\ 29 | ; running it from scheme2k will interfere with signal handlers installed by scheme2k.\n")) 30 | 31 | (import (scheme2k example signal handler)) 32 | -------------------------------------------------------------------------------- /containers/containers.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | ;; define (scheme2k containers) as a library that exports all its imported bindings 11 | (library-reexport (scheme2k containers (0 9 2)) 12 | (import (scheme2k containers bitmap) 13 | (scheme2k containers bytespan) 14 | (scheme2k containers bytevector) 15 | (scheme2k containers charspan) 16 | (scheme2k containers flvector) 17 | (scheme2k containers fxvector) 18 | (scheme2k containers in) 19 | (scheme2k containers gbuffer) 20 | (scheme2k containers list) 21 | (scheme2k containers hashtable) 22 | (scheme2k containers macros) 23 | (scheme2k containers sort) 24 | (scheme2k containers span) 25 | (scheme2k containers string) 26 | (scheme2k containers utf8b) 27 | (scheme2k containers vector))) 28 | -------------------------------------------------------------------------------- /containers/containers.h: -------------------------------------------------------------------------------- 1 | /** 2 | * Copyright (C) 2023-2025 by Massimiliano Ghilardi 3 | * 4 | * This library is free software; you can redistribute it and/or 5 | * modify it under the terms of the GNU Library General Public 6 | * License as published by the Free Software Foundation; either 7 | * version 2 of the License, or (at your option) any later version. 8 | */ 9 | 10 | #ifndef SCHEME2K_CONTAINERS_H 11 | #define SCHEME2K_CONTAINERS_H 12 | 13 | #include "../chezscheme.h" /* ptr */ 14 | #include /* size_t */ 15 | 16 | void scheme2k_register_c_functions_containers(void); 17 | 18 | /** 19 | * convert a C byte[] to Scheme bytevector and return it. 20 | * If len == (size_t)-1, set len = strlen(bytes). 21 | * If out of memory, or len > maximum bytevector length, raises condition. 22 | */ 23 | ptr scheme2k_Sbytevector(const char bytes[], const size_t len); 24 | 25 | /** 26 | * convert a C byte[] from UTF-8b to Scheme string and return it. 27 | * If len == (size_t)-1, set len = strlen(bytes). 28 | * If out of memory, or required string length > maximum string length, raises condition. 29 | */ 30 | ptr scheme2k_Sstring_utf8b(const char bytes[], const size_t len); 31 | 32 | #endif /* SCHEME2K_CONTAINERS_H */ 33 | -------------------------------------------------------------------------------- /conversions/unicode.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | (library (scheme2k conversions unicode (0 9 2)) 11 | (export char-display-wide?) 12 | (import 13 | (rnrs) 14 | (only (chezscheme) fx1+ include)) 15 | 16 | 17 | (define wide-table (make-eqv-hashtable)) 18 | 19 | (define (wide-set! lo hi) 20 | (do ((i lo (fx1+ i))) 21 | ((fx>? i hi)) 22 | (hashtable-set! wide-table (integer->char i) #t))) 23 | 24 | 25 | (define wide-lowest (integer->char (include "conversions/gen-unicode-wide-lowest.ss"))) 26 | (define wide-highest (integer->char (include "conversions/gen-unicode-wide-highest.ss"))) 27 | 28 | (define (char-display-wide? ch) 29 | (and 30 | (char<=? wide-lowest ch wide-highest) 31 | (or 32 | (include "conversions/gen-unicode-wide-default.ss") 33 | (hashtable-ref wide-table ch #f)))) 34 | 35 | (include "conversions/gen-unicode-wide-set.ss") 36 | 37 | ) ; close library 38 | -------------------------------------------------------------------------------- /examples/example_fd_read_u8.ss: -------------------------------------------------------------------------------- 1 | 2 | (define (loop-fd-read-u8 fd) 3 | (do ((b (fd-read-u8 fd) (fd-read-u8 fd))) 4 | ((eof-object? b)) 5 | (format (console-output-port) "read one byte: ~s\n" b) 6 | (flush-output-port (console-output-port)))) 7 | 8 | (define (loop-port-read-u8 binary-input-port) 9 | (do ((b (get-u8 binary-input-port) (get-u8 binary-input-port))) 10 | ((eof-object? b)) 11 | (format (console-output-port) "read one byte: ~s\n" b) 12 | (flush-output-port (console-output-port)))) 13 | 14 | (define (loop-port-read-char textual-input-port) 15 | (do ((ch (get-char textual-input-port) (get-char textual-input-port))) 16 | ((eof-object? ch)) 17 | (format (console-output-port) "read one char: ~s\n" ch) 18 | (flush-output-port (console-output-port)))) 19 | 20 | (define j1 {sleep 1 | {echo0 abc; sleep 2; echo def; sleep 3} | $(loop-fd-read-u8 (sh-fd 0))}) 21 | (define j2 {sleep 1 | {echo0 abc; sleep 2; echo def; sleep 3} | $(loop-port-read-u8 (sh-stdin))}) 22 | (define j3 {sleep 1 | {echo0 abc; sleep 2; echo def; sleep 3} | $(loop-port-read-char (current-input-port))}) 23 | 24 | #;(sh-run/i j1) 25 | #;(sh-run/i j2) 26 | #;(sh-run/i j3) 27 | 28 | #;(sh-run j1) 29 | #;(sh-run j2) 30 | #;(sh-run j3) 31 | 32 | (void) 33 | -------------------------------------------------------------------------------- /load.h: -------------------------------------------------------------------------------- 1 | /** 2 | * Copyright (C) 2023-2025 by Massimiliano Ghilardi 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU General Public License as published by 6 | * the Free Software Foundation; either version 2 of the License, or 7 | * (at your option) any later version. 8 | */ 9 | 10 | /** 11 | * this file contains helper functions to load schemesh library 12 | * and import its definitions. 13 | */ 14 | 15 | #include "eval.h" 16 | 17 | #define LIBSCHEMESH_SO "libschemesh_0.9.2.so" 18 | 19 | #define STR_(arg) #arg 20 | #define STR(arg) STR_(arg) 21 | 22 | /** @return 0 if successful, otherwise error code */ 23 | int schemesh_load_library(const char* override_library_dir) { 24 | const char* filename = LIBSCHEMESH_SO; 25 | int err = -1; 26 | 27 | if (override_library_dir != NULL) { 28 | err = scheme2k_load_library(override_library_dir, filename); 29 | } else { 30 | #ifdef SCHEMESH_DIR 31 | err = scheme2k_load_library(STR(SCHEMESH_DIR), filename); 32 | #endif 33 | if (err != 0) { 34 | err = scheme2k_load_library("/usr/local/lib/schemesh", filename); 35 | } 36 | if (err != 0) { 37 | err = scheme2k_load_library("/usr/lib/schemesh", filename); 38 | } 39 | } 40 | return err; 41 | } 42 | 43 | void schemesh_import_all_libraries(void) { 44 | scheme2k_eval("(import (schemesh))\n"); 45 | } 46 | -------------------------------------------------------------------------------- /posix/tty.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | (library (scheme2k posix tty (0 9 2)) 11 | (export tty-setraw! tty-restore! tty-inspect tty-size with-cooked-tty with-raw-tty) 12 | (import 13 | (rnrs) 14 | (only (chezscheme) foreign-procedure inspect)) 15 | 16 | 17 | (define tty-restore! (foreign-procedure "c_tty_restore" () int)) 18 | 19 | (define tty-setraw! (foreign-procedure "c_tty_setraw" () int)) 20 | 21 | ;; (tty-size) calls C functions c_tty_size(), 22 | ;; which returns controlling tty size as pair (width . height), or c_errno() < 0 on error 23 | (define tty-size (foreign-procedure "c_tty_size" () ptr)) 24 | 25 | (define-syntax with-cooked-tty 26 | (syntax-rules () 27 | ((_ body1 body2 ...) 28 | (dynamic-wind 29 | tty-restore! ; run before body 30 | (lambda () body1 body2 ...) 31 | tty-setraw!)))) ; run after body 32 | 33 | (define-syntax with-raw-tty 34 | (syntax-rules () 35 | ((_ body1 body2 ...) 36 | (dynamic-wind 37 | tty-setraw! ; run before body 38 | (lambda () body1 body2 ...) 39 | tty-restore!)))) ; run after body 40 | 41 | (define (tty-inspect obj) 42 | (with-cooked-tty (inspect obj))) 43 | 44 | 45 | 46 | ) ; close library 47 | -------------------------------------------------------------------------------- /containers/hashtable-accessors.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | ;; Chez Scheme hashtables can be iterated only by copying their WHOLE contents to one or more vectors, 11 | ;; or with (hash-table-for-each) that ONLY works on eq-hashtables. 12 | ;; 13 | ;; Define functions for accessing hashtables' internal bucket vector 14 | ;; and let hash-iterator iterate on them. 15 | 16 | (define (record-accessor-byname rtd name) 17 | (and rtd 18 | (let ((index (vector-index name (record-type-field-names rtd)))) 19 | (and index 20 | (record-accessor rtd index))))) 21 | 22 | (define (record-accessor-byname/recursive rtd name) 23 | (or (record-accessor-byname rtd name) 24 | (record-accessor-byname/recursive (record-type-parent rtd) name))) 25 | 26 | 27 | (define %eqv-hashtable->eq-hashtable 28 | (let ((%eqv-hashtable-rtd (record-rtd (make-eqv-hashtable)))) 29 | (record-accessor-byname %eqv-hashtable-rtd 'eqht))) 30 | 31 | (define %eqv-hashtable->gen-hashtable 32 | (let ((%eqv-hashtable-rtd (record-rtd (make-eqv-hashtable)))) 33 | (record-accessor-byname %eqv-hashtable-rtd 'genht))) 34 | 35 | (define %hashtable->vector 36 | (let ((%gen-hashtable-rtd (record-rtd (make-hashtable equal-hash equal?)))) 37 | (record-accessor-byname/recursive %gen-hashtable-rtd 'vec))) 38 | -------------------------------------------------------------------------------- /.clang-format: -------------------------------------------------------------------------------- 1 | --- 2 | Language: Cpp 3 | # BasedOnStyle: Google 4 | AccessModifierOffset: -1 5 | AlignAfterOpenBracket: Align 6 | AlignConsecutiveAssignments: true 7 | AlignConsecutiveDeclarations: true 8 | AlignEscapedNewlinesLeft: false 9 | AlignOperands: true 10 | AlignTrailingComments: true 11 | AllowAllParametersOfDeclarationOnNextLine: true 12 | AllowShortBlocksOnASingleLine: false 13 | AllowShortCaseLabelsOnASingleLine: false 14 | AllowShortFunctionsOnASingleLine: None 15 | AllowShortIfStatementsOnASingleLine: false 16 | AllowShortLoopsOnASingleLine: false 17 | AlwaysBreakAfterDefinitionReturnType: false 18 | AlwaysBreakAfterReturnType: None 19 | AlwaysBreakBeforeMultilineStrings: false 20 | AlwaysBreakTemplateDeclarations: true 21 | BinPackArguments: false 22 | BinPackParameters: false 23 | BraceWrapping: 24 | AfterClass: true 25 | BreakBeforeBinaryOperators: None 26 | BreakBeforeBraces: Custom 27 | BreakBeforeTernaryOperators: false 28 | BreakConstructorInitializersBeforeComma: true 29 | ColumnLimit: 100 30 | ConstructorInitializerAllOnOneLineOrOnePerLine: false 31 | ConstructorInitializerIndentWidth: 4 32 | Cpp11BracedListStyle: true 33 | DisableFormat: false 34 | IndentCaseLabels: true 35 | IndentWidth: 2 36 | MaxEmptyLinesToKeep: 1 37 | NamespaceIndentation: None 38 | PointerAlignment: Left 39 | ReflowComments: true 40 | SortIncludes: true 41 | SpaceAfterTemplateKeyword: true 42 | SpaceBeforeAssignmentOperators: true 43 | SpaceBeforeParens: ControlStatements 44 | SpaceInEmptyParentheses: false 45 | SpacesInAngles: false 46 | SpacesInParentheses: false 47 | SpacesInSquareBrackets: false 48 | Standard: Cpp11 49 | UseTab: Never 50 | --- 51 | Language: Proto 52 | DisableFormat: true 53 | BasedOnStyle: Google 54 | -------------------------------------------------------------------------------- /posix/posix.h: -------------------------------------------------------------------------------- 1 | /** 2 | * Copyright (C) 2023-2025 by Massimiliano Ghilardi 3 | * 4 | * This library is free software; you can redistribute it and/or 5 | * modify it under the terms of the GNU Library General Public 6 | * License as published by the Free Software Foundation; either 7 | * version 2 of the License, or (at your option) any later version. 8 | */ 9 | 10 | #ifndef SCHEME2K_POSIX_POSIX_H 11 | #define SCHEME2K_POSIX_POSIX_H 12 | 13 | /** 14 | * initialize Chez Scheme. 15 | * 16 | * if override_boot_dir != NULL, calls in sequence: 17 | * Sscheme_init(on_scheme_exception); 18 | * Sregister_boot_file(string_append(override_boot_dir, "/petite.boot")); 19 | * Sregister_boot_file(string_append(override_boot_dir, "/scheme.boot")); 20 | * Sbuild_heap(NULL, NULL); 21 | * 22 | * otherwise calls in sequence: 23 | * Sscheme_init(on_scheme_exception); 24 | * Sregister_boot_file(CHEZ_SCHEME_DIR_STR "/petite.boot"); 25 | * Sregister_boot_file(CHEZ_SCHEME_DIR_STR "/scheme.boot"); 26 | * Sbuild_heap(NULL, NULL); 27 | */ 28 | void scheme2k_init(const char* override_boot_dir, void (*on_scheme_exception)(void)); 29 | 30 | /** 31 | * quit Chez Scheme. calls: 32 | * c_tty_quit() 33 | * Sscheme_deinit() 34 | */ 35 | void scheme2k_quit(void); 36 | 37 | /** 38 | * register all C functions needed by scheme2k library. 39 | * @return < 0 if some C system call failed 40 | */ 41 | int scheme2k_register_c_functions(void); 42 | 43 | /** print error message to stderr and return -errno */ 44 | int scheme2k_init_failed(const char label[]); 45 | 46 | /** POSIX standard says programs need to declare environ by themselves */ 47 | extern char** environ; 48 | 49 | #endif /** SCHEME2K_POSIX_POSIX_H */ 50 | -------------------------------------------------------------------------------- /wire/misc.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | ;; this file should be included only by file wire/wire.ss 11 | 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | ;; customize how "time" objects are serialized/deserialized 14 | 15 | (define (len/time pos obj) 16 | (let* ((pos (tag+ pos)) 17 | (pos (len/any pos (time-type obj))) 18 | (pos (len/any pos (time-nanosecond obj))) 19 | (pos (len/any pos (time-second obj)))) 20 | pos)) 21 | 22 | (define (put/time bv pos obj) 23 | (let* ((pos (put/tag bv pos tag-time)) 24 | (pos (put/any bv pos (time-type obj))) 25 | (pos (put/any bv pos (time-nanosecond obj))) 26 | (pos (put/any bv pos (time-second obj)))) 27 | pos)) 28 | 29 | (define (get/time bv pos end) 30 | (let*-values (((type pos) (get/any bv pos end)) 31 | ((nanosecond pos) (get/any bv pos end)) 32 | ((second pos) (get/any bv pos end))) 33 | (if (and pos 34 | (memq type '(time-collector-cpu time-collector-real time-duration 35 | time-monotonic time-process time-thread time-utc)) 36 | (integer? nanosecond) (exact? nanosecond) (<= 0 nanosecond 999999999) 37 | (integer? second) (exact? second)) 38 | (values 39 | (make-time type nanosecond second) 40 | pos) 41 | (values #f #f)))) 42 | -------------------------------------------------------------------------------- /posix/posix.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | ;; define (scheme2k posix) as a library that exports all its imported bindings 11 | (library-reexport (scheme2k posix (0 9 2)) 12 | (import 13 | (scheme2k posix dir) 14 | (scheme2k posix fd) 15 | (scheme2k posix io) 16 | (scheme2k posix pattern) 17 | (scheme2k posix pid) 18 | 19 | ;; by default, do not re-export bindings from (scheme2k posix replacements) or (scheme2k posix thread) 20 | ;; because they intentionally conflict with R6RS functions (file-exists?) (delete-file) 21 | ;; (get-char) (get-datum) (get-line) (get-string-all) (get-string-n) (get-string-some) 22 | ;; and with Chez Scheme functions for accessing the filesystem and managing threads. 23 | ;; 24 | ;; Reason for the conflict: the functions in (scheme2k posix replacements) 25 | ;; are intended as replacements for the default ones, and they add UTF-8b support. 26 | ;; 27 | ;; If a user wants them, they need one of: 28 | ;; (import (scheme2k posix replacements)) 29 | ;; (import (scheme2k posix thread)) 30 | ;; (import (scheme2k)) 31 | ;; 32 | ;; as stated, do not import these: 33 | ;; 34 | ;; (scheme2k posix replacements) 35 | ;; (scheme2k posix thread) 36 | 37 | (scheme2k posix rlimit) 38 | (scheme2k posix signal) 39 | (scheme2k posix socket) 40 | (scheme2k posix status) 41 | (scheme2k posix tty))) 42 | -------------------------------------------------------------------------------- /posix/wire-status.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | ;; customize how "status" objects are serialized/deserialized 11 | 12 | (define tag-status 243) ; must match tag-status in wire/wire.ss 13 | 14 | (define known-kind (plist->eq-hashtable '(new 0 running 1 stopped 2 exception 3 failed 4 killed 5 ok 6))) 15 | 16 | (define (kind->int kind) 17 | (hashtable-ref known-kind kind #f)) 18 | 19 | (define int->kind 20 | (let ((vec (make-vector (hashtable-size known-kind)))) 21 | (for-hash ((kind int known-kind)) 22 | (vector-set! vec int kind)) 23 | (lambda (int) 24 | (if (fxval obj))) 30 | 31 | ;; tag was already read and consumed. only read serialized kind and val. 32 | (define (wire-get/status bv pos end) 33 | (let ((kind (int->kind (bytevector-u8-ref bv pos)))) 34 | (if kind 35 | (let-values (((value pos) (wire-inner-get bv (fx1+ pos) end))) 36 | (if pos 37 | (values (%make-status kind value) pos) 38 | (values #f #f))) 39 | (values #f #f)))) 40 | 41 | (define (wire-put/status bv pos obj) 42 | (let ((kind (%status->kind obj))) 43 | (bytevector-u8-set! bv pos tag-status) 44 | (bytevector-u8-set! bv (fx1+ pos) (kind->int kind)) 45 | (wire-inner-put bv (fx+ pos 2) (%status->val obj)))) 46 | -------------------------------------------------------------------------------- /eval.h: -------------------------------------------------------------------------------- 1 | /** 2 | * Copyright (C) 2023-2025 by Massimiliano Ghilardi 3 | * 4 | * This library is free software; you can redistribute it and/or 5 | * modify it under the terms of the GNU Library General Public 6 | * License as published by the Free Software Foundation; either 7 | * version 2 of the License, or (at your option) any later version. 8 | */ 9 | 10 | #ifndef SCHEME2K_EVAL_H 11 | #define SCHEME2K_EVAL_H 12 | 13 | #include "chezscheme.h" 14 | 15 | /** 16 | * call global Scheme procedure with no arguments. 17 | * Return the resulting Scheme value. 18 | */ 19 | ptr scheme2k_call0(const char symbol_name[]); 20 | 21 | /** 22 | * call global Scheme procedure having specified symbol name 23 | * passing a single Scheme argument to it. 24 | * Return the resulting Scheme value. 25 | */ 26 | ptr scheme2k_call1(const char symbol_name[], ptr arg); 27 | 28 | /** 29 | * call global Scheme procedure having specified symbol name 30 | * passing two Scheme arguments to it. 31 | * Return the resulting Scheme value. 32 | */ 33 | ptr scheme2k_call2(const char symbol_name[], ptr arg1, ptr arg2); 34 | 35 | /** 36 | * call global Scheme procedure having specified symbol name 37 | * passing three Scheme arguments to it. 38 | * Return the resulting Scheme value. 39 | */ 40 | ptr scheme2k_call3(const char symbol_name[], ptr arg1, ptr arg2, ptr arg3); 41 | 42 | /** 43 | * call Scheme (eval (read (open-string-input-port str))) on a C string 44 | * and return the resulting Scheme value. 45 | * Cannot use (sh-eval) because it may be called before loading libschemesh. 46 | */ 47 | ptr scheme2k_eval(const char str[]); 48 | 49 | /** 50 | * Load a compiled Scheme library. 51 | * 52 | * @return 0 if successful, 53 | * otherwise print error message to (current-error-port) and return < 0 54 | */ 55 | int scheme2k_load_library(const char dir[], const char filename[]); 56 | 57 | #endif /* SCHEME2K_EVAL_H */ 58 | -------------------------------------------------------------------------------- /examples/example_caller.ss: -------------------------------------------------------------------------------- 1 | (library (scheme2k example caller (0 9 2)) 2 | (export call^ apply^) 3 | (import 4 | (rnrs) 5 | (rnrs mutable-pairs) 6 | (only (chezscheme) eval-when #| format make-time sleep |# )) 7 | 8 | (eval-when (compile) (optimize-level 3) (debug-level 0)) 9 | 10 | (define resume&yield (cons #f #f)) 11 | 12 | 13 | (define (caller-loop proc-and-args) 14 | (do () (#f) 15 | ;; (format #t "; caller-loop proc-and-args=~s\n" proc-and-args) 16 | ;; (sleep (make-time 'time-duration 0 1)) 17 | (let* ((proc (car proc-and-args)) 18 | (args (cdr proc-and-args)) 19 | (rets (call-with-values 20 | (lambda () (apply proc args)) 21 | list)) 22 | (yield (cdr resume&yield))) 23 | (set-cdr! resume&yield #f) 24 | ;; (format #t "; proc rets=~s\n" rets) 25 | (set! proc-and-args 26 | (if (car resume&yield) 27 | (apply yield rets) 28 | (call/cc 29 | (lambda (resume) 30 | ;; (format #t "; installing caller-resume-proc=~s\n" resume) 31 | (set-car! resume&yield resume) 32 | (apply yield rets)))))))) 33 | 34 | 35 | (define (apply^ proc args) 36 | (call/cc 37 | (lambda (yield) 38 | ;; (format #t "; installing caller-yield-proc=~s\n" yield) 39 | (set-cdr! resume&yield yield) 40 | (let ((resume (or (car resume&yield) caller-loop))) 41 | ;; (format #t "; resuming caller-resume-proc=~s\n" resume) 42 | ;; (set-car! resume&yield #f) 43 | (resume (cons proc args)))))) 44 | 45 | 46 | ;; call a procedure from a continuation and return its value(s). 47 | ;; slow, its main purpose is that procedure is called from a different 48 | ;; dynamic context with fixed depth. 49 | (define call^ 50 | (case-lambda 51 | ((proc) (apply^ proc '())) 52 | ((proc . args) (apply^ proc args)))) 53 | 54 | ) ; close library 55 | 56 | 57 | (import (scheme2k example caller)) 58 | -------------------------------------------------------------------------------- /examples/benchmark_sort.ss: -------------------------------------------------------------------------------- 1 | 2 | ;; example file containing a benchmark for (vector-sort!) and (subvector-sort!) 3 | ;; it is not read, compiled nor evaluated. 4 | 5 | (library (scheme2k benchmark sort (0 9 2)) 6 | (export 7 | benchmark-make-vector benchmark-vector-sort! benchmark-subvector-sort! ) 8 | (import 9 | (rnrs) 10 | (only (chezscheme) eval-when fx1+ fx1- random time vector-sort!) 11 | (only (scheme2k bootstrap) assert*) 12 | (only (scheme2k containers sort) subvector-sort!) 13 | (only (scheme2k containers vector) vector-copy!)) 14 | 15 | 16 | (eval-when (compile) (optimize-level 3) (debug-level 0)) 17 | 18 | (define (benchmark-make-vector element-n) 19 | (let ((v (make-vector element-n))) 20 | (do ((i 0 (fx1+ i))) 21 | ((fx>=? i element-n) v) 22 | (vector-set! v i (random (greatest-fixnum)))))) 23 | 24 | 25 | (define (benchmark-vector-sort! element-n run-n) 26 | (assert* 'benchmark-vector-sort! (fixnum? element-n)) 27 | (assert* 'benchmark-vector-sort! (fx>=? element-n 0)) 28 | (assert* 'benchmark-vector-sort! (fixnum? run-n)) 29 | (assert* 'benchmark-vector-sort! (fx>=? run-n 0)) 30 | (let ((v0 (benchmark-make-vector element-n)) 31 | (v (make-vector element-n))) 32 | (do ((i run-n (fx1- i))) 33 | ((fx<=? i 0)) 34 | (vector-copy! v0 0 v 0 element-n) 35 | (vector-sort! fx=? element-n 0)) 41 | (assert* 'benchmark-subvector-sort! (fixnum? run-n)) 42 | (assert* 'benchmark-subvector-sort! (fx>=? run-n 0)) 43 | (let ((v0 (benchmark-make-vector element-n)) 44 | (v (make-vector element-n))) 45 | (do ((i run-n (fx1- i))) 46 | ((fx<=? i 0)) 47 | (vector-copy! v0 0 v 0 element-n) 48 | (subvector-sort! fxseconds seconds->time 23 | 24 | current-exception-handler with-exception-handler raise 25 | 26 | join-timeout-exception? abandoned-mutex-exception? terminated-thread-exception? uncaught-exception? uncaught-exception-reason 27 | |# 28 | ) 29 | (import 30 | (rnrs) 31 | (only (chezscheme) foreign-procedure sleep void) 32 | (only (scheme2k bootstrap) assert*) 33 | (only (scheme2k posix status) ok->values status->kind status->value) 34 | (scheme2k posix thread)) 35 | 36 | 37 | (define thread-join! 38 | (case-lambda 39 | ((thread timeout timeout-val) 40 | (let ((status (thread-join thread timeout))) 41 | (case (status->kind status) 42 | ((running stopped) 43 | timeout-val) 44 | ((ok) 45 | (ok->values status)) 46 | ((exception) 47 | (raise (status->value status))) 48 | (else 49 | (status->value status))))) 50 | ((thread timeout) 51 | (thread-join! thread timeout (void))) 52 | ((thread) 53 | (thread-join! thread #f (void))))) 54 | 55 | 56 | ) ; close library 57 | -------------------------------------------------------------------------------- /ipc/fifo-common.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | ;; this file should be included only by files ipc/fifo-thread.ss or ipc/fifo-nothread.ss 11 | 12 | 13 | (define-record-type (producer %make-producer producer?) 14 | (fields 15 | (mutable tail) 16 | mutex 17 | changed) 18 | (nongenerative producer-7c46d04b-34f4-4046-b5c7-b63753c1be39)) 19 | 20 | 21 | 22 | (define-record-type (consumer %make-consumer consumer?) 23 | (fields 24 | (mutable head) 25 | (mutable eof?) 26 | mutex 27 | changed) 28 | (nongenerative consumer-7c46d04b-34f4-4046-b5c7-b63753c1be39)) 29 | 30 | 31 | ;; convert one of: 32 | ;; * an exact or inexact real, indicating the number of seconds 33 | ;; * a pair (seconds . nanoseconds) where both are exact integers 34 | ;; * a time object with type 'time-duration, which is copied 35 | ;; 36 | ;; to a time object with type 'time-duration 37 | (define (make-time-duration duration) 38 | (cond 39 | ((real? duration) 40 | (let* ((seconds (exact (floor duration))) 41 | (ns (exact (round (* 1e9 (- duration seconds)))))) 42 | (make-time 'time-duration ns seconds))) 43 | ((pair? duration) 44 | (make-time 'time-duration (cdr duration) (car duration))) 45 | (else 46 | (assert* 'make-time-duration (time? duration)) 47 | (assert* 'make-time-duration (eq? 'time-duration (time-type duration))) 48 | (make-time 'time-duration (time-nanosecond duration) (time-second duration))))) 49 | 50 | 51 | ;; create and return a closure that iterates on data recreived by consumer c. 52 | ;; 53 | ;; the returned closure accepts no arguments, and each call to it returns two values: 54 | ;; either (values datum #t) i.e. the next datum received from consumer and #t, 55 | ;; or (values # #f) if consumer reached end-of-file. 56 | (define (in-consumer c) 57 | (assert* 'in-consumer (consumer? c)) 58 | (lambda () 59 | (consumer-get c))) 60 | -------------------------------------------------------------------------------- /port/http.h: -------------------------------------------------------------------------------- 1 | /** 2 | * Copyright (C) 2025 by Massimiliano Ghilardi 3 | * 4 | * This library is free software; you can redistribute it and/or 5 | * modify it under the terms of the GNU Library General Public 6 | * License as published by the Free Software Foundation; either 7 | * version 2 of the License, or (at your option) any later version. 8 | */ 9 | 10 | #ifndef SCHEME2K_PORT_HTTP_H 11 | #define SCHEME2K_PORT_HTTP_H 12 | 13 | #include /* size_t */ 14 | #include /* FILE* */ 15 | 16 | enum { HTTP_EOF = -1 }; 17 | 18 | typedef struct http_struct http; 19 | 20 | int http_global_init(void); 21 | void http_global_cleanup(void); 22 | const char* http_global_strerror(int err); 23 | 24 | http* http_new(void); 25 | void http_del(http* ctx); 26 | 27 | int http_open(http* ctx, const char* url); 28 | void http_close(http* ctx); 29 | 30 | /** 31 | * Receive up to dst_end - dst_start bytes and write them into dst[dst_start ...]. 32 | * 33 | * @return number of bytes actually read, which may also be == 0 on success, 34 | * and may also be != 0 on error. On end-of-file, returns (size_t)-1. 35 | * 36 | * To check for errors, call http_errcode() after this function returns. 37 | */ 38 | size_t http_read(http* ctx, void* dst, size_t dststart, size_t dstend); 39 | 40 | /** 41 | * Non-blocking try to receive up to dst_end - dst_start bytes and write them 42 | * into dst[dst_start ...]. 43 | * 44 | * @return number of bytes actually read, which may also be == 0 on success, 45 | * and may also be != 0 on error. On end-of-file, returns (size_t)-1. 46 | * 47 | * To check for errors, call http_errcode() after this function returns. 48 | */ 49 | size_t http_try_read(http* ctx, void* dst, size_t dststart, size_t dstend); 50 | 51 | /** 52 | * Wait up to timeout_ms milliseconds for I/O to become available on http connection. 53 | */ 54 | int http_select(http* ctx, int timeout_ms); 55 | 56 | /** @return current error, or 0 if success */ 57 | int http_errcode(http* ctx); 58 | /** Print current error to file, if any */ 59 | void http_fprint_error(http* ctx, FILE* out); 60 | /** Print current error to string buffer, if any */ 61 | size_t http_sprint_error(http* ctx, char* out, size_t outlen); 62 | 63 | #endif /* SCHEME2K_PORT_HTTP_H */ 64 | -------------------------------------------------------------------------------- /repl/answers.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | ;; this file should be included only by file repl/repl.ss 11 | 12 | 13 | ;; return span containing all recent values produced by code evaluated at REPL, 14 | ;; or n-th recent value produced by code evaluated at REPL, 15 | ;; or (void) if n is out of range. 16 | (define repl-answers 17 | (let ((ans (make-span 0))) 18 | (case-lambda 19 | (() 20 | ans) 21 | ((n) 22 | (if (fx=? new-max-len 0)) 36 | (set! max-len new-max-len))))) 37 | 38 | 39 | ;; append obj to (repl-answers) 40 | (define (repl-answers-append! obj) 41 | (let* ((ans (repl-answers)) 42 | (len (span-length ans)) 43 | (max-len (repl-answers-max-length)) 44 | (delta (fx- len max-len))) 45 | (when (fx>? delta 0) 46 | (span-fill! ans 0 delta (void)) ; helps GC 47 | (span-delete-left! ans delta)) 48 | (span-insert-right! ans obj))) 49 | 50 | 51 | ;; clear (repl-answers) 52 | (define (repl-answers-clear!) 53 | (span-clear! (repl-answers))) 54 | 55 | 56 | ;; display (repl-answers) to port, 57 | ;; which defaults to (current-output-port) 58 | (define repl-answers-display 59 | (case-lambda 60 | ((port) 61 | (let ((ans (repl-answers))) 62 | (do ((i 0 (fx1+ i)) 63 | (n (span-length ans))) 64 | ((fx>=? i n)) 65 | (write i port) 66 | (write-char #\tab port) 67 | (write (span-ref ans i) port) 68 | (newline port)))) 69 | (() 70 | (repl-answers-display (current-output-port))))) 71 | -------------------------------------------------------------------------------- /vscreen/writer.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | ;; this file should be included only by file vscreen/all.ss 11 | 12 | 13 | ;; customize how vcolors objects are printed 14 | (record-writer (record-type-descriptor %vcolors) 15 | (lambda (cols port writer) 16 | (display "(vcolors " port) 17 | (vcolor-write (vcolors->fg cols) port) 18 | (display " " port) 19 | (vcolor-write (vcolors->bg cols) port) 20 | (display ")" port))) 21 | 22 | 23 | ;; customize how vcellspan objects are printed 24 | (record-writer (record-type-descriptor %vcellspan) 25 | (lambda (csp port writer) 26 | (display "(string->vcellspan " port) 27 | (vcellspan-write csp port) 28 | (display ")" port))) 29 | 30 | 31 | ;; customize how vbuffer objects are printed 32 | (record-writer (record-type-descriptor %vbuffer) 33 | (lambda (cgb port writer) 34 | (display "(string->vbuffer " port) 35 | (vbuffer-write cgb port) 36 | (display ")" port))) 37 | 38 | 39 | ;; customize how vline objects are printed 40 | (record-writer (record-type-descriptor %vline) 41 | (lambda (line port writer) 42 | (display "(vline " port) 43 | (vline-write line port) 44 | (display ")" port))) 45 | 46 | 47 | ;; customize how vscreen objects are printed 48 | (record-writer (record-type-descriptor vscreen) 49 | (lambda (screen port writer) 50 | (display "(vscreen " port) 51 | (vscreen-write screen port) 52 | (display ")" port))) 53 | 54 | 55 | ;; customize how vlines objects are printed 56 | (record-writer (record-type-descriptor %vlines) 57 | (lambda (lines port writer) 58 | (display "(vlines" port) 59 | (vlines-iterate lines 60 | (lambda (i line) 61 | (display #\space port) 62 | (vline-write line port))) 63 | (display ")" port))) 64 | 65 | 66 | ;; customize how vhistory objects are printed 67 | (record-writer (record-type-descriptor %vhistory) 68 | (lambda (hist port writer) 69 | (display "(vhistory" port) 70 | (gbuffer-iterate hist 71 | (lambda (i elem) 72 | (display #\space port) 73 | (writer elem port))) 74 | (display ")" port))) 75 | -------------------------------------------------------------------------------- /shell/status.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | ;; this file should be included only by file shell/job.ss 11 | 12 | 13 | ;; Return #t if old-status and new-status have different kind. 14 | ;; otherwise return #f 15 | (define (status-changed? old-status new-status) 16 | (not (eq? (status->kind old-status) 17 | (status->kind new-status)))) 18 | 19 | 20 | ;; Return #t if status represents a child job status 21 | ;; that causes a parent multijob to end, i.e. one of: 22 | ;; (exception ...) 23 | ;; (killed 'sigint) 24 | ;; (killed 'sigquit) 25 | ;; 26 | (define (status-ends-multijob? status) 27 | (let ((kind (status->kind status))) 28 | (if (or (eq? kind 'exception) 29 | (and (eq? kind 'killed) 30 | (memq (status->value status) '(sigint sigquit)))) 31 | #t 32 | #f))) 33 | 34 | 35 | ;; Return #t if status represents a child job status 36 | ;; that causes a parent multijob to stop or end, i.e. one of: 37 | ;; (stopped ...) 38 | ;; (exception ...) 39 | ;; (killed 'sigint) 40 | ;; (killed 'sigquit) 41 | ;; 42 | (define (status-stops-or-ends-multijob? status) 43 | (or (stopped? status) 44 | (status-ends-multijob? status))) 45 | 46 | 47 | ;; Convert job's last-status to one of: 'new 'running 'stopped 'ok 'failed 'exception 'killed 48 | (define (job-last-status->kind job) 49 | (status->kind (job-last-status job))) 50 | 51 | 52 | 53 | ;; Return #t if job status is '(new ...), otherwise return #f 54 | (define (job-new? job) 55 | (new? (job-last-status job))) 56 | 57 | ;; Return #t if job was already started, otherwise return #f 58 | (define (job-started? job) 59 | (started? (job-last-status job))) 60 | 61 | ;; Return #t if job was started and is currently running (not stopped or finished), otherwise return #f 62 | (define (job-running? job) 63 | (running? (job-last-status job))) 64 | 65 | ;; Return #t if job was started and is currently stopped (not running or finished), otherwise return #f 66 | (define (job-stopped? job) 67 | (stopped? (job-last-status job))) 68 | 69 | ;; Return #t if job has already finished, otherwise return #f 70 | (define (job-finished? job) 71 | (finished? (job-last-status job))) 72 | -------------------------------------------------------------------------------- /doc/lineedit/lineedit.md: -------------------------------------------------------------------------------- 1 | # lineedit 2 | 3 | The effect of key presses at REPL is controlled the library `(scheme2k lineedit)` which is also included in `(schemesh)`. 4 | Users can change these effects, and define new ones, as described in [key.md](key.md). 5 | 6 | The main type defined by library `(scheme2k lineedit)` is `linectx`, 7 | and almost all functions in the library take a `linectx` object as first argument. 8 | 9 | Internals of `linectx` objects are mostly undocumented, the (few) documented functions are: 10 | 11 | ##### (linectx?) 12 | `(linectx? lctx)` returns `#t` if `lctx` is a `linectx` object, otherwise returns `#f`. 13 | 14 | ##### (linectx-height) 15 | `(linectx-height lctx)` returns the current terminal height, i.e. the number of rows. 16 | 17 | ##### (linectx-width) 18 | `(linectx-width lctx)` returns the current terminal width, i.e. the number of columns. 19 | 20 | ##### (linectx-clipboard) 21 | `(linectx-clipboard lctx)` returns the clipboard as a `vcellspan` object. 22 | 23 | ##### (linectx-clipboard-clear!) 24 | `(linectx-clipboard-clear! lctx)` clears the clipboard contents. 25 | 26 | ##### (linectx-history) 27 | `(linectx-history lctx)` returns the history as a `vhistory` object. 28 | 29 | ##### (linectx-insert/bytespan!) 30 | `(linectx-insert/bytespan! lctx bsp [start end])` inserts the contents of a `bytespan` object into current lines, starting at cursor.
31 | Added in 0.9.2 32 | 33 | ##### (linectx-insert/char!) 34 | `(linectx-insert/char! lctx ch)` inserts a single character into current lines, starting at cursor.
35 | Added in 0.9.2 36 | 37 | ##### (linectx-insert/charspan!) 38 | `(linectx-insert/charspan! lctx csp [start end])` inserts the contents of a `charspan` object into current lines, starting at cursor.
39 | Added in 0.9.2 40 | 41 | ##### (linectx-insert/string!) 42 | `(linectx-insert/string! lctx str [stard end])` inserts the contents of a `string` object into current lines, starting at cursor.
43 | Added in 0.9.2 44 | 45 | ##### (linectx-load-history!) 46 | `(linectx-load-history! lctx)` loads history from file. Returns `#t` if successful, otherwise returns `#f`. 47 | 48 | ##### (linectx-save-history) 49 | `(linectx-save-history lctx)` saves history to file. Returns `#t` if successful, otherwise returns `#f`. 50 | 51 | ##### (linectx-to-history) 52 | `(linectx-to-history lctx)` appends a copy of current lines to history, and returns an unspecified value. 53 | Also clears current lines, and removes empty lines from history.
54 | Added in 0.9.3 55 | 56 | ##### (linectx-vscreen lctx) 57 | `(linectx-vscreen lctx)` returns current lines as a `vscreen` object. 58 | -------------------------------------------------------------------------------- /parser/scheme.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | ;;; 11 | ;;; Lexer and parser for Chez Scheme syntax. 12 | ;;; 13 | (library (schemesh parser scheme (0 9 2)) 14 | (export 15 | lex-scheme parse-scheme-forms1 parse-scheme-forms parser-scheme) 16 | (import 17 | (rnrs) 18 | (only (scheme2k lineedit parser) make-parser) 19 | (schemesh parser lisp)) 20 | 21 | ;; Read a single Chez Scheme token from textual input port 'in. 22 | ;; 23 | ;; Return two values: token value and its type. 24 | (define (lex-scheme ctx) 25 | (lex-lisp ctx 'scheme)) 26 | 27 | 28 | ;; Read Chez Scheme tokens from textual input port 'in' 29 | ;; by repeatedly calling (lex-scheme) and construct a Chez Scheme form. 30 | ;; Automatically change parser when directive #!... is found. 31 | ;; 32 | ;; Return a list of parsed forms. 33 | ;; Raise syntax-errorf if end-of-file is reached before completely reading a form, 34 | ;; or if mismatched end token is found, as for example ']' instead of ')' 35 | (define (parse-scheme-forms1 ctx) 36 | (let-values (((ret _) (parse-lisp-forms ctx 'eof 'scheme))) 37 | ; (debugf "<> parse-scheme-forms1 ret=~s" ret) 38 | ret)) 39 | 40 | 41 | 42 | ;; Read Chez Scheme forms from textual input port 'in', until a token ) or ] or } matching 43 | ;; the specified begin-type token is found. 44 | ;; Automatically change parser when directive #!... is found. 45 | ;; 46 | ;; Return a list of parsed forms 47 | ;; Raise syntax-errorf if mismatched end token is found, as for example ']' instead of ')' 48 | (define (parse-scheme-forms ctx begin-type) 49 | (parse-lisp-forms ctx begin-type 'scheme)) 50 | 51 | 52 | ;; Read Chez Scheme forms from textual input port (parsectx-in ctx), 53 | ;; collecting grouping tokens i.e. ( ) [ ] { } |# #| " " | | 54 | ;; and filling paren with them. 55 | ;; 56 | ;; If a parser directive #!... is found, switch to the corresponding parser 57 | ;; until the end of current group. 58 | ;; 59 | ;; Stops on end-of-file, or when closing token matching start-ch is found. 60 | ;; Such closing token is consumed too. 61 | ;; 62 | ;; Return a paren containing the collected grouping tokens. 63 | (define (parse-scheme-paren ctx start-ch) 64 | (parse-lisp-paren ctx start-ch 'scheme)) 65 | 66 | 67 | (define parser-scheme 68 | (let ((ret (make-parser 'scheme parse-scheme-forms parse-scheme-paren))) 69 | (lambda () 70 | ret))) 71 | 72 | ) ; close library 73 | -------------------------------------------------------------------------------- /port/stdio.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | ;;; high-level procedures for reading from and writing to ports. 9 | ;;; 10 | ;;; procedure names and effect are intentionally compatible with 11 | ;;; https://docs.racket-lang.org/reference/port-lib.html 12 | ;;; 13 | (library (scheme2k port stdio (0 9 2)) 14 | (export 15 | sh-stdio-cleanup sh-stdin sh-stdout sh-stderr) 16 | (import 17 | (rnrs) 18 | (rnrs mutable-pairs) 19 | (only (chezscheme) logbit? procedure-arity-mask set-port-eof!) 20 | (only (scheme2k bootstrap) assert*)) 21 | 22 | 23 | (define (validate-stdio-proc caller old-proc new-proc) 24 | (assert* caller (not old-proc)) 25 | (assert* caller (procedure? new-proc)) 26 | (assert* caller (logbit? 0 (procedure-arity-mask new-proc)))) 27 | 28 | 29 | ;; Return binary input port that reads or writes bytes from current standard input 30 | (define sh-stdin 31 | (let ((proc #f)) 32 | (case-lambda 33 | (() 34 | ;; shell/init.ss will install a procedure returning binary standard input port of current job 35 | (and proc (proc))) 36 | ((new-proc) 37 | (validate-stdio-proc 'sh-stdin proc new-proc) 38 | (set! proc new-proc))))) 39 | 40 | 41 | ;; Return binary output port that reads or writes bytes to current standard output 42 | (define sh-stdout 43 | (let ((proc #f)) 44 | (case-lambda 45 | (() 46 | ;; shell/init.ss will install a procedure returning binary standard output port of current job 47 | (and proc (proc))) 48 | ((new-proc) 49 | (validate-stdio-proc 'sh-stdout proc new-proc) 50 | (set! proc new-proc))))) 51 | 52 | 53 | ;; Return binary output port that reads or writes bytes to current standard error 54 | (define sh-stderr 55 | (let ((proc #f)) 56 | (case-lambda 57 | (() 58 | ;; shell/init.ss will install a procedure returning binary standard error port of current job 59 | (and proc (proc))) 60 | ((new-proc) 61 | (validate-stdio-proc 'sh-stderr proc new-proc) 62 | (set! proc new-proc))))) 63 | 64 | 65 | (define (try-port-cleanup port) 66 | (when (input-port? port) 67 | (set-port-eof! port #f))) 68 | 69 | (define (sh-stdio-cleanup) 70 | (try-port-cleanup (current-input-port)) 71 | (try-port-cleanup (current-output-port)) 72 | (try-port-cleanup (current-error-port))) 73 | 74 | 75 | ) ; close library 76 | -------------------------------------------------------------------------------- /shell/parameters.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | ;; if this file is loaded multiple times, only the first one has any effect. 11 | ;; implementation note: 12 | ;; this is done by setting the top-level symbol sh-persistent-parameters 13 | ;; only if it's not bound yet, and by retrieving its value if it's bound. 14 | 15 | (library (schemesh shell parameters (0 9 2)) 16 | (export 17 | ;; parameter1.ss 18 | sh-persistent-parameters 19 | 20 | ;; parameters.ss 21 | sh-current-environment sh-current-eval sh-globals sh-pid-table 22 | sh-schemesh-reload-count repl-restart repl-restart? 23 | sh-eval sh-eval-string sh-eval->bytevector) 24 | (import 25 | (rnrs) 26 | (only (scheme2k bootstrap) sh-make-parameter sh-make-thread-parameter raise-errorf) 27 | (only (scheme2k conversions) any->bytevector) 28 | (only (schemesh shell parameter1) sh-persistent-parameters)) 29 | 30 | 31 | ;; retrieve parameter sh-current-environment set by parameters/parameter1.ss 32 | (define sh-current-environment (vector-ref (sh-persistent-parameters) 0)) 33 | 34 | ;; retrieve parameter sh-current-eval set by parameters/parameter1.ss 35 | (define sh-current-eval (vector-ref (sh-persistent-parameters) 1)) 36 | 37 | ;; retrieve parameter sh-globals set by parameters/parameter1.ss 38 | (define sh-globals (vector-ref (sh-persistent-parameters) 2)) 39 | 40 | ;; retrieve parameter sh-pid-table set by parameters/parameter1.ss 41 | (define sh-pid-table (vector-ref (sh-persistent-parameters) 3)) 42 | 43 | ;; retrieve integer sh-schemesh-reload-count set by parameters/parameter1.ss 44 | (define (sh-schemesh-reload-count) (vector-ref (sh-persistent-parameters) 4)) 45 | 46 | ;; retrieve boolean flag repl-restart? set by parameters/parameter1.ss 47 | (define (repl-restart?) (vector-ref (sh-persistent-parameters) 5)) 48 | 49 | ;; set to #t or #f the boolean flag repl-restart? 50 | (define repl-restart 51 | (case-lambda 52 | (() (repl-restart #t)) 53 | ((flag) (vector-set! (sh-persistent-parameters) 5 (not (not flag)))))) 54 | 55 | 56 | ;; evaluate a form with (sh-current-eval) in specified environment, 57 | ;; which is (sh-current-environment) by default 58 | (define sh-eval 59 | (case-lambda 60 | ((form) ((sh-current-eval) form (sh-current-environment))) 61 | ((form env) ((sh-current-eval) form env)))) 62 | 63 | 64 | ;; parse and evaluate a string with (sh-eval). 65 | (define (sh-eval-string str) 66 | (sh-eval (read (open-string-input-port str)))) 67 | 68 | 69 | ;; parse and evaluate a string with (sh-eval), 70 | ;; then convert result to bytevector. 71 | (define (sh-eval->bytevector str) 72 | (any->bytevector (sh-eval-string str))) 73 | 74 | ) ; close library 75 | -------------------------------------------------------------------------------- /bootstrap/arrow.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | (library (scheme2k bootstrap arrow (0 9 2)) 11 | (export expand==>) 12 | (import 13 | (rnrs) 14 | (rnrs mutable-pairs) 15 | (only (chezscheme) append! fx1+ gensym list-copy list-head)) 16 | 17 | 18 | ;; scan template for '_ and replace '_ with item. 19 | ;; if template contains no '_ then append item to template. 20 | ;; 21 | ;; return template, modified in-place 22 | (define (replace_! item template) 23 | (let ((place (memq '_ template))) 24 | (if place 25 | (begin 26 | (set-car! place item) 27 | template) 28 | (append! template (list item))))) 29 | 30 | 31 | ;; helper function used by expand==> 32 | ;; 33 | ;; traverse list, find first element eq? to '==> or '?=> and return two values: 34 | ;; its position in the list and the symbol found, 35 | ;; or #f #f if no such element was found 36 | (define (scan=> l) 37 | (let %scan=> ((l l) (pos 0)) 38 | (cond 39 | ((null? l) 40 | (values #f #f)) 41 | ((memq (car l) '(=> ?=>)) 42 | (values pos (car l))) 43 | (else 44 | (%scan=> (cdr l) (fx1+ pos)))))) 45 | 46 | 47 | ;; expand (==> head rest) 48 | (define (compose=> head rest) 49 | (let-values (((pos sym) (scan=> rest))) 50 | (if pos 51 | (let* ((mid (list-head rest pos)) 52 | (mid* (replace_! head mid)) 53 | (tail (list-tail rest (fx1+ pos)))) 54 | (if (eq? sym '=>) 55 | (compose=> mid* tail) 56 | (compose?=> mid* tail))) 57 | (replace_! head (list-copy rest))))) 58 | 59 | 60 | ;; expand (?=> head rest) 61 | (define (compose?=> head rest) 62 | (let-values (((pos sym) (scan=> rest))) 63 | (if pos 64 | (let* ((g (gensym)) 65 | (mid (list-head rest pos)) 66 | (mid* (replace_! g mid)) 67 | (tail (list-tail rest (fx1+ pos)))) 68 | `(let ((,g ,head)) 69 | (and ,g ,(if (eq? sym '=>) 70 | (compose=> mid* tail) 71 | (compose?=> mid* tail))))) 72 | (let* ((g (gensym)) 73 | (rest* (replace_! g (list-copy rest)))) 74 | `(let ((,g ,head)) 75 | (and ,g ,rest*)))))) 76 | 77 | 78 | ;; implementation of macro ==> 79 | (define (expand==> l) 80 | (when (null? l) 81 | (syntax-violation "" "invalid syntax, need at least one argument after" '==>)) 82 | (let-values (((pos sym) (scan=> l))) 83 | (case sym 84 | ((=>) 85 | (compose=> (list-head l pos) (list-tail l (fx1+ pos)))) 86 | ((?=>) 87 | (compose?=> (list-head l pos) (list-tail l (fx1+ pos)))) 88 | (else 89 | l)))) 90 | 91 | 92 | 93 | 94 | ) ; close library 95 | -------------------------------------------------------------------------------- /examples/example_multitasking.ss: -------------------------------------------------------------------------------- 1 | 2 | 3 | (library (scheme2k example multitasking (0 9 2)) 4 | (export 5 | tasks make-task task-yield task-resume) 6 | 7 | (import 8 | (rnrs) 9 | (only (chezscheme) logbit? procedure-arity-mask void) 10 | (only (scheme2k bootstrap) assert*) 11 | (scheme2k containers span)) 12 | 13 | 14 | (define tasks 15 | (let ((sp (span))) 16 | (lambda () sp))) 17 | 18 | 19 | (define-record-type (task %make-task task?) 20 | (fields 21 | id 22 | (mutable status) ; one of: 'new 'running 'failed 23 | (mutable result) 24 | start-proc 25 | (mutable resume-proc) 26 | (mutable yield-proc)) 27 | (nongenerative task-7c46d04b-34f4-4046-b5c7-b63753c1be39)) 28 | 29 | 30 | (define (task-find task-or-id) 31 | (let ((all (tasks)) 32 | (x task-or-id)) 33 | (cond 34 | ((task? x) 35 | x) 36 | ((and (fixnum? x) (fxchez:tree 25 | void) 26 | (import (ffi unsafe vm) 27 | (rnrs) 28 | (only (srfi :1) append! list-copy reverse!) 29 | (only (srfi :19) current-time time-second time-nanosecond) 30 | ) 31 | 32 | ;; create and access Chez Scheme cons objects, not Racket mpair objects 33 | (define chez:car (vm-primitive 'car)) 34 | (define chez:cdr (vm-primitive 'cdr)) 35 | (define chez:cons (vm-primitive 'cons)) 36 | (define chez:list (vm-primitive 'list)) 37 | (define chez:pair? (vm-primitive 'pair?)) 38 | 39 | ;; convert a tree of Racket mpair objects to a tree of Chez Scheme cons objects 40 | (define (tree->chez:tree obj) 41 | (cond 42 | ((pair? obj) 43 | (chez:cons (tree->chez:tree (car obj)) 44 | (tree->chez:tree (cdr obj)))) 45 | ((chez:pair? obj) 46 | (chez:cons (tree->chez:tree (chez:car obj)) 47 | (tree->chez:tree (chez:cdr obj)))) 48 | (else 49 | obj))) 50 | 51 | (define check-interrupts (vm-eval (chez:list '$primitive 3 '$event))) 52 | (define format (vm-primitive 'format)) 53 | (define fx1+ (vm-primitive 'fx1+)) 54 | (define fx1- (vm-primitive 'fx1-)) 55 | (define fx/ (vm-primitive 'fx/)) 56 | (define load-shared-object (vm-primitive 'load-shared-object)) 57 | (define lock-object (vm-primitive 'lock-object)) 58 | ;(define pariah (vm-primitive 'pariah)) 59 | (define read-token (vm-primitive 'read-token)) 60 | (define register-signal-handler (vm-primitive 'register-signal-handler)) 61 | (define top-level-syntax (vm-primitive 'top-level-syntax)) 62 | (define unlock-object (vm-primitive 'unlock-object)) 63 | (define unread-char (vm-primitive 'unread-char)) 64 | (define void (vm-primitive 'void)) 65 | 66 | (define-syntax foreign-procedure 67 | (lambda (stx) 68 | (syntax-case stx () 69 | ;; warning: (syntax->datum #'args) returns Racket mpair objects, 70 | ;; not Chez Scheme cons objects needed by (vm-eval) 71 | ;; => convert them 72 | ((_ . args) #'(vm-eval (chez:cons 'foreign-procedure (tree->chez:tree (syntax->datum #'args)))))))) 73 | 74 | 75 | ) ; close library 76 | -------------------------------------------------------------------------------- /libschemesh.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | (begin 11 | (include "bootstrap/arrow.ss") 12 | (include "bootstrap/functions.ss") 13 | (include "bootstrap/bootstrap.ss") 14 | 15 | (include "containers/bitmap.ss") 16 | (include "containers/bytevector.ss") 17 | (include "containers/flvector.ss") 18 | (include "containers/fxvector.ss") 19 | (include "containers/in.ss") 20 | (include "containers/list.ss") 21 | (include "containers/string.ss") 22 | (include "containers/vector.ss") 23 | (include "containers/hashtable.ss") ; requires containers/list.ss 24 | (include "containers/bytespan.ss") ; requires containers/bytevector.ss containers/list.ss 25 | (include "containers/charspan.ss") ; requires containers/string.ss 26 | (include "containers/span.ss") ; requires containers/vector.ss 27 | (include "containers/sort.ss") ; requires containers/span.ss 28 | (include "containers/gbuffer.ss") ; requires containers/span.ss 29 | (include "containers/utf8b.ss") ; requires containers/bytespan.ss 30 | (include "containers/macros.ss") 31 | (include "containers/containers.ss") 32 | (include "containers/replacements.ss") 33 | 34 | (include "conversions/unicode.ss") 35 | (include "conversions/conversions.ss") 36 | 37 | (include "wire/wire.ss") 38 | 39 | (include "posix/fd.ss") 40 | (include "posix/dir.ss") 41 | (include "posix/io.ss") 42 | (include "posix/pattern.ss") 43 | (include "posix/signal.ss") 44 | (include "posix/socket.ss") ; requires posix/fd.ss 45 | (include "posix/status.ss") ; requires wire/wire.ss 46 | (include "posix/thread.ss") ; requires posix/signal.ss posix/status.ss 47 | (include "posix/tty.ss") 48 | (include "posix/rlimit.ss") 49 | (include "posix/replacements.ss") ; requires posix/thread.ss 50 | (include "posix/pid.ss") 51 | (include "posix/posix.ss") 52 | 53 | (include "port/http.ss") 54 | (include "port/redir.ss") 55 | (include "port/stdio.ss") 56 | (include "port/port.ss") 57 | 58 | (include "vscreen/all.ss") 59 | 60 | 61 | (include "ipc/channel.ss") ; requires wire/wire.ss posix/fd.ss 62 | (meta-cond 63 | ((threaded?) (include "ipc/fifo-thread.ss")) 64 | (else (include "ipc/fifo-nothread.ss"))) 65 | (include "ipc/ipc.ss") 66 | 67 | (include "lineedit/ansi.ss") 68 | (include "lineedit/paren.ss") 69 | (include "lineedit/parenmatcher.ss") 70 | (include "lineedit/parser.ss") 71 | (include "lineedit/lineedit.ss") 72 | (include "lineedit/all.ss") 73 | 74 | (include "parser/lisp.ss") 75 | (include "parser/r6rs.ss") 76 | (include "parser/scheme.ss") 77 | (include "parser/shell.ss") 78 | (include "parser/parser.ss") 79 | 80 | (include "shell/parameter1.ss") 81 | (include "shell/parameters.ss") 82 | (include "shell/fds.ss") 83 | (include "shell/paths.ss") 84 | (include "shell/job.ss") 85 | (include "shell/replacements.ss") 86 | (include "shell/eval.ss") 87 | (include "shell/macros.ss") 88 | (include "shell/autocomplete.ss") 89 | (include "shell/utils.ss") 90 | (include "shell/shell.ss") 91 | 92 | (include "repl/repl.ss") 93 | 94 | (include "utils/import.ss") 95 | 96 | ) ; close begin 97 | -------------------------------------------------------------------------------- /lineedit/ansi.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | (library (scheme2k lineedit ansi (0 9 2)) 11 | (export 12 | ansi-text ansi-text? ansi-text-bytes ansi-text-clear! ansi-text-visible-length make-ansi-text 13 | string+ color 14 | black red green yellow blue magenta cyan white 15 | black+ red+ green+ yellow+ blue+ magenta+ cyan+ white+) 16 | (import 17 | (rnrs) 18 | (only (chezscheme) record-writer) 19 | (only (scheme2k bootstrap) assert*) 20 | (only (scheme2k containers bytespan) make-bytespan bytespan? bytespan-clear!) 21 | (only (scheme2k containers utf8b) utf8b-bytespan->string bytespan-insert-right/string!)) 22 | 23 | 24 | (define-record-type (ansi-text %make-ansi-text ansi-text?) 25 | (fields 26 | (mutable bytes) ; bytespan 27 | (mutable visible-length)) ; unsigned fixnum 28 | (nongenerative %ansi-text-7c46d04b-34f4-4046-b5c7-b63753c1be39)) 29 | 30 | 31 | (define make-ansi-text 32 | (case-lambda 33 | (() 34 | (%make-ansi-text (make-bytespan 0) 0)) 35 | ((bytes visible-length) 36 | (assert* 'make-ansi-text (bytespan? bytes)) 37 | (assert* 'make-ansi-text (fixnum? visible-length)) 38 | (assert* 'make-ansi-text (fx>=? visible-length 0)) 39 | (%make-ansi-text bytes visible-length)))) 40 | 41 | 42 | (define (ansi-text-clear! a) 43 | (bytespan-clear! (ansi-text-bytes a)) 44 | (ansi-text-visible-length-set! a 0)) 45 | 46 | (define string+ 47 | (case-lambda 48 | ((a str visible-length) 49 | (bytespan-insert-right/string! (ansi-text-bytes a) str) 50 | (ansi-text-visible-length-set! a (fx+ visible-length (ansi-text-visible-length a))) 51 | a) 52 | ((a str) 53 | (string+ a str (string-length str))))) 54 | 55 | 56 | (define (color a col-seq str) 57 | (string+ a "\x1b;[" 0) 58 | (string+ a col-seq 0) 59 | (string+ a "m" 0) 60 | (string+ a str (string-length str)) 61 | (string+ a "\x1b;[m" 0) 62 | a) 63 | 64 | 65 | (define (black a str) (color a "30" str)) 66 | (define (red a str) (color a "31" str)) 67 | (define (green a str) (color a "32" str)) 68 | (define (yellow a str) (color a "33" str)) 69 | (define (blue a str) (color a "34" str)) 70 | (define (magenta a str) (color a "35" str)) 71 | (define (cyan a str) (color a "36" str)) 72 | (define (white a str) (color a "37" str)) 73 | 74 | (define (black+ a str) (color a "1;30" str)) 75 | (define (red+ a str) (color a "1;31" str)) 76 | (define (green+ a str) (color a "1;32" str)) 77 | (define (yellow+ a str) (color a "1;33" str)) 78 | (define (blue+ a str) (color a "1;34" str)) 79 | (define (magenta+ a str) (color a "1;35" str)) 80 | (define (cyan+ a str) (color a "1;36" str)) 81 | (define (white+ a str) (color a "1;37" str)) 82 | 83 | 84 | ;; customize how "ansi-text" objects are printed 85 | (record-writer (record-type-descriptor ansi-text) 86 | (lambda (a port writer) 87 | (display "(make-ansi-text (bytevector->bytespan* (string->utf8b " port) 88 | (write (utf8b-bytespan->string (ansi-text-bytes a)) port) 89 | (display ")) " port) 90 | (display (ansi-text-visible-length a) port) 91 | (display ")" port))) 92 | 93 | ) ; close library 94 | -------------------------------------------------------------------------------- /conversions/gen-unicode-wide-set.ss: -------------------------------------------------------------------------------- 1 | (wide-set! #x1100 #x115F) 2 | (wide-set! #x231A #x231B) 3 | (wide-set! #x2329 #x232A) 4 | (wide-set! #x23E9 #x23EC) 5 | (wide-set! #x23F0 #x23F0) 6 | (wide-set! #x23F3 #x23F3) 7 | (wide-set! #x25FD #x25FE) 8 | (wide-set! #x2614 #x2615) 9 | (wide-set! #x2630 #x2637) 10 | (wide-set! #x2648 #x2653) 11 | (wide-set! #x267F #x267F) 12 | (wide-set! #x268A #x268F) 13 | (wide-set! #x2693 #x2693) 14 | (wide-set! #x26A1 #x26A1) 15 | (wide-set! #x26AA #x26AB) 16 | (wide-set! #x26BD #x26BE) 17 | (wide-set! #x26C4 #x26C5) 18 | (wide-set! #x26CE #x26CE) 19 | (wide-set! #x26D4 #x26D4) 20 | (wide-set! #x26EA #x26EA) 21 | (wide-set! #x26F2 #x26F3) 22 | (wide-set! #x26F5 #x26F5) 23 | (wide-set! #x26FA #x26FA) 24 | (wide-set! #x26FD #x26FD) 25 | (wide-set! #x2705 #x2705) 26 | (wide-set! #x270A #x270B) 27 | (wide-set! #x2728 #x2728) 28 | (wide-set! #x274C #x274C) 29 | (wide-set! #x274E #x274E) 30 | (wide-set! #x2753 #x2755) 31 | (wide-set! #x2757 #x2757) 32 | (wide-set! #x2795 #x2797) 33 | (wide-set! #x27B0 #x27B0) 34 | (wide-set! #x27BF #x27BF) 35 | (wide-set! #x2B1B #x2B1C) 36 | (wide-set! #x2B50 #x2B50) 37 | (wide-set! #x2B55 #x2B55) 38 | (wide-set! #x2E80 #x2E99) 39 | (wide-set! #x2E9B #x2EF3) 40 | (wide-set! #x2FF0 #x303E) 41 | (wide-set! #x3041 #x3096) 42 | (wide-set! #x3099 #x30FF) 43 | (wide-set! #x3105 #x312F) 44 | (wide-set! #x3131 #x318E) 45 | (wide-set! #x3190 #x31E5) 46 | (wide-set! #x31EF #x321E) 47 | (wide-set! #x3220 #x3247) 48 | (wide-set! #xA490 #xA4C6) 49 | (wide-set! #xA960 #xA97C) 50 | (wide-set! #xFE10 #xFE19) 51 | (wide-set! #xFE30 #xFE52) 52 | (wide-set! #xFE54 #xFE66) 53 | (wide-set! #xFE68 #xFE6B) 54 | (wide-set! #xFF01 #xFF60) 55 | (wide-set! #xFFE0 #xFFE6) 56 | (wide-set! #x16FE0 #x16FE4) 57 | (wide-set! #x16FF0 #x16FF1) 58 | (wide-set! #x18CFF #x18D08) 59 | (wide-set! #x1AFF0 #x1AFF3) 60 | (wide-set! #x1AFF5 #x1AFFB) 61 | (wide-set! #x1AFFD #x1AFFE) 62 | (wide-set! #x1B132 #x1B132) 63 | (wide-set! #x1B150 #x1B152) 64 | (wide-set! #x1B155 #x1B155) 65 | (wide-set! #x1B164 #x1B167) 66 | (wide-set! #x1D300 #x1D356) 67 | (wide-set! #x1D360 #x1D376) 68 | (wide-set! #x1F004 #x1F004) 69 | (wide-set! #x1F0CF #x1F0CF) 70 | (wide-set! #x1F18E #x1F18E) 71 | (wide-set! #x1F191 #x1F19A) 72 | (wide-set! #x1F200 #x1F202) 73 | (wide-set! #x1F210 #x1F23B) 74 | (wide-set! #x1F240 #x1F248) 75 | (wide-set! #x1F250 #x1F251) 76 | (wide-set! #x1F260 #x1F265) 77 | (wide-set! #x1F300 #x1F320) 78 | (wide-set! #x1F32D #x1F335) 79 | (wide-set! #x1F337 #x1F37C) 80 | (wide-set! #x1F37E #x1F393) 81 | (wide-set! #x1F3A0 #x1F3CA) 82 | (wide-set! #x1F3CF #x1F3D3) 83 | (wide-set! #x1F3E0 #x1F3F0) 84 | (wide-set! #x1F3F4 #x1F3F4) 85 | (wide-set! #x1F3F8 #x1F43E) 86 | (wide-set! #x1F440 #x1F440) 87 | (wide-set! #x1F4FF #x1F53D) 88 | (wide-set! #x1F54B #x1F54E) 89 | (wide-set! #x1F550 #x1F567) 90 | (wide-set! #x1F57A #x1F57A) 91 | (wide-set! #x1F595 #x1F596) 92 | (wide-set! #x1F5A4 #x1F5A4) 93 | (wide-set! #x1F5FB #x1F64F) 94 | (wide-set! #x1F680 #x1F6C5) 95 | (wide-set! #x1F6CC #x1F6CC) 96 | (wide-set! #x1F6D0 #x1F6D2) 97 | (wide-set! #x1F6D5 #x1F6D7) 98 | (wide-set! #x1F6DC #x1F6DF) 99 | (wide-set! #x1F6EB #x1F6EC) 100 | (wide-set! #x1F6F4 #x1F6FC) 101 | (wide-set! #x1F7E0 #x1F7EB) 102 | (wide-set! #x1F7F0 #x1F7F0) 103 | (wide-set! #x1F90C #x1F93A) 104 | (wide-set! #x1F93C #x1F945) 105 | (wide-set! #x1FA70 #x1FA7C) 106 | (wide-set! #x1FA80 #x1FA89) 107 | (wide-set! #x1FA8F #x1FAC6) 108 | (wide-set! #x1FACE #x1FADC) 109 | (wide-set! #x1FADF #x1FAE9) 110 | (wide-set! #x1FAF0 #x1FAF8) 111 | -------------------------------------------------------------------------------- /shell/fds.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | ;; Define the functions (s-fd-allocate) (s-fd-release) to manage reserved fds 11 | ;; Define the record-type (s-fd) containing a reference-counted file descriptor 12 | 13 | 14 | (library (schemesh shell fds (0 9 2)) 15 | (export 16 | s-fd s-fd* s-fd? s-fd->int s-fd-copy s-fd-allocate s-fd-release) 17 | (import 18 | (rnrs) 19 | (only (chezscheme) fx1+ fx1- record-writer) 20 | (only (scheme2k bootstrap) assert* raise-errorf) 21 | (scheme2k containers bitmap) 22 | (only (scheme2k posix fd) fd-open-max)) 23 | 24 | 25 | ;; 1+ highest reserved fd 26 | (define fd-max (fd-open-max)) 27 | 28 | ;; lowest reserved fd 29 | (define fd-min (fx* 3 (fxarithmetic-shift-right fd-max 2))) 30 | 31 | ;; bitmap of reserved fds 32 | (define fd-bitmap (make-bitmap (fx- fd-max fd-min))) 33 | 34 | 35 | ;; reference-counted file descriptor 36 | (define-record-type (%s-fd %make-s-fd s-fd?) 37 | (fields 38 | (immutable int s-fd->int) ; unsigned fixnum: file descriptor 39 | (mutable refcount)) ; fixnum: reference count 40 | (nongenerative %s-fd-7c46d04b-34f4-4046-b5c7-b63753c1be39)) 41 | 42 | 43 | ;; wrap a file descriptor (an unsigned fixnum) and an optional reference count into s-fd 44 | (define s-fd 45 | (case-lambda 46 | ((int) (s-fd* int 1)) 47 | ((int refcount) (s-fd* int refcount)))) 48 | 49 | 50 | ;; wrap a file descriptor (an unsigned fixnum) and a mandatory reference count into s-fd 51 | (define (s-fd* int refcount) 52 | (assert* 's-fd (fx=? refcount 0)) 54 | (%make-s-fd int refcount)) 55 | 56 | 57 | ;; increase by one the reference count of an s-fd 58 | ;; return the s-fd argument 59 | (define (s-fd-copy fd) 60 | (assert* 's-fd-copy (s-fd? fd)) 61 | (%s-fd-refcount-set! fd (fx1+ (%s-fd-refcount fd))) 62 | fd) 63 | 64 | 65 | ;; reserve a fd, return its number wrapped inside a s-fd 66 | (define (s-fd-allocate) 67 | (let ((index (bitmap-last-zero fd-bitmap))) 68 | (when (fxint fd) fd-min))) 84 | (assert* 's-fd-release (fx=? 1 (bitmap-ref fd-bitmap index))) 85 | (bitmap-set! fd-bitmap index 0))) 86 | unreserve?)) 87 | 88 | 89 | ;; customize how "s-fd" objects are printed 90 | (record-writer (record-type-descriptor %s-fd) 91 | (lambda (fd port writer) 92 | (display "(s-fd " port) 93 | (display (s-fd->int fd) port) 94 | (let ((refcount (%s-fd-refcount fd))) 95 | (unless (fx=? 1 refcount) 96 | (display #\space port) 97 | (display refcount port))) 98 | (display ")" port))) 99 | 100 | ) ; close library 101 | -------------------------------------------------------------------------------- /posix/thread-nothread.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | 11 | ;; approximate reimplementation of Chez Scheme make-thread-parameter: 12 | ;; calls (make-parameter) 13 | (define make-thread-parameter make-parameter) 14 | 15 | 16 | ;; acquire $tc-mutex, but don't disable interrupts 17 | (define-syntax with-tc-mutex* 18 | (identifier-syntax begin)) 19 | 20 | 21 | ;; disable interrupts and acquire $tc-mutex 22 | (define-syntax with-tc-mutex 23 | (identifier-syntax with-interrupts-disabled)) 24 | 25 | 26 | (define (thread-count) 1) 27 | 28 | 29 | ;; return alist ((id status . name) ...) of threads that changed status 30 | (define (threads-status-changes) 31 | '()) 32 | 33 | 34 | (define (thread-find thread-id) 35 | (and thread-id 36 | (thread-id-validate thread-id) 37 | (eqv? 0 thread-id) 38 | (current-thread))) 39 | 40 | 41 | ;; return caller's thread 42 | (define (current-thread) 43 | (with-tc-mutex 44 | (car ($threads)))) 45 | 46 | 47 | (define (%thread-timed-join thread timeout) 48 | (assert* 'thread-join (thread? thread)) 49 | (assert* 'thread-join (time? timeout)) 50 | (sleep (cond 51 | ((eq? 'time-duration (time-type timeout)) 52 | timeout) 53 | (else 54 | (assert* 'thread-join (eq? 'time-utc (time-type timeout))) 55 | (time-difference timeout (current-time 'time-utc))))) 56 | #f) 57 | 58 | 59 | (define long-duration (make-time 'time-duration 0 86400)) 60 | 61 | 62 | (define (%thread-join thread) 63 | (assert* 'thread-join (thread? thread)) 64 | (do () (#f) 65 | (sleep long-duration))) 66 | 67 | 68 | (define (%thread-create caller thunk name initial-signal-name) 69 | (raise-errorf caller "compiled without thread support")) 70 | 71 | 72 | (define (thread-name thread) 73 | (assert* 'thread-status (thread? thread)) 74 | (void)) 75 | 76 | 77 | (define thread-specific-value (void)) 78 | 79 | 80 | (define (thread-specific thread) 81 | (assert* 'thread-specific (thread? thread)) 82 | thread-specific-value) 83 | 84 | 85 | (define (thread-specific-set! thread value) 86 | (assert* 'thread-specific-set! (thread? thread)) 87 | (set! thread-specific-value value)) 88 | 89 | 90 | (define thread-kill 91 | (let ((c-signal-raise (foreign-procedure "c_thread_signal_raise" (int int) int))) 92 | (lambda (thread-or-id signal-name) 93 | (datum->thread thread-or-id) ; validate thread-or-id 94 | (let ((signal-number (signal-name->number signal-name))) 95 | (if (fixnum? signal-number) 96 | (let ((ret (c-signal-raise signal-number 0))) ; 0 = preserve signal handler 97 | (if (eqv? 0 ret) (void) ret)) 98 | c-errno-einval))))) 99 | 100 | 101 | (define (thread-status thread) 102 | (assert* 'thread-status (thread? thread)) 103 | (running)) 104 | 105 | 106 | ;; return a fresh hashtable containing the known threads, their id and status 107 | ;; organized as id -> #(thread status name) 108 | ;; 109 | ;; Note: threads may be created or destroyed after this call and before 110 | ;; the returned value is used. 111 | (define (threads-status) 112 | (let ((ret (make-eqv-hashtable))) 113 | (hashtable-set! ret 0 (vector (get-initial-thread) (running) (void))) 114 | ret)) 115 | 116 | 117 | (define (thread-signal-handle) 118 | (void)) 119 | -------------------------------------------------------------------------------- /posix/pid.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | (library (scheme2k posix pid (0 9 2)) 11 | (export pid-get pgid-get pid-kill pid-wait) 12 | (import 13 | (rnrs) 14 | (only (chezscheme) foreign-procedure) 15 | (only (scheme2k bootstrap) assert*) 16 | (only (scheme2k posix fd) raise-c-errno) 17 | (only (scheme2k posix signal) signal-name->number)) 18 | 19 | 20 | ;; return pid of current process 21 | (define pid-get 22 | (let ((c-pid-get (foreign-procedure "c_pid_get" () int))) 23 | (lambda () 24 | (let ((ret (c-pid-get))) 25 | (when (< ret 0) 26 | (raise-c-errno 'pid-get 'getpid ret)) 27 | ret)))) 28 | 29 | ;; return process group of specified process (0 = current process) 30 | (define pgid-get 31 | (let ((c-pgid-get (foreign-procedure "c_pgid_get" (int) int))) 32 | (lambda (pid) 33 | (let ((ret (c-pgid-get pid))) 34 | (when (< ret 0) 35 | (raise-c-errno 'pgid-get 'getpgid ret pid)) 36 | ret)))) 37 | 38 | 39 | ;; call C function kill(pid, sig) i.e. send specified signal to the process(es) identified by pid. 40 | ;; Notes: 41 | ;; pid == 0 means "all processes in the same process group as the caller". 42 | ;; pid == -1 means "all processes". 43 | ;; pid < -1 means "all processes in process group -pid" 44 | ; 45 | ;; Returns 0 on success. 46 | ;; Otherwise < 0 if signal-name is unknown, or if C function kill() fails with C errno != 0. 47 | (define pid-kill 48 | (let ((c-pid-kill (foreign-procedure "c_pid_kill" (int int int) int)) 49 | (c-errno-einval ((foreign-procedure "c_errno_einval" () int)))) 50 | (case-lambda 51 | ((pid signal-name-or-number pause-if-successful?) 52 | ;; (format #t "pid-kill ~s ~s" pid signal-name) 53 | (let ((signal-number (if (fixnum? signal-name-or-number) 54 | signal-name-or-number 55 | (signal-name->number signal-name-or-number)))) 56 | (if (fixnum? signal-number) 57 | (c-pid-kill pid signal-number (if pause-if-successful? 1 0)) 58 | c-errno-einval))) 59 | ((pid signal-name-or-number) 60 | (pid-kill pid signal-name-or-number #f))))) 61 | 62 | 63 | ;; (pid-wait pid may-block) calls waitpid(pid, WUNTRACED) i.e. checks if process specified by pid finished or stopped. 64 | ;; 65 | ;; Special cases: 66 | ;; pid == 0 means "any child process in the same process group as the caller" 67 | ;; pid == -1 means "any child process" 68 | ;; pid < -1 means "any child process in process group -pid" 69 | ; 70 | ;; Argument may-block must be either 'blocking or 'nonblocking. 71 | ;; If may-block is 'blocking, wait until pid (or any child process, if pid == -1) 72 | ;; exits or stops, otherwise check for such conditions without blocking. 73 | ; 74 | ;; If waitpid() fails with C errno != 0, return < 0. 75 | ;; If no child process matches pid, or if may_block is 'nonblocking and no child finished or 76 | ;; stopped, return '(). 77 | ;; Otherwise return a Scheme cons (pid . exit_flag), where exit_flag is one of: 78 | ;; process_exit_status, or 256 + signal, or 512 + stop_signal, or 768 if job continued. 79 | (define pid-wait 80 | (let ((c-pid-wait (foreign-procedure __collect_safe "c_pid_wait" (int int) ptr))) 81 | (lambda (pid may-block) 82 | (assert* 'pid-wait (memq may-block '(blocking nonblocking))) 83 | (c-pid-wait pid (if (eq? may-block 'blocking) 1 0))))) 84 | 85 | 86 | ) ; close library 87 | -------------------------------------------------------------------------------- /containers/bitmap.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | ;;;;;;;;; define Scheme type "bitmap", a fixed size bit vector ;;;;;;;;;;;;; 12 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 13 | 14 | (library (scheme2k containers bitmap (0 9 2)) 15 | (export 16 | bitmap make-bitmap bitmap? bitmap-length bitmap-ref bitmap-set! bitmap-last-zero) 17 | (import 18 | (rnrs) 19 | (only (chezscheme) fx1+ fx1- record-writer void) 20 | (only (scheme2k bootstrap) assert*)) 21 | 22 | (define-record-type (%bitmap %make-bitmap bitmap?) 23 | (fields 24 | (immutable data bitmap-data) ; bytevector 25 | ; unsigned fixnum, length in bits 26 | (mutable length bitmap-length bitmap-length-set!) 27 | ; unsigned fixnum, position of last zero, or -1 if all bits are one. 28 | (mutable last-zero bitmap-last-zero bitmap-last-zero-set!)) 29 | (nongenerative %bitmap-7c46d04b-34f4-4046-b5c7-b63753c1be39)) 30 | 31 | 32 | ;; create a zero-filled bitmap with specified bit length. 33 | (define (make-bitmap bitlength) 34 | (let ((byte-n (fxarithmetic-shift-right (fx+ bitlength 7) 3))) 35 | (%make-bitmap 36 | (make-bytevector byte-n 0) 37 | bitlength 38 | (fx1- bitlength)))) 39 | 40 | 41 | ;; create a bitmap containing specified values. each value must be 0 or 1 42 | (define (bitmap . vals) 43 | (let* ((n (length vals)) 44 | (b (make-bitmap n))) 45 | (do ((i 0 (fx1+ i)) 46 | (tail vals (cdr tail))) 47 | ((fx>=? i n) b) 48 | (bitmap-set! b i (car tail))))) 49 | 50 | 51 | ;; get index-th element of bitmap. returns 0 or 1. 52 | (define (bitmap-ref b index) 53 | (assert* 'bitmap-ref (fx? index (bitmap-last-zero b)) 78 | (bitmap-last-zero-set! b index)) 79 | (when (fx=? index (bitmap-last-zero b)) 80 | (do ((i (fx1- index) (fx1- i))) 81 | ((or (fx=? i n)) 93 | (display #\space port) 94 | (display (bitmap-ref b i) port)) 95 | (display ")" port))) 96 | 97 | ) ; close library 98 | -------------------------------------------------------------------------------- /conversions/download_generate_unicode_wide.ss: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env schemesh 2 | 3 | (unless (file-type "gen-unicode-wide.txt") 4 | (sh-run 5 | {curl http://www.unicode.org/Public/UCD/latest/ucd/EastAsianWidth.txt --output gen-unicode-width.txt && 6 | grep '^[0-9A-F]' gen-unicode-width.txt | cut -d'#' -f1 | grep '; [FW]' | cut -d';' -f1 | tr '.' ' ' > gen-unicode-wide.txt})) 7 | 8 | 9 | ;; The unassigned code points in the following blocks default to "W": 10 | ;; CJK Unified Ideographs Extension A: U+3400..U+4DBF 11 | ;; CJK Unified Ideographs: U+4E00..U+9FFF 12 | ;; CJK Compatibility Ideographs: U+F900..U+FAFF 13 | ;; - All undesignated code points in Planes 2 and 3, whether inside or 14 | ;; outside of allocated blocks, default to "W": 15 | ;; Plane 2: U+20000..U+2FFFD 16 | ;; Plane 3: U+30000..U+3FFFD 17 | 18 | (define table (make-bytevector #x110000 0)) 19 | 20 | (define (wide-set! lo hi) 21 | (subbytevector-fill! table lo (fx1+ hi) 1)) 22 | 23 | (define (set-narrow! lo hi) 24 | (subbytevector-fill! table lo (fx1+ hi) 0)) 25 | 26 | ;; these are always wide 27 | (wide-set! #x3400 #x4DBF) 28 | (wide-set! #x4E00 #x9FFF) 29 | (wide-set! #xF900 #xFAFF) 30 | (wide-set! #x20000 #x3FFFF) 31 | 32 | (define (parse-lo-hi line) 33 | (let ((l (string-trim-split-at-blanks line))) 34 | (case (length l) 35 | ((1) 36 | (let ((lo (string->number (car l) 16))) 37 | (values lo lo))) 38 | ((2) 39 | (let ((lo (string->number (car l) 16)) 40 | (hi (string->number (cadr l) 16))) 41 | (values lo hi))) 42 | (else 43 | (values #f #f))))) 44 | 45 | (let ((in (file->port "gen-unicode-wide.txt" 'read '() 'utf8b))) 46 | (dynamic-wind 47 | void 48 | (lambda () 49 | (do ((line (get-line in) (get-line in))) 50 | ((not (string? line))) 51 | (let-values (((lo hi) (parse-lo-hi line))) 52 | (when (and lo hi) 53 | (wide-set! lo hi))))) 54 | (lambda () 55 | (close-port in)))) 56 | 57 | (define (show-range lo hi flag) 58 | (if (fx<=? (fx- hi lo) 180) 59 | (when flag 60 | (format #t "(wide-set! #x~x #x~x)\n" lo hi)) 61 | (unless flag 62 | (format #t "\n (char<=? #\\x~x ch #\\x~x)" lo hi)))) 63 | 64 | (define (show-table flag) 65 | (let %loop ((lo #f) (i 0) (n (bytevector-length table))) 66 | (cond 67 | ((fx>=? i n) 68 | (when lo 69 | (show-range lo (fx1- i) flag))) 70 | (lo 71 | (if (fxzero? (bytevector-u8-ref table i)) 72 | (begin 73 | (show-range lo (fx1- i) flag) 74 | (%loop #f (fx1+ i) n)) 75 | (%loop lo (fx1+ i) n))) 76 | (else 77 | (%loop (if (fxzero? (bytevector-u8-ref table i)) #f i) 78 | (fx1+ i) n))))) 79 | 80 | (define (lowest-wide) 81 | (do ((i 0 (fx1+ i)) 82 | (n (bytevector-length table))) 83 | ((or (fx>=? i n) (not (fxzero? (bytevector-u8-ref table i)))) 84 | (if (fx>=? i n) #f i)))) 85 | 86 | (define (highest-wide) 87 | (do ((i (fx1- (bytevector-length table)) (fx1- i))) 88 | ((or (fx "gen-unicode-wide-default.ss"}) 92 | (sh-run {$(show-table #f) >> "gen-unicode-wide-default.ss"}) 93 | (sh-run {$(display "\n)\n") >> "gen-unicode-wide-default.ss"}) 94 | 95 | (sh-run {$(show-table #t) > "gen-unicode-wide-set.ss"}) 96 | 97 | (sh-run {$(display (lowest-wide)) > "gen-unicode-wide-lowest.ss"}) 98 | (sh-run {$(display (highest-wide)) > "gen-unicode-wide-highest.ss"}) 99 | 100 | ;; (file-delete "gen-unicode-width.txt") 101 | ;; (file-delete "gen-unicode-wide.txt") 102 | -------------------------------------------------------------------------------- /posix/rlimit.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | (library (scheme2k posix rlimit (0 9 2)) 11 | (export rlimit-keys rlimit-ref rlimit-set!) 12 | (import 13 | (rnrs) 14 | (only (chezscheme) foreign-procedure) 15 | (only (scheme2k bootstrap) assert*) ; debugf 16 | (only (scheme2k containers list) for-list) 17 | (only (scheme2k posix fd) raise-c-errno)) 18 | 19 | 20 | (define c-errno-einval ((foreign-procedure "c_errno_einval" () int))) 21 | 22 | 23 | (define rlimit-keys 24 | (lambda () 25 | '(coredump-size data-size nice file-size pending-signals 26 | locked-memory-size memory-size open-files pipe-size msgqueue-size 27 | realtime-priority stack-size cpu-time user-processes 28 | virtual-memory-size file-locks realtime-nonblocking-time))) 29 | 30 | 31 | (define rlimit-key->ckey 32 | (let ((htable (make-eq-hashtable))) 33 | (for-list ((key (rlimit-keys)) 34 | (ckey ((foreign-procedure "c_rlimit_keys" () ptr)))) 35 | (hashtable-set! htable key ckey)) 36 | (lambda (who resource) 37 | (let ((ckey (hashtable-ref htable resource #f))) 38 | (unless ckey 39 | ;; throw if resource is not among (rlimit-keys) 40 | (assert* who (memq resource (rlimit-keys)))) 41 | ;; ckey can be #f if resource is not among C rlimit_keys[] 42 | ckey)))) 43 | 44 | 45 | ;; return unsigned per-process hard or soft resource limit, i.e. getrlimit() 46 | ;; returns #f if specified resource is not supported on current OS 47 | ;; returns 'unlimited if resource has no limit 48 | (define rlimit-ref 49 | (let ((c-rlimit-get (foreign-procedure "c_rlimit_get" (int int) ptr))) 50 | (lambda (hard-soft resource) 51 | ;; (debugf "(rlimit-ref ~s ~s)" hard-soft resource) 52 | (assert* 'rlimit-ref (memq hard-soft '(hard soft))) 53 | (let* ((ckey (rlimit-key->ckey 'rlimit-ref resource)) 54 | (ret (and ckey (c-rlimit-get (if (eq? hard-soft 'hard) 1 0) ckey)))) 55 | ;; (debugf "(rlimit-ref ~s ~s) -> ret = ~s" hard-soft resource ret) 56 | (cond 57 | ((eq? #t ret) 58 | 'unlimited) 59 | ((and ret (< ret 0)) 60 | (raise-c-errno 'rlimit-ref 'getrlimit ret hard-soft resource)) 61 | (else 62 | ret)))))) 63 | 64 | 65 | ;; set per-process hard or soft resource limit, i.e. setrlimit(). 66 | ;; limit to set must be an unsigned-64 or symbol 'unlimited 67 | ;; returns (void), or #f if specified resource is not supported on current OS 68 | (define rlimit-set! 69 | (let ((c-rlimit-set (foreign-procedure "c_rlimit_set" (int int ptr) int))) 70 | (lambda (hard-soft resource value) 71 | (assert* 'rlimit-set! (memq hard-soft '(hard soft))) 72 | (unless (eq? 'unlimited value) 73 | (assert* 'rlimit-set! (exact? value)) 74 | (assert* 'rlimit-set! (integer? value)) 75 | (assert* 'rlimit-set! (<= 0 value #xFFFFFFFFFFFFFFFF))) 76 | (let* ((ckey (rlimit-key->ckey 'rlimit-set! resource)) 77 | (ret (and 78 | ckey 79 | (c-rlimit-set 80 | (if (eq? hard-soft 'hard) 1 0) 81 | ckey 82 | (if (eq? 'unlimited value) #t value))))) 83 | ;; return (void) if resource was set successfully, 84 | ;; or #f if resource is not supported on current OS 85 | (if ret 86 | (when (< ret 0) 87 | (raise-c-errno 'rlimit-set! 'setrlimit ret hard-soft resource value)) 88 | ret))))) 89 | 90 | ) ; close library 91 | -------------------------------------------------------------------------------- /doc/shell/env.md: -------------------------------------------------------------------------------- 1 | # shell job environment variables 2 | 3 | Shell jobs are implemented by library `(schemesh shell job)` which is also included in `(schemesh shell)` and `(schemesh)`. 4 | 5 | Shell syntax to create and redirect shell jobs is the same as POSIX shells, 6 | and differences are documented in the main [README.md](../../README.md). 7 | 8 | Scheme functions to **create** shell jobs are not documented yet. 9 | 10 | Scheme functions to manage the **environment variables** of existing shell jobs are documented below. 11 | 12 | Scheme functions to **redirect** existing shell jobs, and to access redirected file descriptors of a job, are documented in [redirect.md](redirect.md). 13 | 14 | ### Alphabetical index 15 | * [`(sh-env-copy)`](#sh-env-copy) 16 | * [`(sh-env-delete!)`](#sh-env-delete) 17 | * [`(sh-env-ref)`](#sh-env-ref) 18 | * [`(sh-env-set!)`](#sh-env-set!) 19 | * [`(sh-env-visibility-ref)`](#sh-env-visibility-ref) 20 | * [`(sh-env-visibility-set!)`](#sh-env-visibility-set) 21 | 22 | ### Jobs environment variables 23 | 24 | Each job created by schemesh has its own environment variables, redirections and current directory. 25 | 26 | When a new job is created, it *references* the environment variables, redirections, and current directory of its parent job. 27 | Note: the main schemesh process acts the default parent job if none is specified. 28 | 29 | This means that by default, changing the environment variables, redirections or current directory of a parent job also affects all its children jobs. 30 | 31 | To stop such sharing, just set a job's environment variable (or delete it): the new value shadows the inherited one, and such variable is no longer shared. 32 | The same applies for redirections and current directory: if you set some of them, they shadow inherited values. 33 | 34 | All the functions to access or modify jobs' environment variables always accept as first parameter a `job-or-id`: 35 | it can be a job object, or the numeric ID of a job, or one of the special values: 36 | * `#t` shortcut for the main schemesh process, i.e. the job (sh-globals) 37 | * `#f` shortcut for the current scheme job, i.e. (sh-current-job) 38 | 39 | ##### (sh-env-ref) 40 | `(sh-env-ref job-or-id name)` returns the string value of environment variable `name` for specified job or job-id. 41 | Argument `name` must be a string. Returns the empty string if environment variable `name` is not found. 42 | 43 | ##### (sh-env-set!) 44 | `(sh-env-set! job-or-id name value [visibility])` sets the string value of environment variable `name` for specified job or job-id. 45 | Argument `name` must be a string, and optional `visibility` must be one of the symbols `'export` `'private` `'maintain`. 46 | 47 | Only environment variables with `visibility` equal to `'export` are passed to child processes, 48 | and `visibility` not specified or equal to `'maintain` indicates to preserve the current visibility of specified environment variable. 49 | 50 | ##### (sh-env-visibility-ref) 51 | `(sh-env-visibility-ref job-or-id name)` returns the value and visibility of environment variable `name` for specified job or job-id. 52 | 53 | If the environment variable `name` is found, returns `(value str vis)` 54 | where `str` is the the string value of environment variable, 55 | and `vis` is one of the symbols `'export` `'private`. 56 | 57 | If the environment variable `name` is not found, returns `(values #f #f)`. 58 | 59 | ##### (sh-env-visibility-set!) 60 | `(sh-env-visibility-set! job-or-id name visibility)` is equivalent to `(sh-env-set! job-or-id name [visibility])` 61 | with the only difference that all arguments are mandatory. 62 | 63 | ##### (sh-env-delete!) 64 | `(sh-env-delete! job-or-id name)` removes environment variable `name` from specified job or job-id. 65 | 66 | ##### (sh-env-copy) 67 | `(sh-env-copy job-or-id visibility)` returns a string->string hashtable containing a copy of all environment variables for specified job or job-id. 68 | 69 | Argument `visibility` must be one of the symbols: 70 | * `'export` indicating that only exported environment variables should be returned 71 | * `'all` indicating that both exported and private environment variables should be returned 72 | -------------------------------------------------------------------------------- /eval.c: -------------------------------------------------------------------------------- 1 | /** 2 | * Copyright (C) 2023-2025 by Massimiliano Ghilardi 3 | * 4 | * This library is free software; you can redistribute it and/or 5 | * modify it under the terms of the GNU Library General Public 6 | * License as published by the Free Software Foundation; either 7 | * version 2 of the License, or (at your option) any later version. 8 | */ 9 | 10 | #include "eval.h" 11 | #include "containers/containers.h" /* scheme2k_Sstring_utf8b() */ 12 | 13 | #include /* NULL */ 14 | #include /* strlen() */ 15 | 16 | static ptr top_level_value(const char symbol_name[]) { 17 | return Stop_level_value(Sstring_to_symbol(symbol_name)); 18 | } 19 | 20 | /** 21 | * call global Scheme procedure with no arguments. 22 | * Return the resulting Scheme value. 23 | */ 24 | ptr scheme2k_call0(const char symbol_name[]) { 25 | return Scall0(top_level_value(symbol_name)); 26 | } 27 | 28 | /** 29 | * call global Scheme procedure having specified symbol name 30 | * passing a single Scheme argument to it. 31 | * Return the resulting Scheme value. 32 | */ 33 | ptr scheme2k_call1(const char symbol_name[], ptr arg) { 34 | return Scall1(top_level_value(symbol_name), arg); 35 | } 36 | 37 | /** 38 | * call global Scheme procedure having specified symbol name 39 | * passing two Scheme arguments to it. 40 | * Return the resulting Scheme value. 41 | */ 42 | ptr scheme2k_call2(const char symbol_name[], ptr arg1, ptr arg2) { 43 | return Scall2(top_level_value(symbol_name), arg1, arg2); 44 | } 45 | 46 | /** 47 | * call global Scheme procedure having specified symbol name 48 | * passing three Scheme arguments to it. 49 | * Return the resulting Scheme value. 50 | */ 51 | ptr scheme2k_call3(const char symbol_name[], ptr arg1, ptr arg2, ptr arg3) { 52 | return Scall3(top_level_value(symbol_name), arg1, arg2, arg3); 53 | } 54 | 55 | /** 56 | * call Scheme (eval (read (open-string-input-port str))) on a C string 57 | * and return the resulting Scheme value. 58 | */ 59 | ptr scheme2k_eval(const char str[]) { 60 | /* this must work also without libschemesh -> do not use (sh-eval...) */ 61 | return scheme2k_call1( 62 | "eval", 63 | scheme2k_call1("read", 64 | scheme2k_call1("open-string-input-port", scheme2k_Sstring_utf8b(str, -1)))); 65 | } 66 | 67 | /** 68 | * Load a compiled Scheme library. 69 | * 70 | * @return 0 if successful, 71 | * otherwise print error message to (current-error-port) and return < 0 72 | */ 73 | int scheme2k_load_library(const char* dir, const char* filename) { 74 | static ptr func_load = Sfalse; 75 | ptr ret; 76 | if (func_load == Sfalse) { 77 | #if 0 78 | func_load = scheme2k_eval("(lambda (dir filename)\n" 79 | " (load (string-append dir \"/\" filename))\n" 80 | " #t)\n"); 81 | #else 82 | func_load = scheme2k_eval /* */ 83 | ("(lambda (dir filename)\n" 84 | " (let ((path (if (fxzero? (string-length dir))\n" 85 | " filename\n" 86 | " (string-append dir \"/\" filename))))\n" 87 | " (call/cc\n" 88 | " (lambda (k-exit)\n" 89 | " (with-exception-handler\n" 90 | " (lambda (ex)\n" 91 | " (let ((port (current-error-port)))\n" 92 | " (put-string port \"schemesh: \")" 93 | " (display-condition ex port)\n" 94 | " (newline port)\n" 95 | " (flush-output-port port))\n" 96 | " (k-exit #f))\n" /* exception -> return #f */ 97 | " (lambda ()\n" 98 | " (load path)\n" 99 | " #t))))))\n"); /* success -> return #t */ 100 | #endif 101 | Slock_object(func_load); 102 | } 103 | ret = Scall2(func_load, 104 | scheme2k_Sstring_utf8b(dir, -1), /* */ 105 | scheme2k_Sstring_utf8b(filename, -1)); 106 | /* Sunlock_object(func_load); */ 107 | return ret == Strue ? 0 : -1; 108 | } 109 | -------------------------------------------------------------------------------- /utils/import.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | ;; define (schemesh minimal) as a library that exports all its imported bindings 11 | (library-reexport (schemesh minimal (0 9 2)) 12 | (import (schemesh shell) 13 | (schemesh repl))) 14 | 15 | 16 | ;; library (schemesh rnrs) exports the same bindings as (rnrs), 17 | ;; except for few bindings that are replaced with improved alternatives: 18 | ;; 19 | ;; bytevector-sint-ref bytevector-sint-set! 20 | ;; bytevector-uint-ref bytevector-uint-set! 21 | ;; file-exists? delete-file 22 | ;; get-bytevector-all get-bytevector-n get-bytevector-some 23 | ;; get-char get-datum get-line get-string-all get-string-n get-u8 24 | ;; put-bytevector put-char put-datum put-string put-u8 25 | ;; 26 | (library-reexport (schemesh rnrs (0 9 2)) 27 | (import 28 | (except (rnrs) bytevector-sint-ref bytevector-sint-set! 29 | bytevector-uint-ref bytevector-uint-set! 30 | file-exists? delete-file 31 | get-bytevector-all get-bytevector-n get-bytevector-some 32 | get-char get-datum get-line get-string-all get-string-n get-u8 33 | put-bytevector put-char put-datum put-string put-u8) 34 | (scheme2k containers replacements) ;; intentionally conflicts with some R6RS and Chez Scheme functions, because it is intended to replace them. 35 | (scheme2k posix replacements) ;; intentionally conflicts with some R6RS and Chez Scheme functions, because it is intended to replace them. 36 | (schemesh shell replacements))) ;; intentionally conflicts with some R6RS and Chez Scheme functions, because it is intended to replace them. 37 | 38 | 39 | ;; library (schemesh) collects and exports *all* bindings defined by all libschemesh sub-libraries, 40 | ;; including few bindings that intentionally conflict with some R6RS and Chez Scheme functions 41 | ;; because they are intended as replacements 42 | (library-reexport (schemesh (0 9 2)) 43 | (import 44 | (scheme2k bootstrap) 45 | (scheme2k containers) 46 | (scheme2k containers replacements) ;; intentionally conflicts with some R6RS and Chez Scheme functions, because it is intended to replace them. 47 | (scheme2k conversions) 48 | (scheme2k ipc) 49 | (scheme2k lineedit) 50 | (scheme2k port) 51 | (scheme2k posix) 52 | (scheme2k vscreen) 53 | (scheme2k wire) 54 | (scheme2k posix replacements) ;; intentionally conflicts with some R6RS and Chez Scheme functions, because it is intended to replace them. 55 | (schemesh parser) 56 | (schemesh shell) 57 | (schemesh shell replacements) ;; intentionally conflicts with some R6RS and Chez Scheme functions, because it is intended to replace them. 58 | (schemesh repl))) 59 | 60 | 61 | ;; when reloading libschemesh.ss, reimport (schemesh shell) and (schemesh repl) 62 | ;; fixes error "compiled program requires a different compilation instance of (schemesh ...)"" 63 | (eval-when (eval) 64 | (let () 65 | (import (rnrs) 66 | (only (chezscheme) top-level-bound? eval)) 67 | 68 | (when (top-level-bound? 'sh-version) 69 | (eval '(import (scheme2k bootstrap)))) 70 | (when (top-level-bound? 'subbytevector) 71 | (eval '(import (scheme2k containers))) 72 | (eval '(import (scheme2k containers replacements)))) 73 | (when (top-level-bound? 'text->bytevector) 74 | (eval '(import (scheme2k conversions)))) 75 | (when (top-level-bound? 'vcell) 76 | (eval '(import (scheme2k vscreen)))) 77 | (when (top-level-bound? 'lineedit-read) 78 | (eval '(import (scheme2k lineedit)))) 79 | (when (top-level-bound? 'parsers) 80 | (eval '(import (schemesh parser)))) 81 | (when (top-level-bound? 'pid-wait) 82 | (eval '(import (scheme2k posix))) 83 | (eval '(import (scheme2k posix replacements)))) 84 | (when (top-level-bound? 'sh-persistent-parameters) 85 | (eval '(import (schemesh shell))) 86 | (eval '(import (schemesh shell replacements)))) 87 | (when (top-level-bound? 'repl) 88 | (eval '(import (schemesh repl)))))) 89 | -------------------------------------------------------------------------------- /lineedit/parenmatcher.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | (library (scheme2k lineedit parenmatcher (0 9 2)) 11 | (export 12 | parenmatcher? make-custom-parenmatcher parenmatcher-clear! 13 | parenmatcher-paren parenmatcher-maybe-update! 14 | parenmatcher-find/at parenmatcher-find/surrounds) 15 | (import 16 | (rnrs) 17 | (only (chezscheme) record-writer) 18 | (only (scheme2k bootstrap) assert*) 19 | (scheme2k lineedit paren)) 20 | 21 | ;; type parenmatcher contains bookkeeping information, 22 | ;; to be filled by an actual function that matches parenthesis 23 | ;; - as for example sh-parenmatcher 24 | 25 | (define-record-type (parenmatcher %make-parenmatcher parenmatcher?) 26 | (fields 27 | update-func ; procedure (parsectx initial-parser) -> state 28 | (mutable paren) ; #f or outermost paren object 29 | (mutable htable)) ; #f or hashtable (+ x (* y 65536)) -> paren 30 | (nongenerative %parenmatcher-7c46d04b-34f4-4046-b5c7-b63753c1be39)) 31 | 32 | ;; Create a parenmatcher containing user-specified procedure. 33 | ;; 34 | ;; update-func must be a procedure accepting two argument: parsectx initial-parsers 35 | ;; and returning one value: the outermost paren object. 36 | ;; it should parse the textual input port (parsectx-in parsectx), 37 | ;; find matching parenthesis or grouping tokens, 38 | ;; and return the corresponding paren object, 39 | ;; which will be stored in parenmatcher-paren 40 | ;; to avoid calling update-func multiple times on the same input. 41 | (define (make-custom-parenmatcher update-func) 42 | (assert* 'make-custom-parenmatcher (procedure? update-func)) 43 | (%make-parenmatcher update-func #f #f)) 44 | 45 | 46 | ;; if (parenmatcher-htable pm) is #f then parse (parsectx-in pctx) 47 | ;; by calling (parenmatcher-update-func pm) and store the created paren and hashtable 48 | ;; into parenmatcher pm 49 | (define (parenmatcher-maybe-update! pm pctx-or-func initial-parser) 50 | (unless (parenmatcher-htable pm) 51 | (let* ((pctx (if (procedure? pctx-or-func) (pctx-or-func) pctx-or-func)) 52 | (paren ((parenmatcher-update-func pm) pctx initial-parser))) 53 | ; (debugf-paren paren) 54 | (parenmatcher-paren-set! pm paren) 55 | (parenmatcher-htable-set! pm (paren->hashtable paren))))) 56 | 57 | 58 | ;; Find parenthesis or grouping token starting or ending at position x y. 59 | ;; 60 | ;; In detail: 61 | ;; 62 | ;; first, call (parenmatcher-maybe-update!) to update parenmatcher if needed, 63 | ;; then call (paren-hashtable-ref) to find parenthesis or grouping token 64 | ;; starting or ending at position x y. 65 | ;; 66 | ;; Return such matching paren, 67 | ;; or #f no parenthesis or grouping token starts or ends at position x y 68 | (define (parenmatcher-find/at pm pctx-or-func initial-parser x y) 69 | (if pm 70 | (begin 71 | (parenmatcher-maybe-update! pm pctx-or-func initial-parser) 72 | (paren-hashtable-ref (parenmatcher-htable pm) x y)) 73 | #f)) 74 | 75 | 76 | ;; Find innermost parenthesis or grouping token surrounding position x y. 77 | ;; 78 | ;; In detail: 79 | ;; 80 | ;; first, call (parenmatcher-maybe-update!) to update parenmatcher if needed, 81 | ;; then call (paren-hashtable-ref) to find parenthesis or grouping token 82 | ;; starting or ending at position x y. 83 | ;; 84 | ;; Return such matching paren, 85 | ;; or #f no parenthesis or grouping token surrounds position x y 86 | (define (parenmatcher-find/surrounds pm pctx-or-func initial-parser x y) 87 | (if pm 88 | (begin 89 | (parenmatcher-maybe-update! pm pctx-or-func initial-parser) 90 | (let ((paren (parenmatcher-paren pm))) 91 | (and paren (paren-find/surrounds paren x y)))) 92 | #f)) 93 | 94 | 95 | (define (parenmatcher-clear! pm) 96 | (when pm 97 | (parenmatcher-paren-set! pm #f) 98 | (parenmatcher-htable-set! pm #f))) 99 | 100 | 101 | ;; customize how "parenmatcher" objects are printed 102 | (record-writer (record-type-descriptor parenmatcher) 103 | (lambda (pm port writer) 104 | (display "#" port))) 105 | 106 | ) ; close library 107 | -------------------------------------------------------------------------------- /doc/comparison_with_other_shells.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | # Comparison between schemesh and other Lisp-based shells 4 | 5 | Schemesh is intended as an interactive shell and REPL: 6 | it supports line editing, autocompletion, searchable history, aliases, builtins, 7 | a customizable prompt, and automatic loading of `~/.config/schemesh/repl_init.ss`. 8 | 9 | Most importantly, it also has job control (CTRL+Z, `fg`, `bg` etc.) 10 | and recognizes and extends Unix shell syntax for starting, redirecting and composing jobs. 11 | 12 | Schemesh author is not aware of any other Lisp-based shell that supports *all* of these features. 13 | 14 | All other known Lisp-based shells lack at least job control, 15 | i.e. the ability to suspend a job and resume it in the background or foreground. 16 | 17 | Some alternative shells also have additional limitations. 18 | 19 | 20 | ## Scsh 21 | 22 | [Scsh](https://scsh.net/) is a Lisp programming environment built on top of [Scheme 48](https://www.s48.org/), 23 | with additional Scheme functions for running programs and setting up pipelines and redirections, 24 | and a syscall library for low-level access to the operating system. 25 | 26 | As stated in [Scsh Reference manual - Caveats](https://scsh.net/docu/html/man-Z-H-2.html#node_sec_1.4) 27 | > Scsh, in the current release, is primarily designed for the writing of shell scripts -- programming. 28 | > It is not a very comfortable system for interactive command use: 29 | > the current release lacks job control, command-line editing, a terse, convenient command syntax, 30 | > and it does not read in an initialisation file analogous to .login or .profile 31 | 32 | Also, scsh does not allow a lone dot `.` 33 | * neither as a shell command (the traditional meaning is "load and execute the file specified as argument") 34 | * nor as a shell command argument (it traditionally indicates the current directory) 35 | 36 | The reason for this limitation is: 37 | scsh syntax for creating shell commands is a DSL, i.e. a domain-specific language, built using macros that work on top of Scheme syntax. 38 | And in Scheme, the dot `.` is a low-level syntactic token with its own meaning - it cannot be used as an identifier. 39 | 40 | ## Rash 41 | 42 | [Rash](http://rash-lang.org/) is a shell language, library, and REPL for [Racket](https://racket-lang.org/). 43 | 44 | As explained in [Rash github page](https://github.com/willghatch/racket-rash#getting-started) it can be used as: 45 | * a repl that is as convenient for pipelining programs as Bash is, but has all the power of Racket. 46 | * a scripting language with #lang rash. 47 | * embedded in normal Racket files with (require rash), and mixed freely with any other Racket language or library. 48 | 49 | And indeed it is very similar to schemesh in many aspects: 50 | 51 | both aim to create an interactive, Unix-like shell scriptable in some dialect of Lisp, 52 | and both support line editing, autocompletion, and Unix shell syntax for starting, redirecting and composing jobs. 53 | 54 | Rash has several limitations, sometimes due to design choices, that schemesh solves: 55 | 56 | 1. no job control 57 | 2. multi-line editing is limited 58 | 3. shell commands are Lisp functions, not Lisp objects. 59 | Inspecting and redirecting them after they have been created is difficult 60 | 4. being written in Racket, has larger RAM footprint than schemesh running on vanilla Chez Scheme: 61 | at startup, ~160MB vs. ~40MB 62 | 5. support for multi-language at REPL is limited: once you do `#lang racket`, you cannot go back to `#lang rash` 63 | This is a limitation imposed by the underlying Racket system, and Rash can do relatively little to remove it. 64 | 65 | 66 | ## Eshell 67 | 68 | [Eshell](https://www.gnu.org/software/emacs/manual/html_mono/eshell.html) is a shell written in EmacsLisp. 69 | 70 | It is included in most versions of Emacs, and can be started from inside Emacs with `M-x eshell`. 71 | 72 | Eshell is a shell-like command interpreter, with an interface similar to command shells such as bash, zsh, rc, or 4dos. 73 | As such, it has line editing, autocompletion, history, aliases, builtins, 74 | and recognizes Unix shell syntax for starting, redirecting and composing jobs. 75 | 76 | The main limitations are: 77 | 78 | 1. no job control 79 | 2. Eshell runs *inside* Emacs, so it's difficult to use as a login shell. 80 | 3. pipelines are supported, but in some cases they work differently from POSIX shell semantics: 81 | 82 | For example, `ls | less` shows `ls` output in one Emacs buffer i.e. without piping it into `less`, 83 | while in another Emacs buffer it shows an error message "Missing filename" from `less` 84 | 85 | 86 | # Comparison between schemesh and other non-Lisp-based shells 87 | 88 | To be written 89 | -------------------------------------------------------------------------------- /utils/countdown.c: -------------------------------------------------------------------------------- 1 | /** 2 | * Written in 2025 by Massimiliano Ghilardi 3 | * 4 | * To the extent possible under law, the author(s) have dedicated all copyright 5 | * and related and neighboring rights to this software to the public domain 6 | * worldwide. This software is distributed without any warranty. 7 | * 8 | * You should have received a copy of the CC0 Public Domain Dedication along with 9 | * this software. If not, see . 10 | */ 11 | 12 | /** 13 | * Pause for user-specified number of seconds. 14 | * 15 | * The number of seconds to pause include only the interval this program is running: 16 | * if suspended with CTRL+Z or SIGTSTP, the suspended duration is not counted. 17 | * 18 | * This effectively works as a countdown from NUMBER seconds to zero, 19 | * that can be suspended with CTRL+Z or SIGTSTP and resumed by continuing this program. 20 | */ 21 | 22 | #include /* errno */ 23 | #include /* sigaction() */ 24 | #include /* _Atomic, atomic_store(), atomic_exchange() */ 25 | #include /* fprintf(), stderr() */ 26 | #include /* strtod() */ 27 | #include /* strerror() */ 28 | #include /* clock_gettime(), clock_nanosleep() */ 29 | 30 | typedef struct timespec timespec; 31 | 32 | static int c_fail(const char label[], int err) { 33 | fprintf(stderr, "%s failed with error %d: %s\n", label, err, strerror(err)); 34 | return err; 35 | } 36 | 37 | static _Atomic int c_sigtstp_received = 0; 38 | 39 | static void c_sigtstp_handler(int sig) { 40 | (void)sig; 41 | atomic_store(&c_sigtstp_received, 1); 42 | } 43 | 44 | static void c_sigtstp_sethandler(void) { 45 | struct sigaction action = {}; 46 | action.sa_handler = &c_sigtstp_handler; 47 | (void)sigaction(SIGTSTP, &action, NULL); 48 | } 49 | 50 | static void c_sigtstp_setdefault(void) { 51 | struct sigaction action = {}; 52 | action.sa_handler = SIG_DFL; 53 | (void)sigaction(SIGTSTP, &action, NULL); 54 | } 55 | 56 | static int c_countdown(timespec interval) { 57 | timespec left = {}; 58 | int err; 59 | while ((interval.tv_sec > 0 || (interval.tv_sec == 0 && interval.tv_nsec > 0))) { 60 | c_sigtstp_sethandler(); 61 | 62 | /* macOS lacks clock_nanosleep(). How to test for clock_nanosleep() availability? */ 63 | #if defined(CLOCK_MONOTONIC) && !defined(__APPLE__) 64 | err = clock_nanosleep(CLOCK_MONOTONIC, 0, &interval, &left); 65 | #else 66 | if ((err = nanosleep(&interval, &left)) != 0) { 67 | err = errno; 68 | } 69 | #endif 70 | if (err == 0) { 71 | break; 72 | } else if (err != EINTR) { 73 | #if defined(CLOCK_MONOTONIC) && !defined(__APPLE__) 74 | return c_fail("clock_nanosleep(CLOCK_MONOTONIC)", err); 75 | #else 76 | return c_fail("nanosleep()", err); 77 | #endif 78 | } 79 | interval = left; 80 | if (atomic_exchange(&c_sigtstp_received, 0)) { 81 | c_sigtstp_setdefault(); 82 | raise(SIGTSTP); 83 | } 84 | } 85 | return 0; 86 | } 87 | 88 | static int help(const char* name) { 89 | if (!name || !name[0]) { 90 | name = "countdown"; 91 | } 92 | fprintf(stdout, "%s: missing argument.\nType '%s --help' for more information.\n", name, name); 93 | return 0; 94 | } 95 | 96 | static int usage(const char* name) { 97 | if (!name || !name[0]) { 98 | name = "countdown"; 99 | } 100 | fprintf(stdout, 101 | "Usage: %s NUMBER\n%s", 102 | name, 103 | "Pause for NUMBER seconds.\n" 104 | "\n" 105 | "The number of seconds to pause include only the interval this program is running:\n" 106 | "if suspended with CTRL+Z or SIGTSTP, the suspended duration is not counted.\n" 107 | "\n" 108 | "This effectively works as a countdown from NUMBER seconds to zero,\n" 109 | "that can be suspended with CTRL+Z or SIGTSTP and resumed by continuing this program.\n"); 110 | return 0; 111 | } 112 | 113 | int main(int argc, char** argv) { 114 | double seconds = 0.0; 115 | if (argc <= 1) { 116 | return help(argv[0]); 117 | } else if (!strcmp(argv[1], "--help")) { 118 | return usage(argv[0]); 119 | } else { 120 | char* end = NULL; 121 | seconds = strtod(argv[1], &end); 122 | if (*end) { 123 | seconds = 0.0; 124 | } 125 | } 126 | if (seconds > 0.0) { 127 | timespec interval; 128 | interval.tv_sec = (time_t)seconds; 129 | interval.tv_nsec = (long)(0.5 + 1e9 * (seconds - (double)interval.tv_sec)); 130 | return c_countdown(interval); 131 | } 132 | return 0; 133 | } 134 | -------------------------------------------------------------------------------- /utils/benchmark_async_signal_handler.c: -------------------------------------------------------------------------------- 1 | /** 2 | * Copyright (C) 2023-2025 by Massimiliano Ghilardi 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU General Public License as published by 6 | * the Free Software Foundation; either version 2 of the License, or 7 | * (at your option) any later version. 8 | */ 9 | 10 | #include 11 | #include /* sched_yield() */ 12 | #include 13 | #include 14 | #include /* int64_t */ 15 | #include 16 | #include /* strerror() */ 17 | #include /* clock_gettime() */ 18 | #include 19 | 20 | #define N_OF(array) (sizeof(array) / sizeof((array)[0])) 21 | 22 | #if 1 /* defined(__STDC_VERSION__) && __STDC_VERSION__ >= 201112L && !defined(__STDC_NO_ATOMICS__) \ 23 | */ 24 | #define ATOMIC _Atomic 25 | #else 26 | #define ATOMIC volatile 27 | #endif 28 | 29 | static int c_errno(void) { 30 | return -errno; 31 | } 32 | 33 | static const char* c_strerror(int err) { 34 | return strerror(err < 0 ? -err : err); 35 | } 36 | 37 | static int scheme2k_init_failed(const char label[]) { 38 | const int err = c_errno(); 39 | fprintf(stderr, 40 | "error initializing POSIX subsystem: %s failed with error %s\n", 41 | label, 42 | c_strerror(err)); 43 | return err; 44 | } 45 | 46 | static ATOMIC int c_sigusr1_received = 0; 47 | 48 | static void c_sigusr1_handler(int sig_num) { 49 | atomic_store(&c_sigusr1_received, 1); 50 | } 51 | 52 | static int c_sigusr1_consume(void) { 53 | return atomic_exchange(&c_sigusr1_received, 0); 54 | } 55 | 56 | static int c_signals_init(void) { 57 | struct sigaction action = {}; 58 | action.sa_handler = &c_sigusr1_handler; 59 | if (sigaction(SIGCHLD, &action, NULL) < 0) { 60 | return scheme2k_init_failed("sigaction(SIGCHLD)"); 61 | } 62 | return 0; 63 | } 64 | 65 | static int c_signals_setdefault(void) { 66 | struct sigaction action = {}; 67 | size_t i = 0; 68 | action.sa_handler = SIG_DFL; 69 | 70 | if (sigaction(SIGCHLD, &action, NULL) < 0) { 71 | return c_errno(); 72 | } 73 | return 0; 74 | } 75 | 76 | static int c_pid_send_signal(pid_t pid, int sig) { 77 | if (kill(pid, sig) < 0) { 78 | return c_errno(); 79 | } 80 | return 0; 81 | } 82 | 83 | static int c_pid_fork(void) { 84 | const pid_t pid = fork(); 85 | switch (pid) { 86 | case -1: /* fork() failed */ 87 | return c_errno(); 88 | case 0: /* child */ 89 | return 0; 90 | default: /* parent */ 91 | return pid; 92 | } 93 | } 94 | 95 | static int64_t c_steady_time_ns(void) { 96 | struct timespec ts; 97 | if (clock_gettime(CLOCK_MONOTONIC, &ts) < 0) { 98 | return (int64_t)-1; 99 | } 100 | return ts.tv_nsec + ts.tv_sec * 1000000000; 101 | } 102 | 103 | static ssize_t c_read(int fd, char buf[], size_t n) { 104 | const ssize_t got = read(fd, buf, n); 105 | return got >= 0 ? got : c_errno(); 106 | } 107 | 108 | static int c_run_child(void) { 109 | ssize_t err; 110 | char buf[1]; 111 | for (;;) { 112 | err = c_read(0, buf, sizeof(buf)); 113 | if (err > 0) { 114 | continue; 115 | } else if (err == 0 || (err < 0 && err != -EINTR)) { 116 | return err; 117 | } 118 | if (c_sigusr1_consume()) { 119 | fprintf(stdout, "signal handler executed in 0 ns\n"); 120 | } else { 121 | const int64_t t1 = c_steady_time_ns(); 122 | while (!c_sigusr1_consume()) { 123 | (void)sched_yield(); 124 | } 125 | const int64_t t2 = c_steady_time_ns(); 126 | fprintf(stdout, "signal handler executed in %lld ns\n", (long long)(t2 - t1)); 127 | } 128 | const int64_t t2 = c_steady_time_ns(); 129 | fflush(stdout); 130 | } 131 | } 132 | 133 | static int c_sleep(const int64_t s, const uint32_t ns) { 134 | struct timespec ts; 135 | ts.tv_sec = s; 136 | ts.tv_nsec = ns; 137 | return nanosleep(&ts, NULL) < 0 ? c_errno() : 0; 138 | } 139 | 140 | static int c_run_parent(pid_t child_pid) { 141 | for (int i = 0; i < 10; i++) { 142 | const int64_t t1 = c_steady_time_ns(); 143 | const int64_t t2 = c_steady_time_ns(); 144 | fprintf(stdout, "clock_gettime executed in %lld ns\n", (long long)(t2 - t1)); 145 | } 146 | for (;;) { 147 | (void)c_sleep(1, 0); 148 | c_pid_send_signal(child_pid, SIGCHLD); 149 | } 150 | return 0; 151 | } 152 | 153 | int main(int argc, char** argv) { 154 | int err; 155 | if ((err = c_signals_init()) < 0) { 156 | return err; 157 | } 158 | #if 1 159 | if ((err = c_pid_fork()) < 0) { 160 | return err; 161 | } 162 | #endif 163 | if (err == 0) { 164 | return c_run_child(); 165 | } else { 166 | return c_run_parent((pid_t)err); 167 | } 168 | } 169 | -------------------------------------------------------------------------------- /parser/parser.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | (library (schemesh parser (0 9 2)) 11 | (export 12 | ; lisp.ss 13 | lex-lisp parse-lisp-forms parse-lisp-paren read-lisp-token 14 | 15 | ; parser.ss 16 | make-parsectx make-parsectx* parsectx? 17 | parsectx-skip-whitespace parsectx-unread-char parsectx-try-read-directive 18 | get-parser to-parser make-parser parser? parser-name 19 | parser-parse-forms parser-parse-paren 20 | 21 | ; r6rs.ss 22 | lex-r6rs parse-r6rs-forms parser-r6rs 23 | 24 | ; scheme.ss 25 | lex-scheme parse-scheme-forms1 parse-scheme-forms parser-scheme 26 | 27 | ; shell.ss 28 | read-shell-char lex-shell parse-shell-word parse-shell-form1 29 | parse-shell-forms parser-shell 30 | 31 | ; parser.ss 32 | parse-forms parse-forms1 33 | parse-paren string->paren make-parenmatcher 34 | parsers) 35 | (import 36 | (rnrs) 37 | (rnrs mutable-pairs) 38 | (only (chezscheme) reverse! void) 39 | (only (scheme2k bootstrap) assert*) 40 | (scheme2k lineedit paren) 41 | (only (scheme2k lineedit parenmatcher) make-custom-parenmatcher) 42 | (scheme2k lineedit parser) 43 | (schemesh parser lisp) 44 | (schemesh parser r6rs) 45 | (schemesh parser scheme) 46 | (schemesh parser shell)) 47 | 48 | 49 | ;; Return mutable hashtable containing all known parsers. 50 | (define parsers 51 | (let ((ret (make-eq-hashtable))) 52 | (hashtable-set! ret 'r6rs (parser-r6rs)) 53 | (hashtable-set! ret 'scheme (parser-scheme)) 54 | (hashtable-set! ret 'chezscheme (parser-scheme)) 55 | (hashtable-set! ret 'shell (parser-shell)) 56 | (lambda () 57 | ret))) 58 | 59 | 60 | ;; Parse textual input port until eof, using the parser specified by initial-parser, 61 | ;; and temporarily switching to other parsers every time the directive #!... is found 62 | ;; in a (possibly nested) list being parsed. 63 | ;; 64 | ;; Return two values. 65 | ;; First value is list of parsed forms 66 | ;; Second value is updated parser to use. 67 | (define (parse-forms pctx initial-parser) 68 | (let* ((parser (to-parser pctx initial-parser 'parse-forms)) 69 | (func-parse-forms (parser-parse-forms parser))) 70 | (let-values (((form updated-parser) (func-parse-forms pctx 'eof))) 71 | (values form (or updated-parser parser))))) 72 | 73 | 74 | ;; Parse textual input port until eof, using the parser specified by initial-parser, 75 | ;; and temporarily switching to other parsers every time the directive #!... is found 76 | ;; in a (possibly nested) list being parsed. 77 | ;; 78 | ;; Return list of parsed forms 79 | (define (parse-forms1 pctx initial-parser) 80 | (let-values (((ret _) (parse-forms pctx initial-parser))) 81 | ret)) 82 | 83 | 84 | ;; Parse textual input port (parsectx-in pctx) until closing token matching start-ch is found 85 | ;; (or until end-of-file if start-ch is #f) using the parser specified by initial-parser, 86 | ;; and temporarily switching to other parsers every time the directive #!... is found 87 | ;; in a (possibly nested) list being parsed. 88 | ;; 89 | ;; Return a paren describing the ( [ { " ' ` | characters in input stream, 90 | ;; their positions, and the positions of their matching ) ] } " ' ` | 91 | (define (parse-paren pctx start-ch initial-parser) 92 | (assert* 'parse-paren (parsectx? pctx)) 93 | (let* ((current-parser (to-parser pctx initial-parser 'parse-paren)) 94 | (current-parse-paren (parser-parse-paren current-parser))) 95 | (current-parse-paren pctx start-ch))) 96 | 97 | 98 | 99 | ;; Function stored by (make-parenmatcher) into created parenmatcher: 100 | ;; 101 | ;; parse textual input port (parsectx-in pctx) until end-of-file 102 | ;; for matching parenthesis and grouping tokens, 103 | ;; and return corresponding paren object 104 | ;; 105 | ;; Equivalent to (parse-paren pctx #f initial-parser) 106 | (define (parse-paren-all pctx initial-parser) 107 | (parse-paren pctx #f initial-parser)) 108 | 109 | 110 | ;; Simple wrapper around parse-paren-all, useful for testing 111 | (define string->paren 112 | (case-lambda 113 | ((str) (parse-paren-all (string->parsectx str (parsers)) 'scheme)) 114 | ((str initial-parser) (parse-paren-all (string->parsectx str (parsers)) initial-parser)))) 115 | 116 | 117 | ;; Create a parenmatcher that uses parse-paren to find matching parenthesis and grouping tokens 118 | (define (make-parenmatcher) 119 | (make-custom-parenmatcher parse-paren-all)) 120 | 121 | 122 | 123 | 124 | ) ; close library 125 | -------------------------------------------------------------------------------- /libscheme2k.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | ;;; This file loads and compiles the subset of schemesh sources 11 | ;;; that are licensed as LGPLv2+ into Scheme library libscheme2k_0.9.2.so 12 | 13 | (begin 14 | (include "bootstrap/arrow.ss") 15 | (include "bootstrap/functions.ss") 16 | (include "bootstrap/bootstrap.ss") 17 | 18 | (include "containers/bitmap.ss") 19 | (include "containers/bytevector.ss") 20 | (include "containers/flvector.ss") 21 | (include "containers/fxvector.ss") 22 | (include "containers/in.ss") 23 | (include "containers/list.ss") 24 | (include "containers/string.ss") 25 | (include "containers/vector.ss") 26 | (include "containers/hashtable.ss") ; requires containers/list.ss 27 | (include "containers/bytespan.ss") ; requires containers/bytevector.ss containers/list.ss 28 | (include "containers/charspan.ss") ; requires containers/string.ss 29 | (include "containers/span.ss") ; requires containers/vector.ss 30 | (include "containers/sort.ss") ; requires containers/span.ss 31 | (include "containers/gbuffer.ss") ; requires containers/span.ss 32 | (include "containers/utf8b.ss") ; requires containers/bytespan.ss 33 | (include "containers/macros.ss") 34 | (include "containers/containers.ss") 35 | (include "containers/replacements.ss") 36 | 37 | (include "conversions/unicode.ss") 38 | (include "conversions/conversions.ss") 39 | 40 | (include "wire/wire.ss") 41 | 42 | (include "posix/fd.ss") 43 | (include "posix/dir.ss") 44 | (include "posix/io.ss") 45 | (include "posix/pattern.ss") 46 | (include "posix/signal.ss") 47 | (include "posix/socket.ss") ; requires posix/fd.ss 48 | (include "posix/status.ss") ; requires wire/wire.ss 49 | (include "posix/thread.ss") ; requires posix/signal.ss posix/status.ss 50 | (include "posix/tty.ss") 51 | (include "posix/rlimit.ss") 52 | (include "posix/replacements.ss") ; requires posix/thread.ss 53 | (include "posix/pid.ss") 54 | (include "posix/posix.ss") 55 | 56 | (include "port/http.ss") 57 | (include "port/redir.ss") 58 | (include "port/stdio.ss") 59 | (include "port/port.ss") 60 | 61 | (include "ipc/channel.ss") ; requires wire/wire.ss posix/fd.ss 62 | (meta-cond 63 | ((threaded?) (include "ipc/fifo-thread.ss")) 64 | (else (include "ipc/fifo-nothread.ss"))) 65 | (include "ipc/ipc.ss") 66 | 67 | (include "vscreen/all.ss") 68 | 69 | (include "lineedit/ansi.ss") 70 | (include "lineedit/paren.ss") 71 | (include "lineedit/parenmatcher.ss") 72 | (include "lineedit/parser.ss") 73 | (include "lineedit/lineedit.ss") 74 | (include "lineedit/all.ss") 75 | 76 | 77 | ;; library (scheme2k rnrs) exports the same bindings as (rnrs), 78 | ;; except for few bindings that are replaced with improved alternatives: 79 | ;; 80 | ;; bytevector-sint-ref bytevector-sint-set! 81 | ;; bytevector-uint-ref bytevector-uint-set! 82 | ;; file-exists? delete-file 83 | ;; get-bytevector-all get-bytevector-n get-bytevector-some 84 | ;; get-char get-datum get-line get-string-all get-string-n get-u8 85 | ;; put-bytevector put-char put-datum put-string put-u8 86 | ;; 87 | (library-reexport (scheme2k rnrs (0 9 2)) 88 | (import 89 | (except (rnrs) bytevector-sint-ref bytevector-sint-set! 90 | bytevector-uint-ref bytevector-uint-set! 91 | file-exists? delete-file 92 | get-char get-datum get-line get-string-all get-string-n 93 | put-char put-datum put-string) 94 | (scheme2k containers replacements) ;; intentionally conflicts with some R6RS and Chez Scheme functions, because it is intended to replace them. 95 | (scheme2k posix replacements))) ;; intentionally conflicts with some R6RS and Chez Scheme functions, because it is intended to replace them. 96 | 97 | 98 | 99 | ;; library (scheme2k) collects and exports *all* bindings defined by all LGPLv2+ libschemesh sub-libraries, 100 | ;; including few bindings that intentionally conflict with some R6RS and Chez Scheme functions 101 | ;; because they are intended as replacements 102 | (library-reexport (scheme2k (0 9 2)) 103 | (import 104 | (scheme2k bootstrap) 105 | (scheme2k containers) 106 | (scheme2k containers replacements) ;; intentionally conflicts with some R6RS and Chez Scheme functions, because it is intended to replace them. 107 | (scheme2k conversions) 108 | (scheme2k ipc) 109 | (scheme2k lineedit) 110 | (scheme2k port) 111 | (scheme2k posix) 112 | (scheme2k posix replacements) ;; intentionally conflicts with some R6RS and Chez Scheme functions, because it is intended to replace them. 113 | (scheme2k vscreen) 114 | (scheme2k wire))) 115 | 116 | ) ; close begin 117 | -------------------------------------------------------------------------------- /shell/parameter1.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | ;; if this file is loaded multiple times, only the first one has any effect. 11 | ;; implementation note: 12 | ;; this is done by setting the top-level symbol sh-persistent-parameters 13 | ;; only if it's not bound yet, and by retrieving its value if it's bound. 14 | 15 | 16 | (library (schemesh shell parameter1 (0 9 2)) 17 | (export 18 | sh-persistent-parameters) 19 | (import 20 | (rnrs) 21 | (only (chezscheme) define-top-level-value environment? environment-mutable? fx1+ 22 | interaction-environment logbit? procedure-arity-mask top-level-bound? top-level-value) 23 | (only (scheme2k bootstrap) eval-form sh-make-parameter sh-make-thread-parameter raise-errorf)) 24 | 25 | 26 | ;; Create and return thread parameter containing the scheme environment where to eval forms, 27 | ;; usually with (sh-eval) that calls ((sh-current-eval) form (sh-current-environment)) 28 | ;; 29 | ;; Initially set to Chez Scheme's (interaction-environment), because it's mutable 30 | ;; and contains all r6rs and chezscheme bindings. 31 | (define (make-parameter-environment) 32 | (sh-make-thread-parameter 33 | (interaction-environment) 34 | (lambda (env) 35 | (unless (environment? env) 36 | (raise-errorf 'sh-current-environment "~s is not an environment" env)) 37 | (unless (environment-mutable? env) 38 | (raise-errorf 'sh-current-environment "~s is not a mutable environment" env)) 39 | env))) 40 | 41 | 42 | ;; Create and return thread parameter containing the eval function to use. 43 | ;; Will be called as ((sh-current-eval) obj environment). 44 | ;; 45 | ;; Initially set to eval-form, an enhanced variant of Chez Scheme's eval 46 | (define (make-parameter-eval) 47 | (sh-make-thread-parameter 48 | eval-form 49 | (lambda (proc) 50 | (unless (procedure? proc) 51 | (raise-errorf 'sh-current-eval "~s is not a procedure" proc)) 52 | (unless (logbit? 2 (procedure-arity-mask proc)) 53 | (raise-errorf 'sh-current-eval "~s is not a procedure accepting 2 arguments" proc)) 54 | proc))) 55 | 56 | ;; Create and return thread parameter containing the global job corresponding to this process. 57 | ;; Jobs started with (sh-start) will be children of (sh-globals). 58 | ;; 59 | ;; May be parameterized to a different value in subshells. 60 | (define (make-parameter-globals) 61 | (sh-make-thread-parameter #f)) 62 | 63 | 64 | ;; Create and return parameter containing the global hashtable pid -> job. 65 | ;; 66 | ;; May be parameterized to a different value in subshells. 67 | (define (make-parameter-pid-table) 68 | (sh-make-parameter 69 | (make-eqv-hashtable) 70 | (lambda (htable) 71 | (unless (hashtable? htable) 72 | (raise-errorf 'sh-pid-table "~s is not a hashtable" htable)) 73 | (unless (hashtable-mutable? htable) 74 | (raise-errorf 'sh-pid-table "~s is not a mutable hashtable" htable)) 75 | (unless (eq? (hashtable-equivalence-function htable) eqv?) 76 | (raise-errorf 'sh-pid-table "~s is not an eqv hashtable" htable)) 77 | htable))) 78 | 79 | ;; Return vector #(sh-schemesh-reload-count sh-current-environment sh-current-eval sh-globals sh-pid-table) 80 | ;; 81 | ;; Carefully access symbol sh-persistent-parameters* in (interaction-environment) 82 | ;; to preserve vector across libschemesh library reloads. 83 | (define sh-persistent-parameters 84 | (let* ((params 85 | (if (top-level-bound? 'sh-persistent-parameters* (interaction-environment)) 86 | ;; retrieve existing parameters vector 87 | ((top-level-value 'sh-persistent-parameters* (interaction-environment))) 88 | ;; create a new parameters vector 89 | (vector (make-parameter-environment) 90 | (make-parameter-eval) 91 | (make-parameter-globals) 92 | (make-parameter-pid-table) 93 | 0 ; sh-schemesh-reload-count 94 | #f))) ; repl-restart? 95 | ;; create closure around parameters vector 96 | (persistent-parameters (lambda () params)) ; displayed as # 97 | (proc persistent-parameters)) ; short alias 98 | 99 | ;; always overwrite symbol sh-persistent-parameters* in (interaction-environment), 100 | ;; it should help garbage collector to discard previously loaded libschemesh library. 101 | (define-top-level-value 'sh-persistent-parameters* proc (interaction-environment)) 102 | ;; always increase by 1 sh-schemesh-reload-count 103 | (vector-set! (proc) 4 (fx1+ (vector-ref (proc) 4))) 104 | ;; define sh-persistent-parameters as the closure created around parameters vector 105 | proc)) 106 | 107 | 108 | ) ; close library 109 | -------------------------------------------------------------------------------- /wire/vector.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | ;; this file should be included only by file wire/wire.ss 11 | 12 | (define (len/vector pos obj) 13 | (let ((n (vector-length obj))) 14 | (let %len/vector ((i 0) (pos (vlen+ n (tag+ pos)))) ; n is encoded as vlen 15 | (if (and pos (fx? (fx- pos i) (fx- end n))) 36 | (values #f #f)) 37 | ((fx>=? i n) 38 | (values ret pos)) 39 | (else 40 | (let-values (((elem pos) (get/any bv pos end))) 41 | (vector-set! ret i elem) 42 | (%get/vector (fx1+ i) pos)))))) 43 | (values #f #f)))) 44 | 45 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 46 | 47 | (define (len/bytevector pos bv) 48 | (let ((n (bytevector-length bv))) 49 | (vlen+ n (tag+ pos) n))) 50 | 51 | (define (put/bytevector bv pos obj) 52 | (let* ((n (bytevector-length obj)) 53 | (end0 (put/tag bv pos tag-bytevector)) 54 | (end1 (put/vlen bv end0 n))) ; n is encoded as vlen 55 | (if end1 56 | (begin 57 | (bytevector-copy! obj 0 bv end1 n) 58 | (fx+ end1 n)) 59 | #f))) 60 | 61 | (define (get/bytevector bv pos end) 62 | (let-values (((n pos) (get/vlen bv pos end))) 63 | (if (and pos (fx<=? n (fx- end pos))) 64 | (let ((ret (make-bytevector n))) 65 | (bytevector-copy! bv pos ret 0 n) 66 | (values ret (fx+ pos n))) 67 | (values #f #f)))) 68 | 69 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 70 | 71 | (define (len/fxvector pos obj) 72 | (let ((n (fxvector-length obj))) 73 | (let %len/fxvector ((i 0) (pos (vlen+ n (tag+ pos)))) ; n is encoded as clen 74 | (if (and pos (fx? (fx- pos i) (fx- end n))) 93 | (values #f #f)) 94 | ((fx=? i n) 119 | pos) 120 | (bytevector-ieee-double-set! bv pos (flvector-ref obj i) endian)))) 121 | 122 | (define (get/flvector bv pos end) 123 | (let-values (((n pos) (get/vlen bv pos end))) 124 | (if (and pos (fx<=? (fx* n len-flonum) (fx- end pos))) 125 | (do ((ret (make-flvector n)) 126 | (i 0 (fx1+ i)) 127 | (pos pos (fx+ pos len-flonum))) 128 | ((fx>=? i n) 129 | (values ret pos)) 130 | (flvector-set! ret i (bytevector-ieee-double-ref bv pos endian))) 131 | (values #f #f)))) 132 | -------------------------------------------------------------------------------- /containers/fxvector.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | (library (scheme2k containers fxvector (0 9 2)) 11 | (export 12 | fxvector-copy! for-fxvector in-fxvector) 13 | (import 14 | (rnrs) 15 | (only (chezscheme) foreign-procedure 16 | fx1+ fx1- fxvector? fxvector-length fxvector-ref fxvector-set! 17 | import meta-cond library-exports) 18 | (only (scheme2k bootstrap) assert* forever fx<=?* generate-pretty-temporaries with-while-until)) 19 | 20 | 21 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 22 | ;;;;;;;;;;;;;;;;;;; some additional fxvector functions ;;;;;;;;;;;;;;;;;; 23 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 24 | 25 | 26 | ;; (fxvector-copy! src src-start dst dst-start n) 27 | ;; 28 | ;; Added in scheme2k 0.9.3 29 | (meta-cond 30 | ;; fxvector-copy! is defined only in Chez Scheme >= 10.2.0 31 | ((memq 'fxvector-copy! (library-exports '(chezscheme))) 32 | (import (prefix 33 | (only (chezscheme) fxvector-copy!) 34 | chez:)) 35 | (define fxvector-copy! chez:fxvector-copy!)) 36 | 37 | (else 38 | ;; fxvector is a different type, cannot reuse (vector-copy!) 39 | (define fxvector-copy! 40 | (let ((c-fxvector-copy! (foreign-procedure "c_fxvector_copy" (ptr ptr ptr ptr ptr) void))) 41 | (lambda (src src-start dst dst-start n) 42 | (case n 43 | ((3) 44 | ;; copy may overlap 45 | (let ((e0 (fxvector-ref src src-start)) 46 | (e1 (fxvector-ref src (fx1+ src-start))) 47 | (e2 (fxvector-ref src (fx+ 2 src-start)))) 48 | (fxvector-set! dst dst-start e0) 49 | (fxvector-set! dst (fx1+ dst-start) e1) 50 | (fxvector-set! dst (fx+ 2 dst-start) e2))) 51 | ((2) 52 | ;; copy may overlap 53 | (let ((e0 (fxvector-ref src src-start)) 54 | (e1 (fxvector-ref src (fx1+ src-start)))) 55 | (fxvector-set! dst dst-start e0) 56 | (fxvector-set! dst (fx1+ dst-start) e1))) 57 | ((1) 58 | (let ((e0 (fxvector-ref src src-start))) 59 | (fxvector-set! dst dst-start e0))) 60 | (else 61 | (assert* 'fxvector-copy! (fxvector? src)) 62 | (assert* 'fxvector-copy! (fxvector? dst)) 63 | (assert* 'fxvector-copy! (fx<=?* 0 src-start (fx+ src-start n) (fxvector-length src))) 64 | (assert* 'fxvector-copy! (fx<=?* 0 dst-start (fx+ dst-start n) (fxvector-length dst))) 65 | (unless (fxzero? n) 66 | (c-fxvector-copy! src src-start dst dst-start n))))))))) 67 | 68 | 69 | ;; Iterate in parallel on elements of given fxvector(s) v ..., and evaluate body ... on each element. 70 | ;; Stop iterating when the shortest fxvector is exhausted, 71 | ;; and return unspecified value. 72 | ;; 73 | ;; The implementation of body ... can call directly or indirectly functions 74 | ;; that inspect or modify the fxvector(s) elements. 75 | ;; 76 | ;; It must NOT call any function that modifies the fxvector(s) length, as for example (fxvector-truncate!) 77 | ;; 78 | ;; If no flvector is specified, behaves as (forever body ...) 79 | ;; 80 | ;; Return unspecified value. 81 | ;; 82 | ;; Added in scheme2k 0.9.3 83 | (define-syntax for-fxvector 84 | (lambda (stx) 85 | (syntax-case stx () 86 | ((_ () body ...) 87 | #'(forever body ...)) 88 | ((_ ((elem v) ...) body ...) 89 | (with-syntax (((tv ...) (generate-pretty-temporaries #'(v ...)))) 90 | #'(let ((tv v) ...) 91 | (let %for-fxvector ((i 0) (n (fxmin (fxvector-length v) ...))) 92 | (when (fx #f) if end of vector is reached. 104 | (define in-fxvector 105 | (case-lambda 106 | ((v start end step) 107 | (assert* 'in-fxvector (fx<=?* 0 start end (fxvector-length v))) 108 | (assert* 'in-fxvector (fx>=? step 0)) 109 | (lambda () 110 | (if (fx= value 0))) 24 | (else 25 | (assert* caller (boolean? value))))) 26 | 27 | 28 | ;; validate a property list of (sh-start) job options: 29 | ;; raise an exception if it contains one or more unsupported options. 30 | (define (options-validate caller options) 31 | (assert* caller (plist? options)) 32 | (for-plist ((key value options)) 33 | (option-validate caller key value))) 34 | 35 | 36 | ;; create and return property list usable for (sh-start) job options. 37 | ;; 38 | ;; options must be a list containing zero or more: 39 | ;; 40 | ;; (void) or #f followed by arbitrary value - ignored, and omitted from returned list. 41 | ;; 42 | ;; 'catch? flag - flag must be a boolean, otherwise an exception will be raised. 43 | ;; If present and flag is #t, any Scheme condition raised by starting 44 | ;; the job will be captured, and job status will be set to (list exception #) 45 | ;; 46 | ;; 'fd-close fd - fd must be an integer and >= 0, otherwise an exception will be raised. 47 | ;; If present, specified file descriptor will be closed when starting the job. 48 | ;; Useful mostly together with 'spawn? #t because the file descriptor will be closed 49 | ;; only in the subprocess. 50 | ;; 51 | ;; 'process-group-id id - id must be an integer and >= 0, otherwise an exception will be raised. 52 | ;; If present, the new process will be inserted into the corresponding 53 | ;; process group id - which must be either 0 or an already exist one. 54 | ;; 55 | ;; 'spawn? flag - flag must be a boolean, otherwise an exception will be raised. 56 | ;; If present and flag is #t, then job will be started in a subprocess. 57 | ;; By design, commands and (sh-subshell) are always started in a subprocess, 58 | ;; and for them the 'spawn option has no effect - it is enabled by default. 59 | ;; 60 | ;; Instead builtins and multijobs such as (sh-and) (sh-or) (sh-list) (sh-pipe) (sh-expr) ... 61 | ;; are usually started in the main schemesh process: this is convenient and fast, 62 | ;; but may deadlock if their file descriptors contain pipes whose other end 63 | ;; is read/written by the main schemesh process too. 64 | ;; 65 | ;; The option 'spawn? #t causes builtins and multijobs to start in a subprocess too. 66 | ;; It is slower, but has the beneficial effect that reading/writing 67 | ;; their redirected file descriptors from main schemesh process will no longer deadlock. 68 | ;; 69 | (define (sh-options options) 70 | (let ((ret '())) 71 | (for-plist ((key value options)) 72 | (when (and key (not (eq? (void) key))) 73 | (option-validate 'sh-options key value) 74 | (set! ret (cons value (cons key ret))))) 75 | (reverse! ret))) 76 | 77 | 78 | ;; return a copy of property list options without any occurrence of keys-to-remove 79 | (define (options-filter-out options keys-to-remove) 80 | (if (null? keys-to-remove) 81 | options 82 | (plist-delete/pred options (lambda (key) (memq key keys-to-remove))))) 83 | 84 | 85 | ;; if options contain 'catch? flag, return such flag. 86 | ;; otherwise return #f 87 | (define (options->catch? options) 88 | (let ((val (plist-ref options 'catch?))) 89 | (assert* 'options->catch? (boolean? val)) 90 | val)) 91 | 92 | 93 | ;; if options contain 'spawn? flag, return such flag. 94 | ;; otherwise return #f 95 | (define (options->spawn? options) 96 | (let ((val (plist-ref options 'spawn?))) 97 | (assert* 'options->spawn? (boolean? val)) 98 | val)) 99 | 100 | 101 | ;; if job control is active and options contain 'process-group-id id, return such id. 102 | ;; otherwise return #f 103 | (define (options->process-group-id options) 104 | (if (sh-job-control?) 105 | (let ((val (plist-ref options 'process-group-id))) 106 | (if val 107 | (let ((caller 'options->process-group-id)) 108 | (assert* caller (integer? val)) 109 | (assert* caller (>= val 0)) 110 | val) 111 | 0)) ; default: create a new process group 112 | 113 | ; if job control is inactive, as for example in a subshell, 114 | ; ignore requests to move a process into a specific process group id 115 | ; or to create a new process group id 116 | #f)) 117 | 118 | 119 | ;; for each option 'fd-close fd in options, call (fd-close fd) 120 | ;; return unspecified value 121 | (define (options->call-fd-close options) 122 | (for-plist ((key val options)) 123 | (when (eq? 'fd-close key) 124 | (fd-close val)))) 125 | -------------------------------------------------------------------------------- /test/test.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | (library (schemesh test (0 9 2)) 11 | (export 12 | run-tests) 13 | (import 14 | (except (rnrs) bytevector-sint-ref bytevector-sint-set! 15 | bytevector-uint-ref bytevector-uint-set! 16 | file-exists? delete-file 17 | get-bytevector-all get-bytevector-n get-bytevector-some 18 | get-char get-datum get-line get-string-all get-string-n get-u8 19 | put-bytevector put-char put-datum put-string put-u8) 20 | (rnrs base) 21 | (rnrs exceptions) 22 | (only (rnrs mutable-strings) string-set!) 23 | (only (chezscheme) console-output-port display-condition format fx1+ fx1- fx/) 24 | (schemesh)) 25 | 26 | 27 | (define (run-tests file-path) 28 | (status-display-color? #f) 29 | (let* ((tests (sh-read-file file-path)) 30 | (vec-n (vector-length tests)) 31 | (test-n (fx1+ (fx/ vec-n 2))) ; also count (run-tests-utf8b) 32 | (fail-n 0)) 33 | 34 | (do ((i 0 (fx+ i 2))) 35 | ((fx>=? i vec-n)) 36 | (unless (run-test (vector-ref tests i) (vector-ref tests (fx1+ i))) 37 | (set! fail-n (fx1+ fail-n)))) 38 | 39 | (unless (run-tests-utf8b) 40 | (set! fail-n (fx1+ fail-n))) 41 | 42 | (flush-output-port (current-output-port)) 43 | (flush-output-port (current-error-port)) 44 | 45 | (cons test-n fail-n))) 46 | 47 | 48 | (define (run-test form expected-result) 49 | ;; (format #t "test: ~s\n" form) 50 | (call/cc 51 | (lambda (return) 52 | (let-values (((comparison exp-result) (parse-expected-result expected-result))) 53 | (with-exception-handler 54 | (lambda (ex) 55 | (let-values (((port get-string) (open-string-output-port))) 56 | (display-condition ex port) 57 | (format #t "test failed:\n Scheme code ~s\n exception ~a\n expecting ~s\n" 58 | form (get-string) exp-result)) 59 | (return #f)) 60 | (lambda () 61 | (test-ok? comparison form exp-result))))))) 62 | 63 | 64 | (define (parse-expected-result expected-result) 65 | (cond 66 | ((and (pair? expected-result) (eq? 'unquote (car expected-result))) 67 | (values 'format-s (cadr expected-result))) 68 | ((and (pair? expected-result) (eq? 'unquote-splicing (car expected-result))) 69 | (values 'format-a (cadr expected-result))) 70 | (else 71 | (values 'equal expected-result)))) 72 | 73 | 74 | (define (test-ok? comparison form exp-result) 75 | (let* ((result (sh-eval form)) 76 | (comparable-result (test->comparable comparison result)) 77 | (comparable-exp-result (test->comparable comparison exp-result)) 78 | (same? (comparable-equal? comparison comparable-result comparable-exp-result))) 79 | (unless same? 80 | (if (eq? 'format-s comparison) 81 | (format #t "test failed:\n Scheme code ~s\n evaluated to ~a\n expecting ~a\n" 82 | form comparable-result comparable-exp-result) 83 | (format #t "test failed:\n Scheme code ~s\n evaluated to ~s\n expecting ~s\n" 84 | form comparable-result comparable-exp-result))) 85 | same?)) 86 | 87 | 88 | (define (test->comparable comparison result) 89 | (case comparison 90 | ((format-s) 91 | (format #f "~s" result)) 92 | ((format-a) 93 | (format #f "~a" result)) 94 | (else 95 | result))) 96 | 97 | 98 | (define (comparable-equal? comparison comparable-result comparable-exp-result) 99 | (case comparison 100 | ((format-s format-a) 101 | (string=? comparable-result comparable-exp-result)) 102 | (else 103 | (equal? comparable-result comparable-exp-result)))) 104 | 105 | 106 | (define (run-tests-utf8b) 107 | (let* ((maxlen 1024) 108 | (s (make-string maxlen)) 109 | (good? #t)) 110 | (do ((i 0 (fx+ i maxlen))) 111 | ((fx>? i #x10FFFF) good?) 112 | (unless (run-test-utf8b s i) 113 | (set! good? #f))))) 114 | 115 | 116 | (define (run-test-utf8b s first-codepoint) 117 | (let ((maxlen (string-length s)) 118 | (codepoint first-codepoint)) 119 | 120 | (do ((pos 0 (fx1+ pos))) 121 | ((fx>=? pos maxlen)) 122 | (set! codepoint (adjust-codepoint codepoint)) 123 | (string-set! s pos (integer->char* codepoint)) 124 | (set! codepoint (fx1+ codepoint))) 125 | 126 | (let ((s2 (utf8b->string (string->utf8b s)))) 127 | (do ((pos 0 (fx1+ pos))) 128 | ((or (fx>=? pos maxlen) 129 | (not (compare-chars (string-ref s pos) (string-ref s2 pos)))) 130 | (fx>=? pos maxlen)))))) 131 | 132 | (define (adjust-codepoint codepoint) 133 | (cond 134 | ((fx<=? #xD800 codepoint #xDC80) 135 | #xDC80) 136 | ((fx<=? #xDD00 codepoint #xE000) 137 | #xE000) 138 | ((fx>=? codepoint #x110000) 139 | 0) 140 | (else 141 | codepoint))) 142 | 143 | (define (compare-chars ch1 ch2) 144 | (if (char=? ch1 ch2) 145 | #t 146 | (begin 147 | (format (console-output-port) 148 | "test failed:\n (utf8b->string (string->utf8b ...)) \n evaluated to U+0x~x\n expecting U+0x~x\n" 149 | (char->integer ch1) (char->integer ch2)) 150 | #f))) 151 | 152 | ) ; close library 153 | -------------------------------------------------------------------------------- /test/test.c: -------------------------------------------------------------------------------- 1 | /** 2 | * Copyright (C) 2023-2025 by Massimiliano Ghilardi 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU General Public License as published by 6 | * the Free Software Foundation; either version 2 of the License, or 7 | * (at your option) any later version. 8 | */ 9 | 10 | #include "../containers/containers.h" /* scheme2k_Sstring_utf8b() */ 11 | #include "../eval.h" 12 | #include "../load.h" 13 | #include "../posix/posix.h" 14 | 15 | #include 16 | #include 17 | #include 18 | #include 19 | #include /* chdir() */ 20 | 21 | #if !defined(__GNUC__) || defined(__OPTIMIZE__) 22 | #define SCHEME_OPTIMIZE 23 | #else 24 | #undef SCHEME_OPTIMIZE 25 | #endif 26 | 27 | #define LIBSCHEME2K_SO "libscheme2k_0.9.2.so" 28 | 29 | #define N_OF(array) (sizeof(array) / sizeof((array)[0])) 30 | 31 | static void run_scheme_tests(unsigned long* run_n, unsigned long* failed_n, const char* test_file) { 32 | 33 | ptr ret = scheme2k_call1("run-tests", scheme2k_Sstring_utf8b(test_file, -1)); 34 | 35 | if (Spairp(ret) && Sfixnump(Scar(ret)) && Sfixnump(Scdr(ret))) { 36 | *run_n += Sfixnum_value(Scar(ret)); 37 | *failed_n += Sfixnum_value(Scdr(ret)); 38 | } else { 39 | *run_n += 1; 40 | *failed_n += 1; 41 | } 42 | } 43 | 44 | static int run_all_tests(void) { 45 | const char* test_files[] = {"test/data0.ss", "test/data1.ss", "test/data2.ss", "test/data3.ss"}; 46 | unsigned long run_n = 0; 47 | unsigned long failed_n = 0; 48 | 49 | fprintf(stdout, "%s", "running tests ...\n"); 50 | fflush(stdout); 51 | 52 | scheme2k_call1("load", scheme2k_Sstring_utf8b("test/test.ss", -1)); 53 | scheme2k_eval("(import (schemesh test))"); 54 | 55 | for (unsigned i = 0; i < N_OF(test_files); i++) { 56 | run_scheme_tests(&run_n, &failed_n, test_files[i]); 57 | } 58 | 59 | if (failed_n == 0) { 60 | fprintf(stdout, "all %lu tests passed\n", run_n); 61 | } else { 62 | fprintf(stdout, "%lu tests failed out of %lu\n", failed_n, run_n); 63 | } 64 | fflush(stdout); 65 | return failed_n == 0 ? 0 : 1; 66 | } 67 | 68 | static void handle_scheme_exception(void) { 69 | (void)write(1, "schemesh_test failed: exception evaluating Scheme code!\n", 56); 70 | exit(1); 71 | } 72 | 73 | /** 74 | * compile libschemesh_VERSION.so from sources found in specified directory. 75 | * 76 | * return 0 if successful, otherwise error code. 77 | */ 78 | static int compile_schemesh_so(const char* source_dir) { 79 | ptr ret; 80 | int err; 81 | if (source_dir == NULL) { 82 | fprintf(stderr, "%s", "schemesh_test: source_dir is null\n"); 83 | return EINVAL; 84 | } 85 | if (chdir(source_dir) != 0) { 86 | err = errno; 87 | fprintf(stderr, 88 | "schemesh_test: C function chdir(\"%s\") failed with error %d: %s\n", 89 | source_dir, 90 | err, 91 | strerror(err)); 92 | return err; 93 | } 94 | #ifdef SCHEME_OPTIMIZE 95 | ret = 96 | scheme2k_eval("(parameterize ((optimize-level 2))\n" 97 | " (compile-file \"libschemesh.ss\" \"libschemesh_temp.so\")\n" 98 | " (strip-fasl-file \"libschemesh_temp.so\" \"" LIBSCHEMESH_SO "\"\n" 99 | " (fasl-strip-options inspector-source source-annotations profile-source))\n" 100 | " #t\n)"); 101 | #else /* !SCHEME_OPTIMIZE */ 102 | ret = scheme2k_eval("(parameterize ((optimize-level 0)\n" 103 | " (run-cp0 (lambda (cp0 x) x)))\n" 104 | " (compile-file \"libschemesh.ss\" \"" LIBSCHEMESH_SO "\")\n" 105 | " #t)"); 106 | #endif 107 | return ret == Strue ? 0 : EINVAL; 108 | } 109 | 110 | /** 111 | * compile libscheme2k_VERSION.so from sources found in specified directory. 112 | * 113 | * return 0 if successful, otherwise error code. 114 | */ 115 | static int compile_scheme2k_so(const char* source_dir) { 116 | ptr ret; 117 | int err; 118 | if (source_dir == NULL) { 119 | fprintf(stderr, "%s", "schemesh_test: source_dir is null\n"); 120 | return EINVAL; 121 | } 122 | if (chdir(source_dir) != 0) { 123 | err = errno; 124 | fprintf(stderr, 125 | "schemesh_test: C function chdir(\"%s\") failed with error %d: %s\n", 126 | source_dir, 127 | err, 128 | strerror(err)); 129 | return err; 130 | } 131 | #ifdef SCHEME_OPTIMIZE 132 | ret = 133 | scheme2k_eval("(parameterize ((optimize-level 2))\n" 134 | " (compile-file \"libscheme2k.ss\" \"libscheme2k_temp.so\")\n" 135 | " (strip-fasl-file \"libscheme2k_temp.so\" \"" LIBSCHEME2K_SO "\"\n" 136 | " (fasl-strip-options inspector-source source-annotations profile-source))\n" 137 | " #t\n)"); 138 | #else /* !SCHEME_OPTIMIZE */ 139 | ret = scheme2k_eval("(parameterize ((optimize-level 0)\n" 140 | " (run-cp0 (lambda (cp0 x) x)))\n" 141 | " (compile-file \"libscheme2k.ss\" \"" LIBSCHEME2K_SO "\")\n" 142 | " #t)"); 143 | #endif 144 | return ret == Strue ? 0 : EINVAL; 145 | } 146 | 147 | int main(int argc, const char* argv[]) { 148 | int err = 0; 149 | 150 | scheme2k_init(NULL, &handle_scheme_exception); 151 | 152 | if (argc == 2 && strcmp(argv[1], "--compile_scheme2k_so") == 0) { 153 | err = compile_scheme2k_so("."); 154 | } else { 155 | if (scheme2k_register_c_functions() == 0 && /* */ 156 | compile_schemesh_so(".") == 0 && /* */ 157 | scheme2k_load_library(".", LIBSCHEMESH_SO) == 0) { 158 | 159 | schemesh_import_all_libraries(); 160 | 161 | (void)run_all_tests(); 162 | } 163 | } 164 | scheme2k_quit(); 165 | 166 | return err; 167 | } 168 | -------------------------------------------------------------------------------- /vscreen/vhistory.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | ;; this file should be included only by file vscreen/all.ss 11 | 12 | 13 | ;; type vhistory is a gbuffer containing vlines elements (the history itself) 14 | (define-record-type (%vhistory %make-vhistory vhistory?) 15 | (parent %gbuffer) 16 | (fields 17 | (mutable path vhistory-path %vhistory-path-set!)) ; #f or string path where to load/save history 18 | (nongenerative %vhistory-7c46d04b-34f4-4046-b5c7-b63753c1be39)) 19 | 20 | 21 | (define (vhistory . vals) 22 | (for-list ((val vals)) (assert-vlines? 'vhistory val)) 23 | (%make-vhistory (span) (list->span vals) #f)) 24 | 25 | 26 | (define (make-vhistory n) 27 | ; optimization: (vhistory-ref/cow) returns a copy-on-write clone of i-th vline, 28 | ; thus we can reuse the same empty (vlines) for all elements 29 | (%make-vhistory (span) (make-span n (vlines)) #f)) 30 | 31 | 32 | (define (vhistory-path-set! hist path) 33 | (when (and path (not (string? path))) 34 | (raise-assertf 'vhistory-path-set! "~s is not #f or string" path)) 35 | (%vhistory-path-set! hist path)) 36 | 37 | 38 | (define vhistory-empty? gbuffer-empty?) 39 | (define vhistory-length gbuffer-length) 40 | (define vhistory-clear! gbuffer-clear!) 41 | 42 | ;; iterate on vhistory lines, and call (proc i lines) on each one. 43 | ;; Stops iterating if (proc ...) returns #f. 44 | ;; 45 | ;; Returns #t if all calls to (proc i lines) returned truish, 46 | ;; otherwise returns #f. 47 | ;; 48 | ;; The implementation of (proc ...) can call directly or indirectly functions 49 | ;; that inspect the vhistory without modifying it, 50 | ;; and can also inspect lines. 51 | ;; 52 | ;; It must NOT call any function that modifies the lines or vhistory 53 | ;; (set elements, insert or erase elements, change the size or capacity, etc). 54 | (define vhistory-iterate gbuffer-iterate) 55 | 56 | ;; return a copy-on-write clone of i-th vlines in history 57 | (define (vhistory-ref/cow hist idx) 58 | (vlines-copy-on-write (gbuffer-ref hist idx))) 59 | 60 | 61 | ;; if i is in range, set i-th vlines in history to a shallow copy of lines. 62 | ;; otherwise append shallow copy of lines to history. 63 | ;; do NOT insert lines in history if they are equal to another vlines at a nearby index. 64 | ;; returns two values: 65 | ;; the inserted shallow copy of lines - or the existing lines that prevented insertion 66 | ;; the index where lines were actually stored - or the index of existing lines that prevented insertion 67 | (define (vhistory-set*! hist idx lines) 68 | (assert-vlines? 'vhistory-set*! lines) 69 | (let* ((len (gbuffer-length hist)) 70 | (idx-clamp (fxmax 0 (fxmin idx len))) 71 | (idx-eq (%vlines-find-nearby hist idx-clamp lines)) 72 | (idx (or idx-eq idx-clamp)) 73 | (lines (if idx-eq 74 | (gbuffer-ref hist idx-eq) 75 | ; make a shallow copy of lines. Also helps in case lines is not 76 | ; a vlines but a subclass of it, for example a vscreen 77 | (vlines-shallow-copy lines)))) 78 | (unless idx-eq 79 | (if (fx>=? idx len) 80 | (gbuffer-insert-at! hist idx lines) 81 | (gbuffer-set! hist idx lines))) 82 | (values lines idx))) 83 | 84 | 85 | ;; remove empty vlines before index idx in vhistory. 86 | ;; stop as soon as a non-empty vlines is found. 87 | (define (vhistory-delete-empty-lines! hist idx) 88 | (let ((i (fx1- (fxmin idx (vhistory-length hist))))) 89 | (while (and (fx>=? i 0) (%vlines-empty? (gbuffer-ref hist i))) 90 | (gbuffer-delete! hist i (fx1+ i)) 91 | (set! i (fx1- i))) 92 | i)) 93 | 94 | 95 | (define (%vlines-empty? lines) 96 | (or (vlines-empty? lines) 97 | (and (fx=? 1 (vlines-length lines)) 98 | (vline-empty? (vlines-ref lines 0))))) 99 | 100 | 101 | ;; search for vlines equal to lines 102 | ;; at vhistory indexes (fx1- idx) idx (fx1+ idx) 103 | ;; 104 | ;; return index of equal vlines if found, 105 | ;; otherwise return #f 106 | (define (%vlines-find-nearby hist idx lines) 107 | (let* ((len (gbuffer-length hist)) 108 | (start (fxmax 0 (fx1- idx))) 109 | (end (fxmin len (fx+ 2 idx))) 110 | (ret #f)) 111 | (do ((i start (fx1+ i))) 112 | ((or ret (fx>=? i end)) ret) 113 | (when (vlines-equal/chars? (gbuffer-ref hist i) lines) 114 | (set! ret i))))) 115 | 116 | ;; search for first vlines in range [start, end) that begins with same characters 117 | ;; as the range [0 0, prefix-x prefix-y) of prefix-lines. 118 | ;; 119 | ;; return index of such vlines if found, 120 | ;; otherwise return #f 121 | (define (vhistory-index/starts-with hist start end prefix-lines prefix-x prefix-y) 122 | (let ((start (fxmax 0 start)) 123 | (end (fxmin end (vhistory-length hist)))) 124 | (do ((i start (fx1+ i))) 125 | ((or (fx>=? i end) (vlines-starts-with? (gbuffer-ref hist i) prefix-lines prefix-x prefix-y)) 126 | (if (fx=? i start) i #f))))) 140 | -------------------------------------------------------------------------------- /ipc/fifo-nothread.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | ;;; inter-thread communication library: 11 | ;;; 12 | ;;; exchanges arbitrary objects through thread-safe FIFO 13 | ;;; 14 | (library (scheme2k ipc fifo (0 9 2)) 15 | (export make-producer producer? producer-close producer-name producer-put 16 | make-consumer consumer? consumer-get consumer-eof? consumer-timed-get consumer-try-get in-consumer) 17 | (import 18 | (rnrs) 19 | (rnrs mutable-pairs) 20 | (only (chezscheme) include make-time record-writer time? time-type time-second time-nanosecond) 21 | (only (scheme2k bootstrap) assert* check-interrupts raise-errorf) 22 | (only (scheme2k posix signal) countdown)) 23 | 24 | 25 | (include "ipc/fifo-common.ss") 26 | 27 | ;; create and return a producer. 28 | (define make-producer 29 | (case-lambda 30 | (() 31 | (make-producer #f)) 32 | ((name) 33 | (%make-producer (cons #f '()) name #f)))) 34 | 35 | 36 | (define (producer-name p) 37 | (producer-mutex p)) 38 | 39 | 40 | ;; Close specified producer. 41 | ;; Notifies all attached consumers that no more data can be received. 42 | ;; Each attached consumer will still receive any pending data. 43 | ;; 44 | ;; This procedure is for non-threaded build of Chez Scheme. 45 | (define (producer-close p) 46 | (set-cdr! (producer-tail p) #f)) 47 | 48 | 49 | ;; put a datum into the producer, which will be visible to all 50 | ;; consumers attached *before* this call to (producer-put). 51 | ;; 52 | ;; raises exception if producer is closed 53 | ;; 54 | ;; This procedure is for non-threaded build of Chez Scheme. 55 | (define (producer-put p obj) 56 | (let ((old-tail (producer-tail p))) 57 | (unless (null? (cdr old-tail)) 58 | (raise-errorf 'producer-put "~s is already closed" p)) 59 | (set-car! old-tail obj) 60 | (let ((new-tail (cons #f '()))) 61 | (set-cdr! old-tail new-tail) 62 | (producer-tail-set! p new-tail)))) 63 | 64 | 65 | 66 | 67 | 68 | ;; create a consumer attached to specified producer, and return it. 69 | ;; multiple consumers can be attached to the same producer, and each consumer 70 | ;; receives in order all data put to the producer *after* the consumer was created. 71 | ;; 72 | ;; This procedure is for non-threaded build of Chez Scheme. 73 | (define (make-consumer p) 74 | (%make-consumer (producer-tail p) #f (producer-mutex p) (producer-changed p))) 75 | 76 | 77 | (define (consumer-name c) 78 | (consumer-mutex c)) 79 | 80 | (define huge-timeout (* 86400 365)) 81 | 82 | (define (consumer-timed-get-once c timeout) 83 | (check-interrupts) 84 | (let* ((head (consumer-head c)) 85 | (tail (cdr head))) 86 | (cond 87 | ((not tail) 88 | (consumer-eof?-set! c #t) 89 | (values #f 'eof)) 90 | ((null? tail) 91 | (if (eqv? 0 timeout) 92 | (values #f 'timeout) 93 | (begin 94 | (countdown timeout) 95 | (consumer-timed-get-once c 0)))) 96 | ((pair? tail) 97 | (consumer-head-set! c tail) 98 | (values (car head) 'ok))))) 99 | 100 | 101 | ;; block until a datum is received from producer, and return two values: 102 | ;; datum and #t 103 | ;; or and #f if producer has been closed and all data has been received. 104 | ;; 105 | ;; This procedure is for non-threaded build of Chez Scheme. 106 | (define (consumer-get c) 107 | (if (consumer-eof? c) 108 | (values #f #f) 109 | (let %consumer-get ((c c)) 110 | (let-values (((datum flag) (consumer-timed-get-once c huge-timeout))) 111 | (if (eq? flag 'timeout) 112 | (%consumer-get c) 113 | (values datum (eq? flag 'ok))))))) 114 | 115 | 116 | ;; block with timeout until a datum is received from producer, and return two values: 117 | ;; received datum and 'ok 118 | ;; or and 'eof if producer has been closed and all data has been received 119 | ;; or and 'timeout on timeout 120 | ;; 121 | ;; timeout must be one of: 122 | ;; * an exact or inexact real, indicating the number of seconds (non-integer values are supported too) 123 | ;; * a pair (seconds . nanoseconds) where both are exact integers 124 | ;; * a time object with type 'time-duration 125 | ;; 126 | ;; This procedure is for non-threaded build of Chez Scheme. 127 | (define (consumer-timed-get c timeout) 128 | (if (consumer-eof? c) 129 | (values #f 'eof) 130 | (consumer-timed-get-once c timeout))) 131 | 132 | 133 | ;; non-blockingly try to receive a datum from producer, and return two values: 134 | ;; received datum and 'ok 135 | ;; or and 'eof if producer has been closed and all data has been received 136 | ;; or and 'timeout on timeout 137 | ;; 138 | ;; This procedure is for non-threaded build of Chez Scheme. 139 | (define (consumer-try-get c) 140 | (if (consumer-eof? c) 141 | (values #f 'eof) 142 | (consumer-timed-get-once c 0))) 143 | 144 | 145 | ;; customize how "producer" objects are printed 146 | (record-writer (record-type-descriptor producer) 147 | (lambda (p port writer) 148 | (let ((name (producer-name p))) 149 | (if name 150 | (begin 151 | (display "#" port)) 154 | (display "#" port))))) 155 | 156 | 157 | ;; customize how "consumer" objects are printed 158 | (record-writer (record-type-descriptor consumer) 159 | (lambda (c port writer) 160 | (let ((name (consumer-name c))) 161 | (if name 162 | (begin 163 | (display "#" port)) 166 | (display "#" port))))) 167 | 168 | 169 | ) ; close library 170 | -------------------------------------------------------------------------------- /doc/posix/dir.md: -------------------------------------------------------------------------------- 1 | # posix dir 2 | 3 | The library `(scheme2k posix dir)`, which is also included in `(scheme2k posix)` and `(schemesh)`, 4 | provides low-level functions to access POSIX filesystem. 5 | 6 | Additional functions are also provided by `(scheme2k posix replacements)`, see [replacements.md](replacements.md). 7 | 8 | ### Alphabetical index 9 | 10 | * [`(directory-list)`](#directory-list) 11 | * [`(directory-list-type)`](#directory-list-type) 12 | * [`(directory-sort!)`](#directory-sort!) 13 | * [`(file-delete)`](#file-delete) 14 | * [`(file-rename)`](#file-rename) 15 | * [`(file-type)`](#file-type) 16 | * [`(mkdir)`](#mkdir) 17 | 18 | ### Functions 19 | 20 | ##### (directory-list) 21 | `(directory-list dirpath [options])` returns a list of names present in a filesystem directory, in arbitrary order.
22 | WARNING: Chez Scheme also defines a function `(directory-list)` with different options.
23 | Argument `dirpath` must be a bytevector, string, bytespan or charspan.
24 | Optional argument `options` must be a list containing zero or more of: 25 | * `'append-slash` - if a returned name corresponds to a directory, then a '/' will be appended to its name 26 | * `'bytes` - each returned name will be a bytevector, not a string 27 | * `'catch` - errors will be ignored instead of raising a condition 28 | * `'prefix` followed by a charspan, string or bytevector, indicating the filter-prefix: only names that start with such filter-prefix will be returned 29 | * `'suffix` followed by a charspan, string or bytevector, indicating the filter-suffix: only names that end with such filter-suffix will be returned 30 | * `'symlinks` - only meaningful together with `'types`: returned names that are symlinks will have type `'symlink` instead of the type of the file they point to 31 | * `'types` - each returned list element will be a pair `(name . type)` where `name` is a bytevector or string, and `type` is a symbol, one of: 32 | `'unknown` `'blockdev` `'chardev` `'dir` `'fifo` `'file` `'socket` `'symlink`. 33 | The type `'symlink` can be returned only if option `'symlinks` is present. 34 | 35 | ##### (directory-list-type) 36 | `(directory-list-type dirpath [options])` returns a list of names present in a filesystem directory, in arbitrary order, and their types. 37 | Equivalent to `(directory-list dirpath [options])` with the difference that option `'types` is added automatically. 38 | 39 | ##### (directory-sort!) 40 | `(directory-sort! dir-list)` in-place alphabetically sorts a list returned by `(directory-list)` or `(directory-list-type)`. 41 | Returns the modified list. 42 | 43 | ##### (file-delete) 44 | `(file-delete path [options])` deletes a file or an empty directory.
45 | Argument `path` must be a bytevector, string or charspan.
46 | Optional argument `options` must be a list containing zero or more: 47 | * `'catch` - on error, return numeric c-errno instead of raising a condition 48 | 49 | On success, returns `(void)`.
50 | On error, either returns an integer error code (if `options` contain `'catch`) or raises an exception. 51 | 52 | Improvements compared to Chez Scheme `(delete-file)`: 53 | * also deletes empty directories. 54 | * also accepts bytevectors, bytespans or charspans, not only strings. 55 | * strings and charspans are converted to posix paths with UTF-8b instead of UTF-8 - the former can also represent invalid UTF-8 sequences. 56 | * returns `(void)` on success and error code on failure, instead of a boolean. 57 | 58 | ##### (file-rename) 59 | `(file-rename old-path new-path [options])` moves or renames a file or directory from `old-path` to `new-path`.
60 | Both arguments `old-path` and `new-path` must be a bytevector, string or charspan.
61 | Optional argument `options` must be a list containing zero or more: 62 | * `'catch` - on error, return numeric c-errno instead of raising a condition. 63 | 64 | On success, returns `(void)`.
65 | On error, either returns an integer error code (if `options` contain `'catch`) or raises an exception. 66 | 67 | Improvements compared to Chez Scheme `(rename-file)`: 68 | * also accepts bytevectors, bytespans and charspans, not only strings. 69 | * strings and charspans are converted to posix paths with UTF-8b instead of UTF-8 - the former can also represent invalid UTF-8 sequences. 70 | * returns `(void)` on success and error code on failure, instead of an unspecified value. 71 | 72 | ##### (file-type) 73 | `(file-type path [options])` checks existence and type of a filesystem path.
74 | Argument `path` must be a bytevector, string, bytespan or charspan.
75 | Optional argument `options` must be a list containing zero or more: 76 | * `'catch` - on error, return numeric c-errno instead of raising a condition. 77 | * `'symlinks` - if path is a symlink, returned value will be `'symlink` instead of the type of the file it points to. 78 | 79 | If `path` exists, returns its type which as one the symbols: 80 | `'unknown` `'blockdev` `'chardev` `'dir` `'fifo` `'file` `'socket` `'symlink`. 81 | The type `'symlink` can be returned only if option `'symlinks` is present. 82 | 83 | If `path` does not exists, returns `#f`. 84 | 85 | 86 | ##### (mkdir) 87 | `(mkdir dirpath [options])` creates a directory.
88 | WARNING: Chez Scheme also defines a function (mkdir) with different options.
89 | Argument `dirpath` must be a bytevector, string or charspan.
90 | Optional argument `options` must be a list containing zero or more: 91 | * `'catch` - on error, return numeric c-errno instead of raising a condition. 92 | * `'mode` followed by a fixnum - specifies the owner, group and others initial permissions on the directory - see POSIX "man 2 mkdir" for details. 93 | 94 | On success, returns `(void)`.
95 | On error, either returns an integer error code (if `options` contain `'catch`) or raises an exception. 96 | 97 | Improvements compared to Chez Scheme `(mkdir)`: 98 | * also accepts bytevectors, bytespans and charspans, not only strings. 99 | * strings and charspans are converted to posix paths with UTF-8b instead of UTF-8 - the former can also represent invalid UTF-8 sequences. 100 | * returns `(void)` on success and error code on failure, instead of an unspecified value. 101 | 102 | 103 | -------------------------------------------------------------------------------- /shell/aliases.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This program is free software; you can redistribute it and/or modify 4 | ;;; it under the terms of the GNU General Public License as published by 5 | ;;; the Free Software Foundation; either version 2 of the License, or 6 | ;;; (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | ;; this file should be included only by file job.ss 11 | 12 | 13 | ;; find and return the definition of specified alias name, 14 | ;; or #f if not found 15 | (define (sh-alias-ref name) 16 | (hashtable-ref (sh-aliases) name #f)) 17 | 18 | 19 | ;; given a command line prog-and-args i.e. a list of strings, 20 | ;; extract the first string and expand the corresponding alias. 21 | ;; Return the list of strings produced by alias expansion. 22 | ;; Return the unmodified prog-and-args if no corresponding alias is found. 23 | ;; 24 | ;; Note: aliases are expanded recursively, i.e. if the expansion produced by an alias 25 | ;; starts with an alias name, it is expanded again. 26 | ;; To avoid infinite recursion, each alias name is only expanded at most once. 27 | ;; 28 | ;; Note: for sanity, (sh-aliases-expand) ignores aliases for "builtin" 29 | (define (sh-aliases-expand prog-and-args) 30 | (assert-string-list? 'sh-aliases-expand prog-and-args) 31 | (aliases-expand prog-and-args '("builtin"))) ; suppress alias expansion for "builtin" 32 | 33 | 34 | (define (aliases-expand prog-and-args suppressed-name-list) 35 | (if (null? prog-and-args) 36 | prog-and-args 37 | (let* ((name (car prog-and-args)) 38 | (alias (sh-alias-ref name))) 39 | ;; try to recursively expand output of alias expansion, 40 | ;; but suppress expansion of already-expanded names 41 | (if (and alias (not (member name suppressed-name-list))) 42 | (let ((expanded (append alias (cdr prog-and-args)))) 43 | (alias-validate 'sh-aliases-expand name alias) 44 | (aliases-expand expanded (cons name suppressed-name-list))) 45 | 46 | ;; name is not an alias, or is in suppressed-name-list: 47 | ;; stop recursion, just return prog-and-args 48 | prog-and-args)))) 49 | 50 | 51 | (define (alias-validate caller name alias) 52 | (assert-string-list? caller alias)) 53 | 54 | 55 | ;; add an alias to (sh-aliases) table. 56 | ;; name must be a string; alias must be a list of strings. 57 | ;; command line (cons name args) will be expanded to (append alias args) 58 | ;; 59 | ;; do NOT modify alias after calling this function. 60 | (define (sh-alias-set! name alias) 61 | (alias-validate 'sh-alias-set! name alias) 62 | (when (hashtable-ref (sh-builtins) name #f) 63 | (write-builtin-warning 64 | (string-append "\"" name 65 | "\" is a builtin. defining an alias with the same name is allowed, but probably confusing"))) 66 | (hashtable-set! (sh-aliases) name alias)) 67 | 68 | 69 | ;; remove an alias from (sh-aliases) table. 70 | (define (sh-alias-delete! name) 71 | (hashtable-delete! (sh-aliases) name)) 72 | 73 | 74 | ;; the "alias" builtin: show all aliases, or show a single alias, or set an alias. 75 | ;; 76 | ;; As all builtins do, must return job status. 77 | (define (builtin-alias job prog-and-args options) 78 | ; (debugf "builtin-alias ~s" prog-and-args) 79 | (assert-string-list? 'builtin-alias prog-and-args) 80 | (cond 81 | ((or (null? prog-and-args) (null? (cdr prog-and-args))) 82 | (show-aliases)) 83 | ((null? (cddr prog-and-args)) 84 | (show-alias (cadr prog-and-args))) 85 | (else 86 | (sh-alias-set! (cadr prog-and-args) (cddr prog-and-args)) 87 | (void)))) 88 | 89 | 90 | ;; the "unalias" builtin: unset zero or more aliases. 91 | ;; 92 | ;; As all builtins do, must return job status. 93 | (define (builtin-unalias job prog-and-args options) 94 | (assert-string-list? 'builtin-unalias prog-and-args) 95 | (do ((tail (cdr prog-and-args) (cdr tail))) 96 | ((null? tail) (void)) 97 | (sh-alias-delete! (car tail)))) 98 | 99 | 100 | ;; function returning the global hashtable name -> alias 101 | ;; Each alias is a function args -> prog-and-args 102 | ;; i.e. it must accept a list of strings and return a list of strings 103 | (define sh-aliases 104 | (let ((ht (make-hashtable string-hash string=?))) 105 | ; initial aliases 106 | (hashtable-set! ht "ls" '("ls" "--color=auto")) 107 | (hashtable-set! ht "l" '("ls" "-al")) 108 | (hashtable-set! ht "v" '("ls" "-l")) 109 | (lambda () ht))) 110 | 111 | 112 | 113 | (define (show-aliases) 114 | (let ((wbuf (make-bytespan 0)) 115 | (aliases (span)) 116 | (fd (sh-fd 1))) 117 | (for-hash-pairs ((cell (sh-aliases))) 118 | (span-insert-right! aliases cell)) 119 | (span-sort! (lambda (cell1 cell2) (string=? (bytespan-length wbuf) 4096) 124 | (fd-write/bytespan! fd wbuf)))) 125 | (fd-write/bytespan! fd wbuf) 126 | (void))) ; return (void), means builtin finished, successfully 127 | 128 | 129 | (define (show-alias name) 130 | (let ((alias (sh-alias-ref name))) 131 | (if alias 132 | (let ((wbuf (make-bytespan 0))) 133 | (show-alias* name alias wbuf) 134 | (fd-write/bytespan! (sh-fd 1) wbuf) 135 | (void)) ; success, return (void) 136 | (write-builtin-error "alias" name "not found")))) ; error, return (failed 1) 137 | 138 | 139 | (define (show-alias* name alias wbuf) 140 | (bytespan-insert-right/string! wbuf "alias ") 141 | (bytespan-insert-right/string! wbuf name) 142 | (cond 143 | ((procedure? alias) 144 | (bytespan-insert-right/string! wbuf " #")) 145 | ((or (pair? alias) (null? alias)) 146 | (for-list ((elem alias)) 147 | (if (string? elem) 148 | (begin 149 | (bytespan-insert-right/u8! wbuf 32 39) ; #\space #\' 150 | (bytespan-insert-right/string! wbuf elem) 151 | (bytespan-insert-right/u8! wbuf 39)) ; #\' 152 | (bytespan-insert-right/string! wbuf elem " #")))) 153 | (else 154 | (bytespan-insert-right/string! wbuf " #"))) 155 | (bytespan-insert-right/u8! wbuf 10)) ; #\newline 156 | -------------------------------------------------------------------------------- /doc/lineedit/ansi.md: -------------------------------------------------------------------------------- 1 | # prompt customization 2 | 3 | prompt can be customized using two alternative mechanisms: 4 | 5 | 1. by setting the environment variable `$SCHEMESH_PS1`, which is mostly compatible with bash PS1 6 | as described in section "PROMPTING" of `man bash` and available online at 7 | https://www.man7.org/linux/man-pages//man1/bash.1.html#PROMPTING 8 | 9 | 2. by registering a user-defined function that will be executed each time schemesh needs to draw the prompt. 10 | Such function must accept a single `lctx` argument and can update the prompt stored into `lctx` as it sees fit. 11 | 12 | Such a prompt-updating function can be registered into schemesh by calling 13 | `(linectx-prompt-proc MY-PROCEDURE)` 14 | 15 | The registered function can run arbitrary Scheme code, and can also launch external commands 16 | (possibly slow, but supported) either with Chez Scheme function `(open-process-ports)` 17 | or with schemesh facilities for running jobs and capturing their output, as for example `(sh-run/string)`. 18 | 19 | Users must take care to capture or redirect all the input and output of the external commands, 20 | because they should **not** read from or write to the current terminal. 21 | 22 | ### scheme2k lineedit 23 | 24 | The library `(scheme2k lineedit)`, which is also included in `(schemesh)`, provides the following functions for prompt customization: 25 | 26 | `(linectx-prompt-proc)` returns the current prompt updater 27 | 28 | `(linectx-prompt-proc proc)` registers function `proc` as the prompt updater: 29 | `proc` will be invoked with a single argument `lctx` each time schemesh needs to draw the prompt 30 | 31 | `(linectx-prompt-ansi-text lctx)` extracts the current prompt from `lctx` object and converts it to a mutable `ansi-text` object 32 | 33 | `(linectx-prompt-ansi-text-set! lctx a)` stores the `ansi-text` object `a` into `lctx` as the updated prompt 34 | 35 | ### scheme2k lineedit ansi 36 | 37 | The library `(scheme2k lineedit ansi)`, which is also included in `(scheme2k lineedit)` and in `(schemesh)`, provides several functions for inspecting and modifying `ansi-text` objects: 38 | 39 | `(ansi-text? a)` returns `#t` if `a` is an `ansi-text` object, otherwise returns `#f` 40 | 41 | `(ansi-text-bytes a)` returns the bytespan (a resizeable bytevector) containing the current text 42 | 43 | `(ansi-text-visible-length a)` returns an unsigned fixnum indicating the **visible** length of the current text, 44 | i.e. ignoring all the escape sequences contained in the current text 45 | 46 | `(ansi-text-clear! a)` removes all text from `ansi-text` object. It should be called as first action, 47 | before filling `ansi-text` object with a new prompt 48 | 49 | `(make-ansi-text)` can be used to create a standalone `ansi-text` object. This is usually not necessary when 50 | customizing a prompt 51 | 52 | `(string+ a string)` and `(string+ a string visible-length)` append a string to the current text. 53 | If string contains escape sequences, the **visible** length of the string, i.e. ignoring all the escape sequences, 54 | must be specified too 55 | 56 | `(black a string)` appends string to the current text, highlighting it in black foreground 57 | 58 | `(black+ a string)` appends string to the current text, highlighting it in bold black or bright black (= grey) foreground 59 | 60 | `(red a string)` appends string to the current text, highlighting it in red foreground 61 | 62 | `(red+ a string)` appends string to the current text, highlighting it in bold/bright red foreground 63 | 64 | `(green a string)` appends string to the current text, highlighting it in green foreground 65 | 66 | `(green+ a string)` appends string to the current text, highlighting it in bold/bright green foreground 67 | 68 | `(yellow a string)` appends string to the current text, highlighting it in yellow foreground 69 | 70 | `(yellow+ a string)` appends string to the current text, highlighting it in bold/bright yellow foreground 71 | 72 | `(blue a string)` appends string to the current text, highlighting it in blue foreground 73 | 74 | `(blue+ a string)` appends string to the current text, highlighting it in bold/bright blue foreground 75 | 76 | `(magenta a string)` appends string to the current text, highlighting it in magenta foreground 77 | 78 | `(magenta+ a string)` appends string to the current text, highlighting it in bold/bright magenta foreground 79 | 80 | `(cyan a string)` appends string to the current text, highlighting it in cyan foreground 81 | 82 | `(cyan+ a string)` appends string to the current text, highlighting it in bold/bright cyan foreground 83 | 84 | `(white a string)` appends string to the current text, highlighting it in white foreground 85 | 86 | `(white+ a string)` appends string to the current text, highlighting it in bold/bright white foreground 87 | 88 | 89 | `(color a col-seq string)` is a general-purpose string highlighting function: 90 | appends string to the current text, highlighting it with specified ansi attribute. 91 | The argument `col-seq` must be a string containing a semicolon-separated list of ansi colors codes 92 | supported by the current terminal. Some codes supported by most terminals: 93 | - `"0"` reset foreground, background and bright or bold to default 94 | - `"1"` bright or bold foreground 95 | - `"30"` black foreground 96 | - `"31"` red foreground 97 | - `"32"` green foreground 98 | - `"33"` yellow foreground 99 | - `"34"` blue foreground 100 | - `"35"` magenta foreground 101 | - `"36"` cyan foreground 102 | - `"37"` white foreground 103 | - `"40"` black background 104 | - `"41"` red background 105 | - `"42"` green background 106 | - `"43"` yellow background 107 | - `"44"` blue background 108 | - `"45"` magenta background 109 | - `"46"` cyan background 110 | - `"47"` white background 111 | 112 | Example: 113 | ```lisp 114 | 115 | (define (my-prompt lctx) 116 | (let ((a (linectx-prompt-ansi-text lctx))) 117 | (ansi-text-clear! a) 118 | (magenta a (c-username)) 119 | (string+ a "@") 120 | (blue+ a (c-hostname)) 121 | (string+ a ":") 122 | (cyan a (charspan->string (sh-home->~ (sh-cwd)))) 123 | (string+ a ":") 124 | (linectx-prompt-ansi-text-set! lctx a))) 125 | 126 | (linectx-prompt-proc my-prompt) 127 | ``` 128 | 129 | To restore the default prompt function, that reads and interprets the environment variable `$SCHEMESH_PS1`, execute 130 | ```lisp 131 | (linectx-prompt-proc sh-expand-ps1) 132 | ``` 133 | -------------------------------------------------------------------------------- /containers/macros.ss: -------------------------------------------------------------------------------- 1 | ;;; Copyright (C) 2023-2025 by Massimiliano Ghilardi 2 | ;;; 3 | ;;; This library is free software; you can redistribute it and/or 4 | ;;; modify it under the terms of the GNU Library General Public 5 | ;;; License as published by the Free Software Foundation; either 6 | ;;; version 2 of the License, or (at your option) any later version. 7 | 8 | #!r6rs 9 | 10 | (library (scheme2k containers macros (0 9 2)) 11 | (export 12 | begin^ for for* if^ let^ let-values^ unless^ when^) 13 | (import 14 | (rnrs) 15 | (only (chezscheme) void) 16 | (only (scheme2k bootstrap) generate-pretty-temporaries with-while-until)) 17 | 18 | 19 | ;; extended (begin body ...) that also accepts empty body 20 | (define-syntax begin^ 21 | (syntax-rules () 22 | ((_) (void)) 23 | ((_ body) body) 24 | ((_ body ...) (begin body ...)))) 25 | 26 | 27 | ;; extended (if expr then else) that also accepts empty then and else 28 | (define-syntax if^ 29 | (syntax-rules () 30 | ((_ expr) (begin expr (void))) 31 | ((_ expr then) (if expr then (void))) 32 | ((_ expr then else) (if expr then else)))) 33 | 34 | 35 | ;; extended (unless expr body ...) that also accepts empty body 36 | (define-syntax unless^ 37 | (syntax-rules () 38 | ((_ expr) (begin expr (void))) 39 | ((_ expr body ...) (if expr (void) (begin^ body ...))))) 40 | 41 | 42 | ;; extended (when expr body ...) that also accepts empty body 43 | (define-syntax when^ 44 | (syntax-rules () 45 | ((_ expr) (begin expr (void))) 46 | ((_ expr body ...) (if expr (begin^ body ...) (void))))) 47 | 48 | 49 | ;; extended (let ((var expr) ...) body ...) that also accepts empty body 50 | (define-syntax let^ 51 | (syntax-rules () 52 | ((_ () body ...) 53 | (begin^ body ...)) 54 | ((_ ((var expr) ...)) 55 | (let ((var expr) ...) 56 | (void))) 57 | ((_ ((var expr) ...) body ...) 58 | (let ((var expr) ...) 59 | body ...)))) 60 | 61 | 62 | ;; extended (let-values (((var ...) expr) ...) body ...) 63 | ;; that optimizes single-value bindings and also accepts empty body 64 | (define-syntax let-values^ 65 | (syntax-rules () 66 | ((_ () body ...) 67 | (begin^ body ...)) 68 | ((_ (((var) expr) more-vars ...) body ...) 69 | (let ((var expr)) 70 | (let-values^ (more-vars ...) 71 | body ...))) 72 | ((_ (((var vars ...) expr) more-vars ...) body ...) 73 | (let-values (((var vars ...) expr)) 74 | (let-values^ (more-vars ...) 75 | body ...))))) 76 | 77 | 78 | (define-syntax %for-body 79 | (syntax-rules () 80 | ((_ for-loop () body ...) 81 | (with-while-until body ... (for-loop))) 82 | ((_ for-loop ((vars ... flag iter) more-vars ...) body ...) 83 | (let-values^ (((vars ... flag) (iter))) 84 | (when^ flag 85 | (%for-body for-loop (more-vars ...) 86 | body ...)))))) 87 | 88 | 89 | (define-syntax %for-sequence 90 | (syntax-rules () 91 | ((_ () (bind ...) body ...) 92 | (let for-loop () 93 | (%for-body for-loop (bind ...) body ...))) 94 | ;; Racket-compatible syntax: (for (((var ...) sequence)) body ...) 95 | ((_ (((var ...) sequence) clause2 ...) (bind ...) body ...) 96 | (%for-sequence ((var ... sequence)) (bind ...) body ...)) 97 | ;; Simplified syntax: (for ((var ... sequence)) body ...) 98 | ((_ ((var ... sequence) clause2 ...) (bind ...) body ...) 99 | (let ((iter sequence)) 100 | (%for-sequence (clause2 ...) (bind ... (var ... flag iter)) body ...))))) 101 | 102 | 103 | ;;; Loop in parallel on elements returned by zero or more iterators, 104 | ;;; and execute body ... at each iteration, with vars bound to elements returned by the iterators. 105 | ;;; 106 | ;;; The loop finishes when some iterator is exhausted, and returns unspecified value. 107 | ;;; 108 | ;;; If no iterators are specified, behave as (forever body ...) 109 | ;;; 110 | ;;; Typical iterators expressions are (in-list ...) (in-vector ...) (in-hash ...) etc. 111 | ;;; 112 | ;;; The only difference between (for) and (for*) is: 113 | ;;; (for) evaluates all (iterator) in parallel, then checks if some of them reached their end. 114 | ;;; (for*) evaluates each (iterator) one by one, and immediately checks if it reached its end: 115 | ;;; in such case, the remaining iterators are not evaluated. 116 | (define-syntax for 117 | (syntax-rules () 118 | ((_ (clause ...) body ...) 119 | (%for-sequence (clause ...) () body ...)))) 120 | 121 | 122 | 123 | (define-syntax %for*-inner-part 124 | (syntax-rules () 125 | ((_ () body ...) 126 | (begin^ body ...)) 127 | ((_ ((vars ... flag iter)) body ...) 128 | (let-values^ (((vars ... flag) (iter))) 129 | (when^ flag 130 | body ...))) 131 | ((_ ((vars ... flag iter) (vars2 ... flag2 iter2) ...) body ...) 132 | (let-values^ (((vars ... flag) (iter))) 133 | (when^ flag 134 | (%for*-inner-part ((vars2 ... flag2 iter2) ...) 135 | body ...)))))) 136 | 137 | 138 | ;;; Loop in parallel on elements returned by zero or more iterators, 139 | ;;; and execute body ... at each iteration, with vars bound to elements returned by iterators. 140 | ;;; 141 | ;;; The loop finishes when some iterator is exhausted, and returns unspecified value. 142 | ;;; 143 | ;;; If no iterators are specified, behave as (forever body ...) 144 | ;;; 145 | ;;; Typical iterators expressions are (in-list ...) (in-vector ...) (in-hash ...) etc. 146 | ;;; 147 | ;;; The only difference between (for) and (for*) is: 148 | ;;; (for) evaluates all (iterator) in parallel, then checks if some of them reached their end. 149 | ;;; (for*) evaluates each (iterator) one by one, and immediately checks if it reached its end: 150 | ;;; in such case, the remaining iterators are not evaluated. 151 | (define-syntax for* 152 | (lambda (stx) 153 | (syntax-case stx () 154 | ((_ ((vars ... iterator) ...) body ...) 155 | (with-syntax (((flag ...) (generate-pretty-temporaries #'(iterator ...)))) 156 | (with-syntax (((iter ...) (generate-pretty-temporaries #'(iterator ...)))) 157 | #`(let ((iter iterator) ...) 158 | (let for*-loop () 159 | (%for*-inner-part ((vars ... flag iter) ...) 160 | (with-while-until 161 | body ... 162 | (for*-loop))))))))))) 163 | 164 | ) ; close library 165 | --------------------------------------------------------------------------------