Add (std gambit-compat) one-stop Gambit/Gerbil compat layer
ober
9b0dc2ab6b52ff99853f5300b516ea2096ba15d9
--- a/lib/jerboa/core.sls +++ b/lib/jerboa/core.sls @@ -707,8 +707,15 @@ (define (getenv name . rest) (or (%chez-getenv name) (if (pair? rest) (car rest) #f))) - ;; with-exception-catcher: Gerbil alias for Chez with-exception-handler - (define with-exception-catcher with-exception-handler) + ;; with-exception-catcher: Gambit-style handler that catches and escapes. + ;; Uses call/cc so the handler's return value becomes the overall result, + ;; instead of re-raising (which with-exception-handler does). + (define (with-exception-catcher handler thunk) + (call-with-current-continuation + (lambda (k) + (with-exception-handler + (lambda (e) (k (handler e))) + thunk)))) ;;;; ---- Gerbil compat: Filesystem ---- ;; create-directory: Gerbil alias for Chez mkdir @@ -838,7 +845,7 @@ (loop (+ i 1) (cdr l))))))) (define (subu8vector bv start end) (let* ((len (- end start)) (result (make-bytevector len))) - (bytevector-copy! result 0 bv start len) + (bytevector-copy! bv start result 0 len) result)) ;; object->string: convert any object to its write representation new file mode 100644 --- /dev/null +++ b/lib/std/gambit-compat.sls @@ -0,0 +1,445 @@ +#!chezscheme +;;; (std gambit-compat) — Gambit/Gerbil runtime compatibility for Chez Scheme +;;; +;;; One-stop import for porting Gerbil code to Jerboa. Re-exports everything +;;; from (jerboa core) and (std sugar), plus adds the remaining Gambit-isms +;;; that neither provides. +;;; +;;; Usage: (import (std gambit-compat)) +;;; +;;; This module exists so that every jerboa-* port doesn't need to write +;;; its own (compat gambit) shim. The canonical set of Gambit compatibility +;;; functions lives here. + +(library (std gambit-compat) + (export + ;; ---- Additional u8vector ops not in (jerboa core) ---- + u8vector? make-u8vector + u8vector-append u8vector-copy u8vector-copy! + open-input-u8vector open-output-u8vector get-output-u8vector + write-subu8vector read-subu8vector + + ;; ---- Additional f64vector ops ---- + f64vector->list + + ;; ---- Void ---- + void? + + ;; ---- Box type ---- + ;; Chez 10 has box/box?/unbox/set-box! built-in, re-export + box box? unbox set-box! + + ;; ---- Control flow ---- + let/cc + with-exception-catcher* ;; thunk-based alias (jerboa core has with-exception-catcher) + with-unwind-protect + + ;; ---- Time ---- + current-second + + ;; ---- Date formatting ---- + date->string* + + ;; ---- Environment ---- + getenv* ;; getenv with default arg (jerboa core's getenv already has this) + setenv* ;; alias for setenv + get-environment-variables + cpu-count + + ;; ---- Path/filesystem extras ---- + directory-files* ;; Gambit settings-list style + + ;; ---- Arithmetic compat ---- + truncate-quotient truncate-remainder + + ;; ---- Hash constructor macro ---- + hash-constructor + + ;; ---- Global-mutation parameterize ---- + gerbil-parameterize + + ;; ---- Pretty print alias ---- + pp + + ;; ---- Re-exports from (jerboa core) ---- + ;; Definitions + def def* defrule defrules + defstruct defclass defmethod + match + try catch finally + while until + hash hash-eq hash-literal hash-eq-literal let-hash + struct-out + + ;; I/O and filesystem + read-line read-string getenv force-output + read-u8 write-u8 + call-with-input-string call-with-output-string + display-exception display-continuation-backtrace + directory-files + create-directory create-directory* + + ;; u8vector / bytes / string + u8vector u8vector-ref u8vector-set! u8vector-length u8vector->list list->u8vector + subu8vector string->bytes bytes->string object->string string-map + string-split string-empty? string-subst + + ;; f64vector + f64vector-ref f64vector-set! f64vector-length make-f64vector + + ;; Threading + spawn spawn/name spawn/group + make-thread thread-start! thread-join! + thread-yield! thread-sleep! current-thread thread-name + thread? thread-specific thread-specific-set! + thread-interrupt! thread-terminate! + make-mutex make-mutex-gambit mutex? mutex-name + mutex-lock! mutex-unlock! mutex-specific mutex-specific-set! + make-condition-variable condition-variable? + condition-variable-signal! condition-variable-broadcast! + condition-variable-specific condition-variable-specific-set! + thread-send thread-receive thread-mailbox-next + + ;; Hash tables + make-hash-table make-hash-table-eq + hash-ref hash-get hash-put! hash-update! hash-remove! + hash-key? hash->list hash->plist hash-for-each hash-map hash-fold + hash-find hash-keys hash-values hash-copy hash-clear! + hash-merge hash-merge! hash-length hash-table? + list->hash-table plist->hash-table + + ;; Keywords + keyword? keyword->string string->keyword make-keyword keyword-arg-ref + + ;; Errors + error-message error-irritants error-trace + + ;; Path utilities + path-expand path-normalize path-directory + path-strip-directory path-extension path-strip-extension + path-strip-trailing-directory-separator + path-join path-absolute? + + ;; File info + with-exception-catcher + file-info file-info-type file-info-size file-info-mode + file-info-last-modification-time file-info-last-access-time + file-info-device file-info-inode file-info-owner file-info-group + + ;; Process + open-process open-input-process process-status + + ;; Misc + random-integer random-bytes copy-file setenv + user-info user-info-home user-name + filter-map displayln 1+ 1- + any every iota last-pair + arithmetic-shift + time->seconds + take drop delete last + input-port-timeout-set! output-port-timeout-set! + getpid + + ;; Method dispatch + ~ bind-method! call-method + *method-tables* + register-struct-type! *struct-types* + struct-predicate struct-field-ref struct-field-set! + struct-type-info + + ;; ---- Re-exports from (std sugar) ---- + unwind-protect + with-catch + cut cute <> <...> + chain chain-and with-id + assert! + with-lock + awhen aif when-let if-let + dotimes) + + (import (except (chezscheme) + make-hash-table hash-table? + iota 1+ 1- + getenv + path-extension path-absolute? + thread? make-mutex mutex? mutex-name) + (jerboa core) + (std sugar)) + + ;; ================================================================ + ;; Additional u8vector operations + ;; ================================================================ + + (define u8vector? bytevector?) + (define make-u8vector make-bytevector) + + (define (u8vector-append . bvs) + (let* ([total (apply + (map bytevector-length bvs))] + [result (make-bytevector total)]) + (let loop ([bvs bvs] [pos 0]) + (if (null? bvs) result + (let ([bv (car bvs)]) + (bytevector-copy! bv 0 result pos (bytevector-length bv)) + (loop (cdr bvs) (+ pos (bytevector-length bv)))))))) + + (define u8vector-copy bytevector-copy) + (define u8vector-copy! bytevector-copy!) + + ;; ---- open-input-u8vector ---- + ;; Gambit: (open-input-u8vector (list init: bv char-encoding: 'UTF-8)) + (define (open-input-u8vector props) + (let loop ([rest (if (list? props) props '())] + [init #f] [encoding 'UTF-8]) + (cond + [(null? rest) + (let* ([bv (or init (make-bytevector 0))] + [tc (make-transcoder + (case encoding + [(UTF-8 utf-8 utf8) (utf-8-codec)] + [(latin-1 ISO-8859-1 latin1) (latin-1-codec)] + [else (utf-8-codec)]))]) + (open-bytevector-input-port bv tc))] + [(and (pair? (cdr rest)) (memq (car rest) '(init init:))) + (loop (cddr rest) (cadr rest) encoding)] + [(and (pair? (cdr rest)) (memq (car rest) '(char-encoding char-encoding:))) + (loop (cddr rest) init (cadr rest))] + [else (loop (cdr rest) init encoding)]))) + + ;; ---- open-output-u8vector / get-output-u8vector ---- + (define *u8vec-extractors* (make-weak-eq-hashtable)) + + (define (open-output-u8vector . _) + (let ([chunks '()]) + (let* ([write-str! + (lambda (str start count) + (let* ([sub (if (and (= start 0) (= count (string-length str))) + str (substring str start (+ start count)))] + [bv (string->utf8 sub)]) + (set! chunks (cons bv chunks))) + count)] + [port (make-custom-textual-output-port + "u8vector-output" + write-str! + #f #f #f)] + [extract + (lambda () + (flush-output-port port) + (let* ([all (reverse chunks)] + [total (apply + (map bytevector-length all))] + [result (make-bytevector total)]) + (let loop ([pos 0] [cs all]) + (if (null? cs) result + (let ([bv (car cs)]) + (bytevector-copy! bv 0 result pos (bytevector-length bv)) + (loop (+ pos (bytevector-length bv)) (cdr cs)))))))]) + (hashtable-set! *u8vec-extractors* port extract) + port))) + + (define (get-output-u8vector port) + (let ([extract (hashtable-ref *u8vec-extractors* port #f)]) + (if extract (extract) + (error 'get-output-u8vector "not a u8vector output port" port)))) + + ;; ---- write-subu8vector / read-subu8vector ---- + (define (write-subu8vector bv start end . port-opt) + (let ([port (if (pair? port-opt) (car port-opt) (current-output-port))]) + (if (binary-port? port) + (put-bytevector port bv start (- end start)) + (display (utf8->string (subu8vector bv start end)) port)))) + + (define (read-subu8vector bv start end . port-opt) + (let ([port (if (pair? port-opt) (car port-opt) (current-input-port))]) + (if (binary-port? port) + (let ([n (get-bytevector-n! port bv start (- end start))]) + (if (eof-object? n) 0 n)) + (let loop ([i start]) + (if (>= i end) (- i start) + (let ([ch (get-char port)]) + (if (eof-object? ch) (- i start) + (begin + (bytevector-u8-set! bv i (char->integer ch)) + (loop (+ i 1)))))))))) + + ;; ================================================================ + ;; Additional f64vector operations + ;; ================================================================ + + (define (f64vector->list fv) + (let loop ([i 0] [acc '()]) + (if (= i (flvector-length fv)) + (reverse acc) + (loop (+ i 1) (cons (flvector-ref fv i) acc))))) + + ;; ================================================================ + ;; Void + ;; ================================================================ + + (define (void? x) (eq? x (void))) + + ;; ================================================================ + ;; Control flow + ;; ================================================================ + + (define-syntax let/cc + (syntax-rules () + [(_ k body ...) + (call-with-current-continuation + (lambda (k) body ...))])) + + ;; Thunk-based alias — same as with-exception-catcher from core + (define (with-exception-catcher* handler thunk) + (with-exception-catcher handler thunk)) + + (define (with-unwind-protect body-thunk cleanup-thunk) + (dynamic-wind + (lambda () (void)) + body-thunk + cleanup-thunk)) + + ;; ================================================================ + ;; Time + ;; ================================================================ + + (define (current-second) + (time->seconds (current-time 'time-utc))) + + ;; ================================================================ + ;; Date formatting (SRFI-19 subset) + ;; ================================================================ + + (define (date->string* date fmt) + (let ([out (open-output-string)] + [len (string-length fmt)]) + (let loop ([i 0]) + (when (< i len) + (let ([c (string-ref fmt i)]) + (if (and (char=? c #\~) (< (+ i 1) len)) + (let ([d (string-ref fmt (+ i 1))]) + (case d + [(#\Y) (display (date-year date) out)] + [(#\m) (let ([m (date-month date)]) + (when (< m 10) (display #\0 out)) + (display m out))] + [(#\d) (let ([day (date-day date)]) + (when (< day 10) (display #\0 out)) + (display day out))] + [(#\H) (let ([h (date-hour date)]) + (when (< h 10) (display #\0 out)) + (display h out))] + [(#\M) (let ([min (date-minute date)]) + (when (< min 10) (display #\0 out)) + (display min out))] + [(#\S) (let ([s (date-second date)]) + (when (< s 10) (display #\0 out)) + (display s out))] + [(#\Z) (let* ([off (date-zone-offset date)] + [sign (if (< off 0) "-" "+")] + [abs-off (abs off)] + [hours (quotient abs-off 3600)] + [mins (quotient (remainder abs-off 3600) 60)]) + (display sign out) + (when (< hours 10) (display #\0 out)) + (display hours out) + (when (< mins 10) (display #\0 out)) + (display mins out))] + [else (display c out)]) + (loop (+ i 2))) + (begin (display c out) (loop (+ i 1))))))) + (get-output-string out))) + + ;; ================================================================ + ;; Environment extras + ;; ================================================================ + + ;; getenv* with optional default (Gambit-style) + ;; Note: (jerboa core)'s getenv already supports optional default, + ;; but this provides a distinctly-named version for clarity. + (define (getenv* name . default) + (or (getenv name) + (if (pair? default) (car default) #f))) + + (define setenv* setenv) + + (define (get-environment-variables) + (guard (exn [#t '()]) + (let ([bv (call-with-port (open-file-input-port "/proc/self/environ") + (lambda (p) (get-bytevector-all p)))]) + (if (eof-object? bv) '() + (let ([str (bytevector->string bv (make-transcoder (utf-8-codec)))]) + (let loop ([i 0] [start 0] [vars '()]) + (cond + [(>= i (string-length str)) (reverse vars)] + [(char=? (string-ref str i) #\nul) + (let* ([entry (substring str start i)] + [eq-pos (let find ([j 0]) + (if (>= j (string-length entry)) #f + (if (char=? (string-ref entry j) #\=) j + (find (+ j 1)))))]) + (loop (+ i 1) (+ i 1) + (if eq-pos + (cons (cons (substring entry 0 eq-pos) + (substring entry (+ eq-pos 1) (string-length entry))) + vars) + vars)))] + [else (loop (+ i 1) start vars)]))))))) + + (define cpu-count + (let ([cached + (guard (exn [#t 1]) + (let ([c-sysconf (foreign-procedure "sysconf" (int) long)]) + (let ([result (c-sysconf 84)]) + (if (> result 0) result 1))))]) + (lambda () cached))) + + ;; ================================================================ + ;; Path/filesystem extras + ;; ================================================================ + + ;; Gambit-style directory-files with settings list + ;; Returns empty list on error (non-existent dir, permission denied) + (define (directory-files* path-or-settings) + (let ([path (if (pair? path-or-settings) + (let loop ([s path-or-settings]) + (cond + [(null? s) "."] + [(and (pair? (cdr s)) (memq (car s) '(path path:))) (cadr s)] + [else (loop (cdr s))])) + path-or-settings)]) + (guard (exn [#t '()]) + (directory-files path)))) + + ;; ================================================================ + ;; Arithmetic compat + ;; ================================================================ + + (define truncate-quotient quotient) + (define truncate-remainder remainder) + + ;; ================================================================ + ;; Hash constructor macro + ;; ================================================================ + + (define-syntax hash-constructor + (syntax-rules () + [(_ (key val) ...) + (let ([ht (make-hash-table)]) + (hash-put! ht key val) ... + ht)])) + + ;; ================================================================ + ;; Gerbil-parameterize (global mutation, not thread-local) + ;; ================================================================ + + (define-syntax gerbil-parameterize + (syntax-rules () + [(_ () body ...) (let () body ...)] + [(_ ((p v) ...) body ...) + (begin (p v) ... body ...)])) + + ;; ================================================================ + ;; Pretty print alias + ;; ================================================================ + + (define pp pretty-print) + +) ;; end library --- a/lib/std/sugar.sls +++ b/lib/std/sugar.sls @@ -13,7 +13,7 @@ assert! with-lock with-catch - cut cute + cut cute <> <...> ;; Anaphoric macros awhen aif ;; Binding macros @@ -131,6 +131,10 @@ (lambda (e) (k (%apply1 handler e))) thunk)))) + ;; Auxiliary syntax for cut/cute slot markers (must be exported for cross-module use) + (define-syntax <> (lambda (x) (syntax-violation '<> "misuse of auxiliary syntax" x))) + (define-syntax <...> (lambda (x) (syntax-violation '<...> "misuse of auxiliary syntax" x))) + ;; cut / cute — SRFI-26 partial application ;; (cut f <> y) → (lambda (x) (f x y)) ;; (cute f <> y) → (let ([t y]) (lambda (x) (f x t))) new file mode 100644 --- /dev/null +++ b/tests/test-gambit-compat.ss @@ -0,0 +1,332 @@ +#!chezscheme +;;; Tests for (std gambit-compat) — Gambit/Gerbil runtime compatibility + +(import (except (chezscheme) + make-hash-table hash-table? iota 1+ 1- getenv + path-extension path-absolute? + thread? make-mutex mutex? mutex-name + box box? unbox set-box!) + (std gambit-compat)) + +(define pass-count 0) +(define fail-count 0) + +(define-syntax check + (syntax-rules (=>) + [(_ expr => expected) + (let ([result expr] + [exp expected]) + (if (equal? result exp) + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (printf "FAIL: ~s => ~s (expected ~s)~n" 'expr result exp))))])) + +(define-syntax check-true + (syntax-rules () + [(_ expr) + (let ([result expr]) + (if result + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (printf "FAIL: ~s => ~s (expected truthy)~n" 'expr result))))])) + +(define-syntax check-false + (syntax-rules () + [(_ expr) + (let ([result expr]) + (if (not result) + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (printf "FAIL: ~s => ~s (expected falsy)~n" 'expr result))))])) + +(define (string-contains* haystack needle) + (let ([hn (string-length haystack)] + [nn (string-length needle)]) + (let loop ([i 0]) + (cond + [(> (+ i nn) hn) #f] + [(string=? (substring haystack i (+ i nn)) needle) #t] + [else (loop (+ i 1))])))) + +(printf "--- Testing (std gambit-compat) ---~n") + +;; ========== u8vector ========== +(printf " u8vector aliases...~n") +(let ([bv (make-u8vector 4 0)]) + (check (u8vector? bv) => #t) + (check (u8vector-length bv) => 4) + (u8vector-set! bv 0 65) + (u8vector-set! bv 1 66) + (check (u8vector-ref bv 0) => 65) + (check (u8vector-ref bv 1) => 66)) + +(let ([bv (u8vector 1 2 3 4 5)]) + (check (u8vector-length bv) => 5) + (check (u8vector-ref bv 0) => 1) + (check (u8vector-ref bv 4) => 5) + (check (u8vector->list bv) => '(1 2 3 4 5))) + +(check (u8vector->list (list->u8vector '(10 20 30))) => '(10 20 30)) + +;; subu8vector +(let ([bv (u8vector 10 20 30 40 50)]) + (check (u8vector->list (subu8vector bv 1 4)) => '(20 30 40))) + +;; u8vector-append +(let ([a (u8vector 1 2)] [b (u8vector 3 4 5)]) + (check (u8vector->list (u8vector-append a b)) => '(1 2 3 4 5))) +(check (u8vector->list (u8vector-append)) => '()) + +;; ========== f64vector ========== +(printf " f64vector aliases...~n") +(let ([fv (make-f64vector 3 1.5)]) + (check (f64vector-ref fv 0) => 1.5) + (check (f64vector-length fv) => 3) + (f64vector-set! fv 1 2.5) + (check (f64vector-ref fv 1) => 2.5) + (check (f64vector->list fv) => '(1.5 2.5 1.5))) + +;; ========== string/bytes ========== +(printf " string/bytes conversion...~n") +(let ([bv (string->bytes "hello")]) + (check (bytevector? bv) => #t) + (check (bytes->string bv) => "hello")) + +(check (object->string 42) => "42") +(check (object->string '(a b)) => "(a b)") + +;; ========== void? ========== +(printf " void?...~n") +(check-true (void? (void))) +(check-false (void? 42)) +(check-false (void? #f)) + +;; ========== box ========== +(printf " box type...~n") +(let ([b (box 42)]) + (check-true (box? b)) + (check (unbox b) => 42) + (set-box! b 99) + (check (unbox b) => 99)) +(check-false (box? 42)) + +;; ========== random-integer ========== +(printf " random-integer...~n") +(let ([r (random-integer 100)]) + (check-true (and (>= r 0) (< r 100)))) + +;; ========== let/cc ========== +(printf " let/cc...~n") +(check (let/cc k (k 42) 99) => 42) +(check (let/cc k (+ 1 2)) => 3) + +;; ========== with-exception-catcher ========== +(printf " with-exception-catcher...~n") +(check (with-exception-catcher + (lambda (e) 'caught) + (lambda () (error 'test "boom"))) + => 'caught) +(check (with-exception-catcher + (lambda (e) 'caught) + (lambda () 42)) + => 42) + +;; Also test with-exception-catcher* (alias) +(check (with-exception-catcher* + (lambda (e) 'got-it) + (lambda () (/ 1 0))) + => 'got-it) + +;; ========== with-unwind-protect ========== +(printf " with-unwind-protect...~n") +(let ([cleaned #f]) + (with-unwind-protect + (lambda () 42) + (lambda () (set! cleaned #t))) + (check-true cleaned)) + +;; ========== call-with-input/output-string ========== +(printf " call-with-input/output-string...~n") +(check (call-with-input-string "(+ 1 2)" + (lambda (p) (read p))) + => '(+ 1 2)) + +(check (call-with-output-string + (lambda (p) (display "hello" p) (display " world" p))) + => "hello world") + +;; ========== read-line ========== +(printf " read-line...~n") +(let ([p (open-input-string "line1\nline2\nline3")]) + (check (read-line p) => "line1") + (check (read-line p) => "line2") + (check (read-line p) => "line3")) + +;; ========== force-output ========== +(printf " force-output...~n") +;; Just verify it doesn't error +(force-output) +(set! pass-count (+ pass-count 1)) + +;; ========== write-u8 ========== +(printf " write-u8...~n") +;; Test on a binary port +(let-values ([(port getter) (open-bytevector-output-port)]) + (write-u8 65 port) + (write-u8 66 port) + (let ([bv (getter)]) + (check (bytevector-u8-ref bv 0) => 65) + (check (bytevector-u8-ref bv 1) => 66))) + +;; ========== display-exception ========== +(printf " display-exception...~n") +(let ([out (with-output-to-string + (lambda () + (display-exception "test error" (current-output-port))))]) + (check-true (> (string-length out) 0))) + +;; ========== time->seconds / current-second ========== +(printf " time->seconds / current-second...~n") +(let ([t (current-time 'time-utc)]) + (let ([s (time->seconds t)]) + (check-true (and (number? s) (> s 0))))) +(let ([s (current-second)]) + (check-true (and (number? s) (> s 1000000000)))) +;; Non-time passthrough +(check (time->seconds 42) => 42) + +;; ========== date->string* ========== +(printf " date->string*...~n") +(let ([d (current-date)]) + (let ([s (date->string* d "~Y-~m-~d ~H:~M:~S")]) + (check-true (> (string-length s) 10)) + ;; Should contain the year + (check-true (string-contains* s (number->string (date-year d)))))) + +;; ========== getenv* / setenv* ========== +(printf " getenv* / setenv*...~n") +(check-true (string? (getenv* "HOME"))) +(check (getenv* "NONEXISTENT_VAR_XYZ_12345") => #f) +(check (getenv* "NONEXISTENT_VAR_XYZ_12345" "default") => "default") + +(setenv* "JERBOA_TEST_VAR" "hello") +(check (getenv* "JERBOA_TEST_VAR") => "hello") + +;; ========== user-name ========== +(printf " user-name...~n") +(check-true (string? (user-name))) + +;; ========== get-environment-variables ========== +(printf " get-environment-variables...~n") +(let ([vars (get-environment-variables)]) + (check-true (list? vars)) + ;; Should have at least some env vars + (check-true (> (length vars) 0)) + ;; Each entry should be a pair + (check-true (pair? (car vars))) + ;; HOME should be in there + (check-true (assoc "HOME" vars))) + +;; ========== cpu-count ========== +(printf " cpu-count...~n") +(check-true (and (integer? (cpu-count)) (> (cpu-count) 0))) + +;; ========== directory-files ========== +(printf " directory-files...~n") +(let ([files (directory-files ".")]) + (check-true (list? files)) + (check-true (> (length files) 0))) + +;; Gambit-style settings list +(let ([files (directory-files* (list 'path: "."))]) + (check-true (list? files)) + (check-true (> (length files) 0))) + +;; Non-existent directory → empty list +(check (directory-files* "/nonexistent_xyz_12345") => '()) + +;; ========== truncate-quotient / truncate-remainder / arithmetic-shift ========== +(printf " arithmetic compat...~n") +(check (truncate-quotient 7 2) => 3) +(check (truncate-remainder 7 2) => 1) +(check (arithmetic-shift 1 4) => 16) +(check (arithmetic-shift 16 -2) => 4) + +;; ========== hash-constructor ========== +(printf " hash-constructor...~n") +(let ([ht (hash-constructor ("name" "Alice") ("age" 30))]) + (check (hash-ref ht "name") => "Alice") + (check (hash-ref ht "age") => 30)) + +;; ========== gerbil-parameterize ========== +(printf " gerbil-parameterize...~n") +(define test-param (make-parameter 0)) +(gerbil-parameterize ((test-param 42)) + (check (test-param) => 42)) +;; Value persists after gerbil-parameterize exits (global mutation) +(check (test-param) => 42) + +;; ========== spawn / thread basics ========== +(printf " spawn / threading...~n") +(let ([result-box (box #f)]) + (let ([t (spawn (lambda () (set-box! result-box 'done)))]) + (thread-join! t) + (check (unbox result-box) => 'done))) + +(let ([result-box (box #f)]) + (let ([t (spawn/name "test-thread" + (lambda () (set-box! result-box (thread-name (current-thread)))))]) + (thread-join! t) + (check (unbox result-box) => "test-thread"))) + +;; thread-sleep! +(let ([start (current-second)]) + (thread-sleep! 0.05) + (let ([elapsed (- (current-second) start)]) + (check-true (>= elapsed 0.04)))) + +;; ========== with-catch (re-exported from sugar) ========== +(printf " with-catch...~n") +(check (with-catch + (lambda (e) 'caught) + (lambda () (error 'test "oops"))) + => 'caught) + +;; ========== cut / cute (re-exported from sugar) ========== +(printf " cut/cute...~n") +(check ((cut + <> 10) 5) => 15) +(check ((cut * <> <>) 3 4) => 12) +(check ((cute + <> 10) 5) => 15) + +;; ========== open-input/output-u8vector ========== +(printf " u8vector ports...~n") +(let ([bv (u8vector 104 101 108 108 111)]) ;; "hello" in ASCII + (let ([p (open-input-u8vector (list 'init: bv))]) + (check (read-line p) => "hello"))) + +(let ([p (open-output-u8vector)]) + (display "hi" p) + (let ([bv (get-output-u8vector p)]) + (check (bytes->string bv) => "hi"))) + +;; ========== write-subu8vector / read-subu8vector ========== +(printf " write-subu8vector / read-subu8vector...~n") +(let-values ([(out getter) (open-bytevector-output-port)]) + (let ([bv (u8vector 65 66 67 68 69)]) ;; ABCDE + (write-subu8vector bv 1 4 out) + (let ([result (getter)]) + (check (bytevector-length result) => 3) + (check (bytevector-u8-ref result 0) => 66) ;; B + (check (bytevector-u8-ref result 2) => 68)))) ;; D + +;; ========== pp ========== +(printf " pp...~n") +(let ([out (with-output-to-string (lambda () (pp '(a b c))))]) + (check-true (> (string-length out) 0))) + +;; ========== Summary ========== +(printf "~n--- Results: ~a passed, ~a failed ---~n" pass-count fail-count) +(when (> fail-count 0) (exit 1))