Add path utils, interface, generic, markup alias; enhance process & temporaries
ober
835cbf3fd3059faa9ff965f9da4f2f594fbb75ed
new file mode 100644 --- /dev/null +++ b/docs/import-conflicts.md @@ -0,0 +1,127 @@ +# Jerboa Import Conflict Reference + +When porting Gerbil code to Jerboa (stock Chez Scheme), name collisions between +`(chezscheme)`, `(jerboa core)`, and `(std ...)` modules are the #1 source of +friction. This document lists every known conflict and shows how to resolve it. + +## Quick Fix: Use `(std gambit-compat)` + +For most ports, importing `(std gambit-compat)` is the easiest path. It +re-exports everything from `(jerboa core)` and `(std sugar)`, plus additional +Gambit compatibility functions. You only need to exclude the Chez names it +overrides: + +```scheme +(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)) +``` + +## Conflict Matrix + +### (chezscheme) vs (jerboa core) + +| Symbol | Chez Behavior | Jerboa Core Behavior | Resolution | +|--------|--------------|---------------------|------------| +| `make-hash-table` | R6RS hashtable | Gerbil-style string-keyed hash | `(except (chezscheme) make-hash-table)` | +| `hash-table?` | R6RS predicate | Gerbil hash predicate | `(except (chezscheme) hash-table?)` | +| `iota` | `(iota n)` only | SRFI-1: `(iota count [start [step]])` | `(except (chezscheme) iota)` | +| `1+` / `1-` | Chez `1+`/`1-` | Same semantics, re-exported | `(except (chezscheme) 1+ 1-)` | +| `getenv` | Returns string or `#f` | Same + optional default arg | `(except (chezscheme) getenv)` | +| `path-extension` | Returns `""` for no ext | Returns `#f` for no ext | `(except (chezscheme) path-extension)` | +| `path-absolute?` | Chez version | Gerbil-style version | `(except (chezscheme) path-absolute?)` | +| `thread?` | Chez thread predicate | Gerbil thread predicate | `(except (chezscheme) thread?)` | +| `make-mutex` | Chez `make-mutex` | Gerbil `make-mutex` | `(except (chezscheme) make-mutex)` | +| `mutex?` | Chez predicate | Gerbil predicate | `(except (chezscheme) mutex?)` | +| `mutex-name` | Chez accessor | Gerbil accessor | `(except (chezscheme) mutex-name)` | +| `box` / `box?` / `unbox` / `set-box!` | Chez 10 built-in | Re-exported cleanly | `(except (chezscheme) box box? unbox set-box!)` | +| `sort` | `(sort pred lst)` | `(sort lst pred)` — arg order swapped | `(except (chezscheme) sort)` | +| `format` | `(format fmt args...)` — no port | Gerbil: `(format fmt args...)` | Usually compatible | + +### (chezscheme) vs (std sugar) + +| Symbol | Conflict | Resolution | +|--------|----------|------------| +| None currently | `(std sugar)` avoids Chez name collisions | Direct import safe | + +### (chezscheme) vs (std format) + +| Symbol | Conflict | Resolution | +|--------|----------|------------| +| `format` | Chez: `(format str args...)` returns string | Use Gerbil's or exclude Chez's | +| `printf` | Chez: has `printf` | Gerbil's may differ | +| `fprintf` | Chez: has `fprintf` | Gerbil's may differ | + +### (chezscheme) vs (std srfi srfi-1) + +| Symbol | Conflict | Resolution | +|--------|----------|------------| +| `iota` | Different signature | SRFI-1 excludes it from Chez | + +### (jerboa core) vs (std misc string) + +Both export string utilities. `(jerboa core)` re-exports many string functions. +If using both: + +```scheme +(import (except (std misc string) + string-split string-join string-index string-trim string-prefix?) + (jerboa core)) +``` + +### (jerboa core) vs (std misc list) + +Both export list utilities. If using both: + +```scheme +(import (except (std misc list) + any every take drop filter-map) + (jerboa core)) +``` + +## Common Import Templates + +### Minimal (just Chez + Gerbil compat) +```scheme +(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)) +``` + +### Full stdlib access +```scheme +(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) + (std iter) + (std srfi srfi-1) + (std srfi srfi-13) + (std text json)) +``` + +### Test file template +```scheme +(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) + (std test)) +``` + +## Tips + +1. **Start with `(std gambit-compat)`** — it handles most conflicts automatically +2. **Add `(except ...)` for Chez names** that collide — the list above is comprehensive +3. **Import specific modules after** `gambit-compat` — they'll override with Gerbil-compatible versions +4. **When in doubt**, check which version you want with `scheme --libdirs lib -q` and test interactively new file mode 100644 --- /dev/null +++ b/lib/std/generic.sls @@ -0,0 +1,62 @@ +#!chezscheme +;;; :std/generic -- Generic functions with type-based dispatch + +(library (std generic) + (export defgeneric defspecific generic-dispatch) + (import (chezscheme)) + + ;; Return a type key for dispatch + (define (type-of obj) + (cond + ((and (record? obj) (record-rtd obj)) => (lambda (rtd) rtd)) + ((string? obj) 'string) + ((number? obj) 'number) + ((pair? obj) 'pair) + ((vector? obj) 'vector) + ((symbol? obj) 'symbol) + ((boolean? obj) 'boolean) + ((char? obj) 'char) + ((bytevector? obj) 'bytevector) + ((port? obj) 'port) + ((procedure? obj) 'procedure) + ((null? obj) 'null) + (else 'other))) + + (define (generic-dispatch table name-str obj rest) + (let ((impl (hashtable-ref table (type-of obj) #f))) + (if impl + (apply impl obj rest) + (error name-str "no method for type" (type-of obj) obj)))) + + ;; (defgeneric name (first-arg rest-arg ...)) + ;; Defines name as a generic function and name-table as its dispatch table. + (define-syntax defgeneric + (lambda (stx) + (syntax-case stx () + [(_ name (first-arg rest-arg ...)) + (with-syntax ([tbl (datum->syntax #'name + (string->symbol + (string-append (symbol->string (syntax->datum #'name)) + "-table")))]) + #'(begin + (define tbl (make-eq-hashtable)) + (define (name first-arg rest-arg ...) + (generic-dispatch tbl + (symbol->string 'name) + first-arg + (list rest-arg ...)))))]))) + + ;; (defspecific (name (first-arg type-expr) rest-arg ...) body ...) + (define-syntax defspecific + (lambda (stx) + (syntax-case stx () + [(_ (name (first-arg type-expr) rest-arg ...) body ...) + (with-syntax ([tbl (datum->syntax #'name + (string->symbol + (string-append (symbol->string (syntax->datum #'name)) + "-table")))]) + #'(hashtable-set! tbl + type-expr + (lambda (first-arg rest-arg ...) body ...)))]))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/interface.sls @@ -0,0 +1,100 @@ +#!chezscheme +;;; :std/interface -- Simple interface protocol system +;;; +;;; Provides a minimal interface system compatible with Gerbil usage: +;;; (definterface Name (method1 method2 ...)) +;;; → defines record type, constructor, accessor, and predicate +;;; +;;; (interface-satisfies? iface type-name) +;;; → #t if type-name has all methods of iface registered +;;; +;;; Methods are registered in a global hash table keyed by +;;; (type-name . method-name) symbols. Actual method registration +;;; is done by defmethod (provided by jerboa core), which should +;;; call (interface-register-method! type-name method-name) when +;;; defining a method. + +(library (std interface) + (export + definterface + make-interface + interface-name + interface-method-names + interface-satisfies? + interface-register-method! + interface-has-method?) + + (import (chezscheme)) + + ;; ========== Method registry ========== + + ;; Global registry: type-name → set of method-name symbols + ;; Outer: eq-hashtable (type-name → inner hashtable) + ;; Inner: eq-hashtable (method-name → #t) + (define *method-registry* (make-eq-hashtable)) + + (define (interface-register-method! type-name method-name) + (let ([methods (hashtable-ref *method-registry* type-name #f)]) + (if methods + (hashtable-set! methods method-name #t) + (let ([ht (make-eq-hashtable)]) + (hashtable-set! ht method-name #t) + (hashtable-set! *method-registry* type-name ht))))) + + (define (interface-has-method? type-name method-name) + (let ([methods (hashtable-ref *method-registry* type-name #f)]) + (and methods (hashtable-ref methods method-name #f)))) + + ;; ========== Interface record type ========== + + (define-record-type interface-type + (fields + (immutable name) + (immutable method-names)) + (protocol + (lambda (new) + (lambda (name method-names) + (new name method-names))))) + + (define (make-interface name method-names) + (make-interface-type name method-names)) + (define (interface-name i) (interface-type-name i)) + (define (interface-method-names i) (interface-type-method-names i)) + + ;; ========== Satisfaction check ========== + + (define (interface-satisfies? iface type-name) + "Return #t if type-name has all methods required by iface registered." + (let loop ((methods (interface-method-names iface))) + (cond + ((null? methods) #t) + ((interface-has-method? type-name (car methods)) + (loop (cdr methods))) + (else #f)))) + + ;; ========== definterface macro ========== + + ;; (definterface Name (method1 method2 ...)) + ;; + ;; Expands to: + ;; - a module-level variable Name holding the interface record + ;; - a predicate Name? that checks interface-satisfies? for a given type-name + ;; + ;; Usage: + ;; (definterface Printable (print to-string)) + ;; (Printable? 'my-type) => #t if my-type registered print and to-string + + (define-syntax definterface + (lambda (stx) + (syntax-case stx () + [(_ Name (method ...)) + (with-syntax ([Name? (datum->syntax #'Name + (string->symbol + (string-append (symbol->string (syntax->datum #'Name)) "?")))]) + #'(begin + (define Name + (make-interface 'Name '(method ...))) + (define (Name? type-name) + (interface-satisfies? Name type-name))))]))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/markup/xml.sls @@ -0,0 +1,11 @@ +#!chezscheme +;;; :std/markup/xml -- alias for (std text xml) + +(library (std markup xml) + (export + write-xml print-sxml->xml + sxml-e sxml-attributes sxml-attribute-e sxml-children) + + (import (std text xml)) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/misc/path.sls @@ -0,0 +1,99 @@ +#!chezscheme +(library (std misc path) + (export + path-default-extension + path-normalize + path-relative? + path-split + subpath) + (import (chezscheme)) + + ;; Add extension to path only if it doesn't already have one. + ;; ext should include the leading dot, e.g. ".scm" + (define (path-default-extension path ext) + (let ([current (path-extension path)]) + (if (and current (not (string=? current ""))) + path + (let ([ext* (if (and (> (string-length ext) 0) + (not (char=? (string-ref ext 0) #\.))) + (string-append "." ext) + ext)]) + (string-append path ext*))))) + + ;; Resolve . and .. components in a path string. + (define (path-normalize path) + (let* ([absolute? (and (> (string-length path) 0) + (char=? (string-ref path 0) #\/))] + [parts (path-split path)] + [resolved + (let loop ([parts parts] [acc '()]) + (cond + [(null? parts) (reverse acc)] + [(string=? (car parts) ".") + (loop (cdr parts) acc)] + [(string=? (car parts) "..") + (if (null? acc) + (loop (cdr parts) (if absolute? '() (list ".."))) + (loop (cdr parts) (cdr acc)))] + [else + (loop (cdr parts) (cons (car parts) acc))]))]) + (cond + [(null? resolved) + (if absolute? "/" ".")] + [absolute? + (string-append "/" (apply string-append + (let loop ([parts resolved]) + (if (null? (cdr parts)) + (list (car parts)) + (cons (car parts) + (cons "/" (loop (cdr parts))))))))] + [else + (apply string-append + (let loop ([parts resolved]) + (if (null? (cdr parts)) + (list (car parts)) + (cons (car parts) + (cons "/" (loop (cdr parts)))))))]))) + + ;; #t if path does not start with / + (define (path-relative? path) + (or (string=? path "") + (not (char=? (string-ref path 0) #\/)))) + + ;; Split a path string into a list of non-empty components. + ;; Leading / is dropped (use path-relative? to detect absolute paths). + (define (path-split path) + (let loop ([chars (string->list path)] [current '()] [acc '()]) + (cond + [(null? chars) + (let ([parts (reverse + (if (null? current) + acc + (cons (list->string (reverse current)) acc)))]) + (filter (lambda (s) (not (string=? s ""))) parts))] + [(char=? (car chars) #\/) + (if (null? current) + (loop (cdr chars) '() acc) + (loop (cdr chars) '() (cons (list->string (reverse current)) acc)))] + [else + (loop (cdr chars) (cons (car chars) current) acc)]))) + + ;; Join base path with additional parts using "/" separators. + ;; Trims trailing slashes from base and leading slashes from each part. + (define (subpath base . parts) + (define (trim-trailing-slash s) + (let ([len (string-length s)]) + (if (and (> len 0) (char=? (string-ref s (- len 1)) #\/)) + (substring s 0 (- len 1)) + s))) + (define (trim-leading-slash s) + (if (and (> (string-length s) 0) (char=? (string-ref s 0) #\/)) + (substring s 1 (string-length s)) + s)) + (let loop ([parts parts] [result (trim-trailing-slash base)]) + (if (null? parts) + result + (loop (cdr parts) + (string-append result "/" (trim-leading-slash (trim-trailing-slash (car parts)))))))) + +) ; end library --- a/lib/std/misc/process.sls +++ b/lib/std/misc/process.sls @@ -16,7 +16,11 @@ process-port-status process-port-rec-stdin-port process-port-rec-stdout-port - process-port-rec-stderr-port) + process-port-rec-stderr-port + + ;; Process control + process-kill + tty?) (import (chezscheme)) @@ -213,4 +217,30 @@ (close-port from-stderr) result)))) + ;; ========== Process Control ========== + + (define _libc-loaded + (let ((v (getenv "JEMACS_STATIC"))) + (if (and v (not (string=? v "")) (not (string=? v "0"))) + #f + (load-shared-object "libc.so.6")))) + + (define c-kill (foreign-procedure "kill" (int int) int)) + (define c-isatty (foreign-procedure "isatty" (int) int)) + + ;; Send a signal to a process. Default signal is SIGTERM (15). + (define process-kill + (case-lambda + [(pid) (process-kill pid 15)] + [(pid sig) (c-kill pid sig)])) + + ;; Check if a port (or fd number) is connected to a terminal + (define (tty? x) + (cond + [(fixnum? x) (= (c-isatty x) 1)] + [(eq? x (current-input-port)) (= (c-isatty 0) 1)] + [(eq? x (current-output-port)) (= (c-isatty 1) 1)] + [(eq? x (current-error-port)) (= (c-isatty 2) 1)] + [else #f])) + ) ;; end library --- a/lib/std/net/request.sls +++ b/lib/std/net/request.sls @@ -11,7 +11,9 @@ request-headers request-header request-close parse-url url-parts-scheme url-parts-host url-parts-port url-parts-path url-encode build-query-string - flatten-request-headers) + flatten-request-headers + headers->alist + alist->headers) (import (chezscheme) (std net tcp)) @@ -250,6 +252,22 @@ [(char-whitespace? (string-ref str i)) (loop (+ i 1))] [else (substring str i len)])))) + ;; Convert "Name: Value" strings to alist + (define (headers->alist header-strings) + (map (lambda (s) + (let ([colon-pos (string-find s #\:)]) + (if colon-pos + (cons (substring s 0 colon-pos) + (string-trim-left (substring s (+ colon-pos 1) (string-length s)))) + (cons s "")))) + header-strings)) + + ;; Convert alist to "Name: Value" strings + (define (alist->headers alist) + (map (lambda (p) + (string-append (car p) ": " (cdr p))) + alist)) + (define (string-join lst sep) (cond [(null? lst) ""] --- a/lib/std/os/temporaries.sls +++ b/lib/std/os/temporaries.sls @@ -2,7 +2,11 @@ ;;; :std/os/temporaries -- Temporary file utilities (library (std os temporaries) - (export make-temporary-file-name with-temporary-file) + (export make-temporary-file-name + with-temporary-file + with-temporary-directory + create-temporary-file + temporary-file-directory) (import (chezscheme)) @@ -21,6 +25,10 @@ (set! *temp-counter* (+ *temp-counter* 1)) (format "~a/~a-~a-~a" dir prefix (getpid) *temp-counter*))) + ;; Parameter for temp directory (respects TMPDIR) + (define temporary-file-directory + (make-parameter (or (getenv "TMPDIR") "/tmp"))) + (define (with-temporary-file proc . rest) (let ((name (apply make-temporary-file-name rest))) (dynamic-wind @@ -28,4 +36,29 @@ (lambda () (proc name)) (lambda () (when (file-exists? name) (delete-file name)))))) + ;; Create a temporary file and return (values path port) + (define (create-temporary-file . rest) + (let ((name (apply make-temporary-file-name rest))) + (let ((port (open-output-file name))) + (values name port)))) + + ;; Scoped temporary directory with recursive cleanup + (define (with-temporary-directory proc . rest) + (let ((dir (apply make-temporary-file-name rest))) + (mkdir dir) + (dynamic-wind + (lambda () #f) + (lambda () (proc dir)) + (lambda () (rm-rf dir))))) + + (define (rm-rf path) + (when (file-exists? path) + (if (file-directory? path) + (begin + (for-each (lambda (f) + (rm-rf (string-append path "/" f))) + (directory-list path)) + (delete-directory path)) + (delete-file path)))) + ) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-newer-batch2.ss @@ -0,0 +1,149 @@ +#!chezscheme +;;; Tests for newer batch 2: path, interface, generic, process, temporaries, markup/xml + +(import (chezscheme) + (std misc path) + (std interface) + (std generic) + (std os temporaries)) + +(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))))])) + +(printf "--- Testing newer batch 2 ---~n") + +;; ========== Path Utilities ========== +(printf " Path utilities...~n") +(check (path-split "/usr/local/bin") => '("usr" "local" "bin")) +(check (path-split "foo/bar/baz") => '("foo" "bar" "baz")) +(check (path-split "/") => '()) + +(check (path-normalize "/usr/local/../bin") => "/usr/bin") +(check (path-normalize "/usr/./bin") => "/usr/bin") +(check (path-normalize "a/b/../c") => "a/c") + +(check-true (path-relative? "foo/bar")) +(check-false (path-relative? "/foo/bar")) + +(check (subpath "/usr" "local" "bin") => "/usr/local/bin") +(check (subpath "a" "b" "c") => "a/b/c") + +(check (path-default-extension "foo" ".txt") => "foo.txt") +(check (path-default-extension "foo.pdf" ".txt") => "foo.pdf") +(check (path-default-extension "foo" "txt") => "foo.txt") + +;; ========== Interface Protocol ========== +(printf " Interface protocol...~n") +(definterface Printable (to-string describe)) +(check-true (not (null? (interface-method-names Printable)))) +(check (interface-name Printable) => 'Printable) +(check (interface-method-names Printable) => '(to-string describe)) + +;; Before registering methods +(check-false (Printable? 'my-type)) + +;; Register methods +(interface-register-method! 'my-type 'to-string) +(interface-register-method! 'my-type 'describe) +(check-true (Printable? 'my-type)) + +;; Partial implementation +(interface-register-method! 'partial-type 'to-string) +(check-false (Printable? 'partial-type)) + +;; ========== Generic Functions ========== +(printf " Generic functions...~n") +(defgeneric greet (obj)) +(defspecific (greet (obj 'string)) (string-append "Hello, " obj "!")) +(defspecific (greet (obj 'number)) (string-append "Number " (number->string obj))) +(defspecific (greet (obj 'symbol)) (string-append "Symbol: " (symbol->string obj))) + +(check (greet "world") => "Hello, world!") +(check (greet 42) => "Number 42") +(check (greet 'foo) => "Symbol: foo") + +;; Multi-arg generic +(defgeneric combine (a b)) +(defspecific (combine (a 'string) b) (string-append a (if (string? b) b (format "~a" b)))) +(defspecific (combine (a 'number) b) (+ a (if (number? b) b 0))) +(check (combine "hello" " world") => "hello world") +(check (combine 10 20) => 30) + +;; ========== Temporaries ========== +(printf " Temporaries...~n") +(let ([name (make-temporary-file-name)]) + (check-true (string? name)) + (check-true (> (string-length name) 0))) + +(with-temporary-file + (lambda (path) + (check-true (string? path)) + (let ([port (open-output-file path)]) + (display "test" port) + (close-port port)) + (check-true (file-exists? path)))) + +(with-temporary-directory + (lambda (dir) + (check-true (file-directory? dir)) + ;; Create a file inside + (let ([f (string-append dir "/test.txt")]) + (let ([port (open-output-file f)]) + (display "hello" port) + (close-port port)) + (check-true (file-exists? f))))) + +(check-true (string? (temporary-file-directory))) + +(let-values ([(path port) (create-temporary-file)]) + (check-true (string? path)) + (check-true (output-port? port)) + (display "test" port) + (close-port port) + (check-true (file-exists? path)) + (delete-file path)) + +;; ========== Markup XML Alias ========== +(printf " Markup XML alias...~n") +;; Just verify the module loads (it re-exports from std text xml) +;; Import it in a guard since it depends on std text xml +(guard (exn [#t (printf " (skipped - std text xml unavailable)~n")]) + (eval '(begin + (import (std markup xml)) + (set! pass-count (+ pass-count 1)))) + (set! pass-count (+ pass-count 1))) + +;; ========== Summary ========== +(printf "~n--- Results: ~a passed, ~a failed ---~n" pass-count fail-count) +(when (> fail-count 0) (exit 1))