Absorb gherkin compat modules: 23 new stdlib libraries
ober
dc7ece3cde471291a8d26519de8d4b35259df982
--- a/Makefile +++ b/Makefile @@ -1,9 +1,9 @@ SCHEME = scheme LIBDIRS = lib -.PHONY: test test-reader test-core test-runtime test-stdlib test-ffi test-modules clean +.PHONY: test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded clean -test: test-reader test-core test-runtime test-stdlib test-ffi test-modules +test: test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-reader: $(SCHEME) --libdirs $(LIBDIRS) --script tests/test-reader.ss @@ -33,6 +33,11 @@ test-modules: $(SCHEME) --libdirs $(LIBDIRS) --script tests/test-modules.ss; \ fi +test-expanded: + @if [ -f tests/test-expanded-stdlib.ss ]; then \ + $(SCHEME) --libdirs $(LIBDIRS) --script tests/test-expanded-stdlib.ss; \ + fi + clean: find lib -name "*.so" -delete 2>/dev/null || true find lib -name "*.wpo" -delete 2>/dev/null || true new file mode 100644 --- /dev/null +++ b/lib/std/cli/getopt.sls @@ -0,0 +1,279 @@ +#!chezscheme +;;; getopt.sls -- Compat shim for Gerbil's :std/cli/getopt +;;; Command-line argument parsing with options, flags, arguments, and commands. + +(library (std cli getopt) + (export + getopt + getopt? + getopt-object? + getopt-error? + getopt-parse + getopt-display-help + getopt-display-help-topic + option + flag + command + argument + optional-argument + rest-arguments + call-with-getopt) + + (import (except (chezscheme) filter find make-hash-table hash-table? iota 1+ 1-) + (only (jerboa runtime) make-hash-table hash-put!)) + + ;; --- Option/Flag/Argument/Command records --- + + (define-record-type opt + (fields name short long help default (mutable value) kind)) + ;; kind: 'option, 'flag, 'argument, 'optional-argument, 'rest-arguments + + (define-record-type cmd + (fields name help options handler)) + + (define-record-type getopt-obj + (fields program options commands)) + + (define-record-type getopt-err + (fields message context)) + + (define (getopt? x) (getopt-obj? x)) + (define (getopt-object? x) (getopt-obj? x)) + (define (getopt-error? x) (getopt-err? x)) + + ;; --- Constructor helpers --- + + (define (option name . args) + ;; (option "name" "-s" "--long" help: "..." default: val) + (let ((parsed (parse-opt-args args))) + (make-opt name (car parsed) (cadr parsed) (caddr parsed) (cadddr parsed) #f 'option))) + + (define (flag name . args) + (let ((parsed (parse-opt-args args))) + (make-opt name (car parsed) (cadr parsed) (caddr parsed) (or (cadddr parsed) #f) #f 'flag))) + + (define (argument name . args) + (let ((parsed (parse-opt-args args))) + (make-opt name #f #f (or (caddr parsed) "") (cadddr parsed) #f 'argument))) + + (define (optional-argument name . args) + (let ((parsed (parse-opt-args args))) + (make-opt name #f #f (or (caddr parsed) "") (cadddr parsed) #f 'optional-argument))) + + (define (rest-arguments name . args) + (let ((parsed (parse-opt-args args))) + (make-opt name #f #f (or (caddr parsed) "") (or (cadddr parsed) '()) #f 'rest-arguments))) + + (define (command name . args) + ;; (command name help: "..." opts... handler) + ;; Last arg is a lambda handler, preceding args are opts + (let lp ((args args) (help #f) (opts '())) + (cond + ((null? args) + (make-cmd name (or help "") (reverse opts) #f)) + ((and (symbol? (car args)) (string=? "help:" (symbol->string (car args)))) + (lp (cddr args) (cadr args) opts)) + ((procedure? (car args)) + (make-cmd name (or help "") (reverse opts) (car args))) + ((opt? (car args)) + (lp (cdr args) help (cons (car args) opts))) + (else + (lp (cdr args) help opts))))) + + ;; Parse option constructor arguments: short long help: default: + (define (parse-opt-args args) + (let lp ((args args) (short #f) (long #f) (help #f) (default #f)) + (cond + ((null? args) + (list short long help default)) + ((and (string? (car args)) (> (string-length (car args)) 0) + (char=? (string-ref (car args) 0) #\-)) + (if (and (> (string-length (car args)) 1) + (char=? (string-ref (car args) 1) #\-)) + (lp (cdr args) short (car args) help default) + (lp (cdr args) (car args) long help default))) + ((and (pair? args) (symbol? (car args)) + (string=? "help:" (symbol->string (car args)))) + (lp (cddr args) short long (cadr args) default)) + ((and (pair? args) (symbol? (car args)) + (string=? "default:" (symbol->string (car args)))) + (lp (cddr args) short long help (cadr args))) + (else + (lp (cdr args) short long help default))))) + + ;; --- getopt --- + (define (getopt . specs) + ;; specs is a mix of option/flag/argument/command objects + (let lp ((specs specs) (program #f) (opts '()) (cmds '())) + (cond + ((null? specs) + (make-getopt-obj program (reverse opts) (reverse cmds))) + ((and (symbol? (car specs)) + (string=? "program:" (symbol->string (car specs)))) + (lp (cddr specs) (cadr specs) opts cmds)) + ((opt? (car specs)) + (lp (cdr specs) program (cons (car specs) opts) cmds)) + ((cmd? (car specs)) + (lp (cdr specs) program opts (cons (car specs) cmds))) + (else + (lp (cdr specs) program opts cmds))))) + + ;; --- getopt-parse --- + (define (getopt-parse gopt args) + ;; Returns: (values options rest-args) or raises getopt-err + ;; options is an alist of (name . value) pairs + (let ((opts (if (getopt-obj? gopt) (getopt-obj-options gopt) '())) + (cmds (if (getopt-obj? gopt) (getopt-obj-commands gopt) '()))) + (parse-args opts cmds args))) + + (define (parse-args opts cmds args) + (let lp ((args args) (result '()) (positionals '()) (pos-idx 0)) + (let ((pos-opts (filter (lambda (o) (memq (opt-kind o) '(argument optional-argument rest-arguments))) opts))) + (cond + ((null? args) + ;; Fill in defaults for unset options + (let ((result (fold-left + (lambda (acc o) + (if (assoc (opt-name o) acc) + acc + (cons (cons (opt-name o) (opt-default o)) acc))) + result + opts))) + (values result '()))) + ;; -- flag or option + ((and (string? (car args)) + (> (string-length (car args)) 1) + (char=? (string-ref (car args) 0) #\-)) + (let ((arg (car args))) + (cond + ;; -- means end of options + ((string=? arg "--") + (let ((result (fold-left + (lambda (acc o) + (if (assoc (opt-name o) acc) + acc + (cons (cons (opt-name o) (opt-default o)) acc))) + result + opts))) + (values result (cdr args)))) + ;; Find matching option/flag + ((find-opt opts arg) + => (lambda (o) + (case (opt-kind o) + ((flag) + (lp (cdr args) (cons (cons (opt-name o) #t) result) positionals pos-idx)) + ((option) + (if (null? (cdr args)) + (error 'getopt-parse (string-append "missing value for " arg)) + (lp (cddr args) + (cons (cons (opt-name o) (cadr args)) result) + positionals pos-idx)))))) + (else + (error 'getopt-parse (string-append "unknown option: " arg)))))) + ;; Check for command + ((and (null? result) (pair? cmds) + (find-cmd cmds (car args))) + => (lambda (c) + (let-values (((cmd-opts rest) (parse-args (cmd-options c) '() (cdr args)))) + (values (cons (cons "command" (cmd-name c)) cmd-opts) rest)))) + ;; Positional argument + (else + (if (< pos-idx (length pos-opts)) + (let ((po (list-ref pos-opts pos-idx))) + (case (opt-kind po) + ((rest-arguments) + (lp '() (cons (cons (opt-name po) args) result) positionals pos-idx)) + (else + (lp (cdr args) (cons (cons (opt-name po) (car args)) result) + positionals (+ pos-idx 1))))) + (lp (cdr args) result (cons (car args) positionals) pos-idx))))))) + + (define (find-opt opts arg) + (find (lambda (o) + (or (and (opt-short o) (string=? arg (opt-short o))) + (and (opt-long o) (string=? arg (opt-long o))))) + opts)) + + (define (find-cmd cmds name) + (let ((name-str (if (symbol? name) (symbol->string name) name))) + (find (lambda (c) + (let ((cn (cmd-name c))) + (string=? name-str (if (symbol? cn) (symbol->string cn) cn)))) + cmds))) + + ;; --- getopt-display-help --- + (define (getopt-display-help gopt . rest) + (let ((port (if (pair? rest) (car rest) (current-output-port)))) + (when (getopt-obj-program gopt) + (fprintf port "Usage: ~a [options]~n" (getopt-obj-program gopt))) + (let ((opts (getopt-obj-options gopt)) + (cmds (getopt-obj-commands gopt))) + (unless (null? opts) + (fprintf port "~nOptions:~n") + (for-each + (lambda (o) + (let ((short (or (opt-short o) "")) + (long (or (opt-long o) "")) + (help (or (opt-help o) ""))) + (cond + ((memq (opt-kind o) '(argument optional-argument rest-arguments)) + (fprintf port " ~a~30t~a~n" (opt-name o) help)) + (else + (fprintf port " ~a ~a~30t~a~n" short long help))))) + opts)) + (unless (null? cmds) + (fprintf port "~nCommands:~n") + (for-each + (lambda (c) + (fprintf port " ~a~30t~a~n" (cmd-name c) (cmd-help c))) + cmds))))) + + (define (getopt-display-help-topic gopt topic . rest) + (let ((port (if (pair? rest) (car rest) (current-output-port)))) + (let ((c (find-cmd (getopt-obj-commands gopt) topic))) + (if c + (begin + (fprintf port "~a: ~a~n" (cmd-name c) (cmd-help c)) + (unless (null? (cmd-options c)) + (fprintf port "~nOptions:~n") + (for-each + (lambda (o) + (fprintf port " ~a ~a~30t~a~n" + (or (opt-short o) "") (or (opt-long o) "") (or (opt-help o) ""))) + (cmd-options c)))) + (fprintf port "Unknown topic: ~a~n" topic))))) + + ;; --- call-with-getopt --- + (define (call-with-getopt proc args . specs) + ;; Gerbil convention: (proc cmd opt-hash) + ;; cmd = command name symbol, opt-hash = hash table of options + (let ((gopt (apply getopt specs))) + (guard (exn (#t (fprintf (current-error-port) "Error: ~a~n" exn) + (getopt-display-help gopt (current-error-port)) + (exit 1))) + (let-values (((opts rest) (getopt-parse gopt args))) + (let ((cmd-pair (assoc "command" opts)) + (ht (make-hash-table))) + (for-each (lambda (pair) + (unless (string=? "command" (let ((k (car pair))) + (if (symbol? k) (symbol->string k) k))) + (hash-put! ht (car pair) (cdr pair)))) + opts) + (if cmd-pair + (proc (cdr cmd-pair) ht) + (proc #f ht))))))) + + ;; Helpers + (define (find pred lst) + (cond + ((null? lst) #f) + ((pred (car lst)) (car lst)) + (else (find pred (cdr lst))))) + + (define (filter pred lst) + (cond + ((null? lst) '()) + ((pred (car lst)) (cons (car lst) (filter pred (cdr lst)))) + (else (filter pred (cdr lst))))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/crypto/digest.sls @@ -0,0 +1,90 @@ +#!chezscheme +;;; :std/crypto/digest -- Cryptographic hash functions via openssl CLI + +(library (std crypto digest) + (export + md5 sha1 sha256 sha384 sha512 + digest->hex-string digest->u8vector) + + (import (chezscheme)) + + (define (compute-digest algo data) + ;; data can be string or bytevector + (let* ((input (if (bytevector? data) data (string->utf8 data))) + (algo-name (case algo + ((md5) "md5") + ((sha1) "sha1") + ((sha256) "sha256") + ((sha384) "sha384") + ((sha512) "sha512") + (else (error 'compute-digest "unknown algorithm" algo))))) + ;; Write to temp file, hash with openssl + (let ((tmp-file (format "/tmp/jerboa-digest-~a" (random 1000000)))) + (let ((port (open-file-output-port tmp-file + (file-options no-fail) + (buffer-mode block)))) + (put-bytevector port input) + (close-port port)) + (let-values (((to-stdin from-stdout from-stderr pid) + (open-process-ports + (format "openssl dgst -~a -hex ~a" algo-name tmp-file) + (buffer-mode block) + (native-transcoder)))) + (close-port to-stdin) + (let ((output (get-string-all from-stdout))) + (close-port from-stdout) + (close-port from-stderr) + (delete-file tmp-file) + ;; openssl output: "SHA256(file)= hexstring\n" + (let ((eq-pos (let lp ((i 0)) + (cond + ((>= i (string-length output)) #f) + ((char=? (string-ref output i) #\=) i) + (else (lp (+ i 1))))))) + (if eq-pos + (string-trim (substring output (+ eq-pos 1) (string-length output))) + (string-trim output)))))))) + + (define (string-trim str) + (let* ((len (string-length str)) + (start (let lp ((i 0)) + (if (or (>= i len) (not (char-whitespace? (string-ref str i)))) + i (lp (+ i 1))))) + (end (let lp ((i (- len 1))) + (if (or (< i start) (not (char-whitespace? (string-ref str i)))) + (+ i 1) (lp (- i 1)))))) + (substring str start end))) + + (define (hex-string->u8vector str) + (let* ((len (string-length str)) + (out-len (quotient len 2)) + (result (make-bytevector out-len))) + (do ((i 0 (+ i 2)) + (j 0 (+ j 1))) + ((>= i len) result) + (let ((hi (hex-char->int (string-ref str i))) + (lo (hex-char->int (string-ref str (+ i 1))))) + (bytevector-u8-set! result j + (bitwise-ior (bitwise-arithmetic-shift-left hi 4) lo)))))) + + (define (hex-char->int c) + (cond + ((char<=? #\0 c #\9) (- (char->integer c) (char->integer #\0))) + ((char<=? #\a c #\f) (+ 10 (- (char->integer c) (char->integer #\a)))) + ((char<=? #\A c #\F) (+ 10 (- (char->integer c) (char->integer #\A)))) + (else 0))) + + ;; Public API: returns hex string + (define (md5 data) (compute-digest 'md5 data)) + (define (sha1 data) (compute-digest 'sha1 data)) + (define (sha256 data) (compute-digest 'sha256 data)) + (define (sha384 data) (compute-digest 'sha384 data)) + (define (sha512 data) (compute-digest 'sha512 data)) + + (define (digest->hex-string digest-result) + digest-result) ;; already a hex string + + (define (digest->u8vector digest-result) + (hex-string->u8vector digest-result)) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/logger.sls @@ -0,0 +1,80 @@ +#!chezscheme +;;; :std/logger -- Simple logging to stderr with level filtering + +(library (std logger) + (export + start-logger! + current-logger + current-logger-options + current-log-directory + make-logger-options + logger-options? + deflogger + errorf + warnf + infof + debugf + verbosef) + + (import (except (chezscheme) errorf)) + + ;; Log levels: 0=error, 1=warn, 2=info, 3=debug, 4=verbose + (define-record-type logger-options + (fields level output)) + + (define current-logger-options + (make-parameter (make-logger-options 2 (current-error-port)))) + + (define current-logger + (make-parameter #f)) + + (define current-log-directory + (make-parameter #f)) + + (define (start-logger! . args) + ;; (start-logger! level: 'info output: port) + (let lp ((args args) (level 2) (output (current-error-port))) + (cond + ((null? args) + (current-logger-options (make-logger-options level output)) + (current-logger #t)) + ((and (symbol? (car args)) (string=? "level:" (symbol->string (car args)))) + (lp (cddr args) (level->int (cadr args)) output)) + ((and (symbol? (car args)) (string=? "output:" (symbol->string (car args)))) + (lp (cddr args) level (cadr args))) + (else (lp (cdr args) level output))))) + + (define (level->int sym) + (case sym + ((error) 0) + ((warn warning) 1) + ((info) 2) + ((debug) 3) + ((verbose) 4) + (else 2))) + + (define (log-at level prefix fmt . args) + (let ((opts (current-logger-options))) + (when (<= level (logger-options-level opts)) + (let ((port (logger-options-output opts)) + (msg (apply format fmt args))) + (fprintf port "[~a] ~a~n" prefix msg) + (flush-output-port port))))) + + (define (errorf fmt . args) (apply log-at 0 "ERROR" fmt args)) + (define (warnf fmt . args) (apply log-at 1 "WARN" fmt args)) + (define (infof fmt . args) (apply log-at 2 "INFO" fmt args)) + (define (debugf fmt . args) (apply log-at 3 "DEBUG" fmt args)) + (define (verbosef fmt . args) (apply log-at 4 "VERBOSE" fmt args)) + + ;; deflogger is a macro in Gerbil; here we just provide it as a no-op + ;; that defines the logging functions in the current module. + ;; Since we use globals, this is just a pass-through. + (define-syntax deflogger + (syntax-rules () + ((_ name) + (begin)) + ((_ name args ...) + (begin)))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/misc/bytes.sls @@ -0,0 +1,81 @@ +#!chezscheme +;;; :std/misc/bytes -- Byte/bytevector manipulation utilities + +(library (std misc bytes) + (export + u8vector-xor + u8vector-xor! + u8vector-and + u8vector-ior + u8vector-zero! + u8vector->uint + uint->u8vector) + + (import (chezscheme)) + + (define (u8vector-xor bv1 bv2) + (let* ((len (min (bytevector-length bv1) (bytevector-length bv2))) + (result (make-bytevector len))) + (let lp ((i 0)) + (when (< i len) + (bytevector-u8-set! result i + (fxlogxor (bytevector-u8-ref bv1 i) + (bytevector-u8-ref bv2 i))) + (lp (+ i 1)))) + result)) + + (define (u8vector-xor! bv1 bv2) + (let ((len (min (bytevector-length bv1) (bytevector-length bv2)))) + (let lp ((i 0)) + (when (< i len) + (bytevector-u8-set! bv1 i + (fxlogxor (bytevector-u8-ref bv1 i) + (bytevector-u8-ref bv2 i))) + (lp (+ i 1)))))) + + (define (u8vector-and bv1 bv2) + (let* ((len (min (bytevector-length bv1) (bytevector-length bv2))) + (result (make-bytevector len))) + (let lp ((i 0)) + (when (< i len) + (bytevector-u8-set! result i + (fxlogand (bytevector-u8-ref bv1 i) + (bytevector-u8-ref bv2 i))) + (lp (+ i 1)))) + result)) + + (define (u8vector-ior bv1 bv2) + (let* ((len (min (bytevector-length bv1) (bytevector-length bv2))) + (result (make-bytevector len))) + (let lp ((i 0)) + (when (< i len) + (bytevector-u8-set! result i + (fxlogor (bytevector-u8-ref bv1 i) + (bytevector-u8-ref bv2 i))) + (lp (+ i 1)))) + result)) + + (define (u8vector-zero! bv) + (bytevector-fill! bv 0)) + + (define (u8vector->uint bv) + ;; Big-endian bytevector to unsigned integer + (let ((len (bytevector-length bv))) + (let lp ((i 0) (result 0)) + (if (>= i len) result + (lp (+ i 1) + (+ (bitwise-arithmetic-shift-left result 8) + (bytevector-u8-ref bv i))))))) + + (define (uint->u8vector n . rest) + ;; Unsigned integer to big-endian bytevector + (let ((len (if (pair? rest) (car rest) + (max 1 (quotient (+ (bitwise-length n) 7) 8))))) + (let ((bv (make-bytevector len 0))) + (let lp ((i (- len 1)) (n n)) + (when (and (>= i 0) (> n 0)) + (bytevector-u8-set! bv i (bitwise-and n #xff)) + (lp (- i 1) (bitwise-arithmetic-shift-right n 8)))) + bv))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/misc/completion.sls @@ -0,0 +1,52 @@ +#!chezscheme +;;; :std/misc/completion -- Asynchronous completion tokens + +(library (std misc completion) + (export + make-completion completion? + completion-ready? + completion-post! completion-error! completion-wait!) + + (import (chezscheme)) + + (define-record-type completion + (fields (mutable ready?) + (mutable val) + (mutable exn) + (immutable mx) + (immutable cv)) + (protocol + (lambda (new) + (lambda args + (new #f #f #f (make-mutex) (make-condition)))))) + + (define (completion-post! c val) + (with-mutex (completion-mx c) + (when (completion-ready? c) + (error 'completion-post! "completion already posted")) + (completion-ready?-set! c #t) + (completion-val-set! c val) + (condition-broadcast (completion-cv c)))) + + (define (completion-error! c exn) + (with-mutex (completion-mx c) + (when (completion-ready? c) + (error 'completion-error! "completion already posted")) + (completion-ready?-set! c #t) + (completion-exn-set! c exn) + (condition-broadcast (completion-cv c)))) + + (define (completion-wait! c) + (mutex-acquire (completion-mx c)) + (let lp () + (cond + ((completion-ready? c) + (let ((exn (completion-exn c)) + (val (completion-val c))) + (mutex-release (completion-mx c)) + (if exn (raise exn) val))) + (else + (condition-wait (completion-cv c) (completion-mx c)) + (lp))))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/misc/process.sls @@ -0,0 +1,112 @@ +#!chezscheme +;;; :std/misc/process -- Process execution utilities + +(library (std misc process) + (export + run-process + run-process/batch) + + (import (chezscheme)) + + (define (run-process args . rest) + ;; Run a process and return its stdout as a string. + ;; args: list of strings (command and arguments) + ;; Keywords: stdin-redirection: #f, stdout-redirection: #t, stderr-redirection: #f, + ;; coprocess: #f, environment: #f, directory: #f + ;; For Chez, we use process and open-process-ports + (let* ((cmd (build-command-string args)) + (show-console (extract-keyword rest 'show-console: #f)) + (dir (extract-keyword rest 'directory: #f)) + (full-cmd (if dir + (string-append "cd " (shell-quote dir) " && " cmd) + cmd))) + (let-values (((to-stdin from-stdout from-stderr pid) + (open-process-ports full-cmd 'line (native-transcoder)))) + (close-port to-stdin) + (let ((output (read-all from-stdout))) + (close-port from-stdout) + (close-port from-stderr) + output)))) + + (define (run-process/batch args . rest) + ;; Run a process and return exit status (0 = success) + (let* ((cmd (build-command-string args)) + (dir (extract-keyword rest 'directory: #f)) + (full-cmd (if dir + (string-append "cd " (shell-quote dir) " && " cmd) + cmd))) + (system full-cmd))) + + (define (build-command-string args) + (if (string? args) + args + (string-join (map shell-quote args) " "))) + + (define (shell-quote s) + ;; Simple shell quoting + (if (and (not (string-contains? s "'")) + (not (string-contains? s " ")) + (not (string-contains? s "\"")) + (not (string-contains? s "$")) + (not (string-contains? s "`")) + (not (string-contains? s "\\")) + (> (string-length s) 0)) + s + (string-append "'" (string-replace-all s "'" "'\"'\"'") "'"))) + + (define (string-contains? s sub) + (let ((slen (string-length s)) + (sublen (string-length sub))) + (let lp ((i 0)) + (cond + ((> (+ i sublen) slen) #f) + ((string=? (substring s i (+ i sublen)) sub) #t) + (else (lp (+ i 1))))))) + + (define (string-replace-all s old new) + (let ((olen (string-length old)) + (slen (string-length s))) + (let lp ((i 0) (parts '())) + (cond + ((> (+ i olen) slen) + (apply string-append (reverse (cons (substring s i slen) parts)))) + ((string=? (substring s i (+ i olen)) old) + (lp (+ i olen) (cons new parts))) + (else + (let lp2 ((j (+ i 1))) + (cond + ((> (+ j olen) slen) + (apply string-append (reverse (cons (substring s i slen) parts)))) + ((string=? (substring s j (+ j olen)) old) + (lp j (cons (substring s i j) parts))) + (else (lp2 (+ j 1)))))))))) + + (define (string-join lst sep) + (cond + ((null? lst) "") + ((null? (cdr lst)) (car lst)) + (else + (let lp ((rest (cdr lst)) (acc (car lst))) + (if (null? rest) acc + (lp (cdr rest) (string-append acc sep (car rest)))))))) + + (define (extract-keyword args key default) + (let lp ((args args)) + (cond + ((null? args) default) + ((and (symbol? (car args)) + (string=? (symbol->string (car args)) + (symbol->string key))) + (if (pair? (cdr args)) (cadr args) default)) + (else (lp (cdr args)))))) + + (define (read-all port) + (let lp ((chunks '())) + (let ((buf (get-string-n port 4096))) + (if (eof-object? buf) + (if (null? chunks) + "" + (apply string-append (reverse chunks))) + (lp (cons buf chunks)))))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/misc/queue.sls @@ -0,0 +1,58 @@ +#!chezscheme +;;; :std/misc/queue -- Mutable FIFO queue + +(library (std misc queue) + (export + make-queue + queue? + queue-empty? + queue-length + enqueue! + dequeue! + queue-peek + queue->list) + + (import (chezscheme)) + + (define-record-type queue + (fields (mutable head) (mutable tail) (mutable size)) + (protocol + (lambda (new) + (lambda () (new '() '() 0))))) + + (define (queue-empty? q) + (= (queue-size q) 0)) + + (define (queue-length q) + (queue-size q)) + + (define (enqueue! q val) + (let ((cell (list val))) + (if (null? (queue-tail q)) + (begin + (queue-head-set! q cell) + (queue-tail-set! q cell)) + (begin + (set-cdr! (queue-tail q) cell) + (queue-tail-set! q cell))) + (queue-size-set! q (+ (queue-size q) 1)))) + + (define (dequeue! q) + (when (queue-empty? q) + (error 'dequeue! "queue is empty")) + (let ((val (car (queue-head q)))) + (queue-head-set! q (cdr (queue-head q))) + (when (null? (queue-head q)) + (queue-tail-set! q '())) + (queue-size-set! q (- (queue-size q) 1)) + val)) + + (define (queue-peek q) + (when (queue-empty? q) + (error 'queue-peek "queue is empty")) + (car (queue-head q))) + + (define (queue->list q) + (list-copy (queue-head q))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/misc/repr.sls @@ -0,0 +1,48 @@ +#!chezscheme +;;; :std/misc/repr -- Object representation printing + +(library (std misc repr) + (export + repr + prn + pr + print-representation + display-separated + default-representation-options + current-representation-options) + + (import (chezscheme)) + + (define default-representation-options '()) + (define current-representation-options + (make-parameter default-representation-options)) + + (define (repr obj) + ;; Return a string representation of obj + (let ((port (open-output-string))) + (print-representation obj port) + (get-output-string port))) + + (define (pr obj . rest) + ;; Print representation to port (default current-output-port) + (let ((port (if (pair? rest) (car rest) (current-output-port)))) + (print-representation obj port))) + + (define (prn obj . rest) + ;; Print representation + newline + (let ((port (if (pair? rest) (car rest) (current-output-port)))) + (print-representation obj port) + (newline port))) + + (define (print-representation obj port) + (write obj port)) + + (define (display-separated lst . rest) + ;; Display items from lst separated by separator + (let ((sep (if (pair? rest) (car rest) " ")) + (port (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) (current-output-port)))) + (unless (null? lst) + (display (car lst) port) + (for-each (lambda (x) (display sep port) (display x port)) (cdr lst))))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/misc/thread.sls @@ -0,0 +1,298 @@ +#!chezscheme +;;; thread.sls -- Gambit thread API → Chez Scheme threads +;;; +;;; Gambit's thread model: +;;; (make-thread thunk [name]) → thread object (not started) +;;; (thread-start! thread) → starts the thread, returns thread +;;; (thread-join! thread) → waits for thread, returns result +;;; (thread-yield!) → yield current thread +;;; (thread-sleep! timeout) → sleep +;;; (current-thread) → current thread object +;;; +;;; Chez Scheme's thread model: +;;; (fork-thread thunk) → starts immediately, returns thread-id +;;; No explicit join in v9; thread-join in v10+ +;;; (get-thread-id) → current thread id (integer) +;;; Mutex: make-mutex, mutex-acquire, mutex-release +;;; Condition: make-condition, condition-wait, condition-signal, condition-broadcast + +(library (std misc thread) + (export + ;; Thread operations + make-thread thread-start! thread-join! + thread-yield! thread-sleep! + current-thread thread-name + thread? thread-specific thread-specific-set! + + ;; Mutex operations (Gambit API names) + make-mutex make-mutex-gambit mutex? mutex-name + mutex-lock! mutex-unlock! + mutex-specific mutex-specific-set! + + ;; Condition variable operations (Gambit API names) + make-condition-variable condition-variable? + condition-variable-signal! condition-variable-broadcast! + condition-variable-specific condition-variable-specific-set! + + ;; Mailbox (Gambit thread mailboxes) + thread-send thread-receive thread-mailbox-next + ) + + (import (except (chezscheme) + thread? ;; we define our own thread? for gerbil-thread + make-mutex mutex? mutex-name ;; we wrap with our own types + ) + (rename (only (chezscheme) make-mutex mutex? mutex-name) + (make-mutex chez:make-mutex) + (mutex? chez:mutex?) + (mutex-name chez:mutex-name))) + + ;;;; Thread wrapper + ;;;; Gambit threads are objects you create, then start. + ;;;; Chez threads start immediately on fork-thread. + ;;;; We wrap to provide the Gambit API. + + (define-record-type gerbil-thread + (fields + thunk ;; the procedure to run + (mutable name-val) ;; thread name (symbol or string) + (mutable chez-tid) ;; Chez thread id (set on start!) + (mutable result) ;; result value (set on completion) + (mutable exception) ;; exception (set on failure) + (mutable done?) ;; #t when finished + (mutable specific) ;; thread-specific storage + done-mutex ;; mutex for join synchronization + done-cond ;; condition for join notification + (mutable mailbox) ;; list of pending messages + mailbox-mutex ;; protects mailbox + mailbox-cond) ;; signal when message arrives + (sealed #t)) + + (define (make-thread thunk . name) + (make-gerbil-thread + thunk + (if (null? name) 'anonymous (car name)) + #f ;; chez-tid (not started) + (void) ;; result + #f ;; exception + #f ;; done? + (void) ;; specific + (chez:make-mutex) + (make-condition) + '() ;; mailbox + (chez:make-mutex) + (make-condition))) + + (define (thread? x) (gerbil-thread? x)) + (define (thread-name t) (gerbil-thread-name-val t)) + (define (thread-specific t) (gerbil-thread-specific t)) + (define (thread-specific-set! t v) (gerbil-thread-specific-set! t v)) + + ;; Thread-local storage for current gerbil-thread (no global lock!) + ;; make-thread-parameter is Chez's SMP-safe thread-local mechanism. + (define main-thread + (let ([t (make-thread (lambda () (void)) 'main)]) + (gerbil-thread-chez-tid-set! t (get-thread-id)) + t)) + + (define current-gerbil-thread (make-thread-parameter main-thread)) + + (define (current-thread) + (current-gerbil-thread)) + + (define (thread-start! t) + (let ([thunk (gerbil-thread-thunk t)]) + (fork-thread + (lambda () + ;; Set thread-local identity (no global lock needed) + (gerbil-thread-chez-tid-set! t (get-thread-id)) + (current-gerbil-thread t) + ;; Run the thunk + (guard (exn + [#t + (gerbil-thread-exception-set! t exn) + (gerbil-thread-done?-set! t #t) + (mutex-acquire (gerbil-thread-done-mutex t)) + (condition-broadcast (gerbil-thread-done-cond t)) + (mutex-release (gerbil-thread-done-mutex t))]) + (let ([result (thunk)]) + (gerbil-thread-result-set! t result) + (gerbil-thread-done?-set! t #t) + (mutex-acquire (gerbil-thread-done-mutex t)) + (condition-broadcast (gerbil-thread-done-cond t)) + (mutex-release (gerbil-thread-done-mutex t))))))) + t) + + (define (thread-join! t . timeout) + (let ([m (gerbil-thread-done-mutex t)] + [c (gerbil-thread-done-cond t)]) + (mutex-acquire m) + (let loop () + (cond + [(gerbil-thread-done? t) + (mutex-release m) + (if (gerbil-thread-exception t) + (raise (gerbil-thread-exception t)) + (gerbil-thread-result t))] + [else + (if (and (not (null? timeout)) (car timeout)) + ;; Timed wait + (let ([ns (inexact->exact + (floor (* (car timeout) 1000000000)))]) + (let ([abstime (make-time 'time-duration ns 0)]) + (condition-wait c m abstime)) + (mutex-release m) + (if (gerbil-thread-done? t) + (if (gerbil-thread-exception t) + (raise (gerbil-thread-exception t)) + (gerbil-thread-result t)) + (error 'thread-join! "timeout"))) + ;; Indefinite wait + (begin + (condition-wait c m) + (loop)))])))) + + (define (thread-yield!) + ;; Chez doesn't have an explicit yield; sleep briefly