Add parser combinators, SRFI bundle, and source translator
ober
413b2e5b36c09931e5a22163e4a4381b690ee33b
new file mode 100644 --- /dev/null +++ b/lib/jerboa/translator.sls @@ -0,0 +1,458 @@ +#!chezscheme +;;; (jerboa translator) — Gerbil-to-Jerboa Source Translator Utilities +;;; +;;; String-level transforms: translate-keywords, translate-brackets, +;;; translate-hash-bang +;;; S-expr transforms: translate-defstruct, translate-let-hash, +;;; translate-using, translate-parameterize +;;; File-level: translate-file, translate-imports +;;; Pipeline: make-translator, default-transforms + +(library (jerboa translator) + (export + ;; String-level transforms + translate-keywords + translate-brackets + translate-hash-bang + + ;; S-expr transforms + translate-defstruct + translate-let-hash + translate-using + translate-parameterize + translate-imports + + ;; File-level operations + translate-file + + ;; Transform pipeline + make-translator + default-transforms) + + (import (chezscheme)) + + ;; ========== String Helpers ========== + + (define (string-has-prefix? str prefix) + (let ([slen (string-length str)] + [plen (string-length prefix)]) + (and (>= slen plen) + (string=? (substring str 0 plen) prefix)))) + + (define (string-has-suffix? str suffix) + (let ([slen (string-length str)] + [suflen (string-length suffix)]) + (and (>= slen suflen) + (string=? (substring str (- slen suflen) slen) suffix)))) + + ;; Find substring, return index or #f + (define (string-search str sub start) + (let ([slen (string-length str)] + [sublen (string-length sub)]) + (if (> sublen slen) + #f + (let loop ([i start]) + (cond + [(> (+ i sublen) slen) #f] + [(let check ([j 0]) + (cond + [(= j sublen) #t] + [(char=? (string-ref str (+ i j)) (string-ref sub j)) + (check (+ j 1))] + [else #f])) + i] + [else (loop (+ i 1))]))))) + + ;; Simple text replacement (all occurrences) + (define (string-replace-all str from to) + (let ([flen (string-length from)]) + (if (= flen 0) + str + (let loop ([i 0] [acc '()]) + (let ([hit (string-search str from i)]) + (if hit + (loop (+ hit flen) + (cons to (cons (substring str i hit) acc))) + (let ([tail (substring str i (string-length str))]) + (apply string-append (reverse (cons tail acc)))))))))) + + ;; ========== Character classification ========== + + (define (word-char? ch) + (or (char-alphabetic? ch) (char-numeric? ch) + (char=? ch #\-) (char=? ch #\_) (char=? ch #\?) + (char=? ch #\!) (char=? ch #\/) (char=? ch #\*) + (char=? ch #\+) (char=? ch #\<) (char=? ch #\>) + (char=? ch #\=) (char=? ch #\.) (char=? ch #\@) + (char=? ch #\^) (char=? ch #\~) (char=? ch #\%))) + + ;; Is character at position i inside a string literal? + ;; Simple scan from start (does not handle nested/escaped properly for + ;; all edge cases, but covers the common case). + (define (in-string-at? str i) + (let loop ([j 0] [in-str #f]) + (cond + [(= j i) in-str] + [(and (not in-str) (char=? (string-ref str j) #\")) + (loop (+ j 1) #t)] + [(and in-str (char=? (string-ref str j) #\\)) + (loop (+ j 2) #t)] ;; skip escaped char + [(and in-str (char=? (string-ref str j) #\")) + (loop (+ j 1) #f)] + [else + (loop (+ j 1) in-str)]))) + + ;; ========== String-level Transformations ========== + + ;; translate-keywords: #:foo → 'foo: + ;; Scans for #: followed by an identifier and replaces with 'sym: + (define (translate-keywords str) + (let ([len (string-length str)]) + (let loop ([i 0] [acc '()]) + (cond + [(>= i len) + (apply string-append (reverse acc))] + ;; Look for #: that is NOT inside a string + [(and (< (+ i 1) len) + (char=? (string-ref str i) #\#) + (char=? (string-ref str (+ i 1)) #\:) + (not (in-string-at? str i))) + ;; Collect the keyword name + (let kloop ([j (+ i 2)]) + (cond + [(>= j len) + ;; End of string: emit 'name: from i+2..j + (let ([name (substring str (+ i 2) j)]) + (loop j (cons (string-append "'" name ":") acc)))] + [(word-char? (string-ref str j)) + (kloop (+ j 1))] + [else + (let ([name (substring str (+ i 2) j)]) + (if (string=? name "") + ;; Bare #: — leave it alone + (loop (+ i 2) (cons "#:" acc)) + (loop j (cons (string-append "'" name ":") acc))))]))] + [else + (loop (+ i 1) (cons (string (string-ref str i)) acc))])))) + + ;; translate-hash-bang: #!void → (void), #!eof → (eof-object), + ;; #!optional/#!rest/#!key → Chez equivalents + ;; Also handles #!chezscheme / #!r6rs directives (leave them as-is). + (define (translate-hash-bang str) + (define replacements + '(("#!void" . "(void)") + ("#!eof" . "(eof-object)") + ("#!optional" . "#!optional") ;; Chez already understands these + ("#!rest" . "#!rest") + ("#!key" . "#!key") + ("#!default" . "#!default") + ("#!unbound" . "(error \"unbound\")") )) + (let loop ([s str] [repls replacements]) + (if (null? repls) + s + (loop (string-replace-all s (caar repls) (cdar repls)) + (cdr repls))))) + + ;; translate-brackets: [x y z] → (list x y z) when NOT in binding position. + ;; + ;; Strategy: scan the string maintaining a context stack. Each open-paren + ;; pushes the keyword that started the form (or 'other). When we see `[`, + ;; if the innermost paren context is a binding-form, the bracket is in + ;; binding position — keep as-is. Otherwise convert to (list ...). + ;; + ;; This correctly handles multi-clause let: (let ([x 1] [y 2]) ...) + ;; because both brackets share the same parent paren context "let". + ;; + ;; This is necessarily heuristic at the string level. For perfectly correct + ;; output, use translate-file which processes s-expressions directly. + (define (translate-brackets str) + (define binding-forms + '("let" "let*" "letrec" "letrec*" "letrec-values" + "let-values" "let*-values" "fluid-let" + "lambda" "case-lambda" "do" + "define" "define-syntax" "define-record-type" + "syntax-rules" "syntax-case" + "cond" "case" "match")) + + ;; Collect the word token starting at position i+1 (after an open paren), + ;; skipping leading whitespace. Returns "" if no word follows immediately. + (define (token-after-open s i) + (let ([len (string-length s)]) + (let skip ([j (+ i 1)]) + (cond + [(>= j len) ""] + [(char-whitespace? (string-ref s j)) (skip (+ j 1))] + [(word-char? (string-ref s j)) + (let scan ([k j]) + (if (and (< k len) (word-char? (string-ref s k))) + (scan (+ k 1)) + (substring s j k)))] + [else ""])))) + + (define (binding-form? token) + (member token binding-forms)) + + ;; pctx-stack: list of 'binding | 'other pushed per open-paren + ;; bracket-stack: list of 'binder | 'list pushed per open-bracket + (let ([len (string-length str)]) + (let loop ([i 0] [acc '()] [pctx '()] [bstk '()]) + (cond + [(>= i len) + (apply string-append (reverse acc))] + [(in-string-at? str i) + (loop (+ i 1) (cons (string (string-ref str i)) acc) pctx bstk)] + ;; Open paren: push context + [(char=? (string-ref str i) #\() + (let ([tok (token-after-open str i)]) + (loop (+ i 1) (cons "(" acc) + (cons (if (binding-form? tok) 'binding 'other) pctx) + bstk))] + ;; Close paren: pop context + [(char=? (string-ref str i) #\)) + (loop (+ i 1) (cons ")" acc) + (if (null? pctx) '() (cdr pctx)) + bstk)] + ;; Open bracket + [(char=? (string-ref str i) #\[) + (let ([in-binding? (and (not (null? pctx)) + (eq? (car pctx) 'binding))]) + (loop (+ i 1) + (cons (if in-binding? "[" "(list ") acc) + pctx + (cons (if in-binding? 'binder 'list) bstk)))] + ;; Close bracket + [(char=? (string-ref str i) #\]) + (if (null? bstk) + (loop (+ i 1) (cons "]" acc) pctx bstk) + (let ([kind (car bstk)]) + (loop (+ i 1) + (cons (if (eq? kind 'binder) "]" ")") acc) + pctx + (cdr bstk))))] + [else + (loop (+ i 1) (cons (string (string-ref str i)) acc) + pctx bstk)])))) + + ;; ========== S-expr Transformations ========== + + ;; translate-defstruct: (defstruct name (field ...)) + ;; → (define-record-type name + ;; (fields field ...) + ;; (sealed #f)) + ;; Also handles (defstruct (name parent) (field ...)) — ignores parent for + ;; R6RS (parent inheritance syntax differs). + (define (translate-defstruct form) + (if (and (pair? form) (eq? (car form) 'defstruct)) + (let* ([head (cadr form)] + [name (if (pair? head) (car head) head)] + [parent (if (pair? head) (cadr head) #f)] + [fields (if (null? (cddr form)) '() (caddr form))] + ;; Normalise field specs: bare symbol or (sym default) → sym + [field-names + (map (lambda (f) (if (pair? f) (car f) f)) fields)] + [record-def + `(define-record-type ,name + (fields ,@field-names) + (sealed #f))]) + (if parent + `(begin ,record-def + ;; NOTE: parent ,parent not wired — R6RS parent syntax differs + ) + record-def)) + form)) + + ;; translate-let-hash: (let-hash h body ...) + ;; → (let ([.field (hash-ref h 'field)] ...) body ...) + ;; Because we cannot statically know which fields are used, we emit an + ;; accessor helper instead and let the body use (hash-ref h 'key). + ;; For a richer transform the caller should use the runtime let-hash macro. + ;; Here we just pass through — let-hash is provided by (jerboa prelude). + (define (translate-let-hash form) + ;; let-hash is handled by the prelude macro; return unchanged. + form) + + ;; translate-using: (using (obj type) body ...) + ;; → (let ([obj obj]) body ...) ; method dispatch handled at runtime + ;; The `using` form in Gerbil binds obj and opens its namespace. + ;; We emit a plain let; method calls like {method obj} still work via ~. + (define (translate-using form) + (if (and (pair? form) (eq? (car form) 'using) + (pair? (cadr form))) + (let* ([binding (cadr form)] + [obj-name (car binding)] + ;; type annotation ignored — no static dispatch in Jerboa + [body (cddr form)]) + `(let ([,obj-name ,obj-name]) ,@body)) + form)) + + ;; translate-parameterize: (parameterize ((p v) ...) body ...) + ;; Gerbil parameterize is the same as R6RS/Chez parameterize — pass through. + (define (translate-parameterize form) + form) + + ;; translate-imports: convert a Gerbil (import ...) form. + ;; :std/foo/bar → (std foo bar) + ;; :gerbil/gambit → (jerboa core) + ;; :gerbil/gambit/XX → (jerboa core) + ;; :foo/bar → (foo bar) (generic) + ;; (only-in :mod sym ...) → (only (mod ...) sym ...) + ;; (except-in :mod sym ...) → (except (mod ...) sym ...) + ;; (rename-in :mod (old new) ...) → (rename (mod ...) (old new) ...) + ;; (prefix-in :mod pfx) → (prefix (mod ...) pfx) + (define (translate-imports form) + (define (module-spec->r6rs spec) + (cond + ;; Already a list (R6RS style) + [(pair? spec) spec] + ;; Symbol starting with : + [(and (symbol? spec) + (let ([s (symbol->string spec)]) + (string-has-prefix? s ":"))) + (let ([s (symbol->string spec)]) + (let ([path (substring s 1 (string-length s))]) + ;; Split by / + (let ([parts (string-split-by path #\/)]) + (cond + ;; :gerbil/gambit* → (jerboa core) + [(string=? (car parts) "gerbil") + '(jerboa core)] + ;; :std/... → (std ...) + [(string=? (car parts) "std") + (cons 'std (map string->symbol (cdr parts)))] + ;; :jerboa/... → (jerboa ...) + [(string=? (car parts) "jerboa") + (cons 'jerboa (map string->symbol (cdr parts)))] + ;; generic :foo/bar → (foo bar) + [else + (map string->symbol parts)]))))] + [else spec])) + + (define (transform-import-clause clause) + (cond + [(pair? clause) + (case (car clause) + [(only-in) + `(only ,(module-spec->r6rs (cadr clause)) ,@(cddr clause))] + [(except-in) + `(except ,(module-spec->r6rs (cadr clause)) ,@(cddr clause))] + [(rename-in) + `(rename ,(module-spec->r6rs (cadr clause)) ,@(cddr clause))] + [(prefix-in) + `(prefix ,(module-spec->r6rs (cadr clause)) ,(caddr clause))] + [else + ;; Already a list spec like (std foo bar) + clause])] + [else + (module-spec->r6rs clause)])) + + (if (and (pair? form) (eq? (car form) 'import)) + `(import ,@(map transform-import-clause (cdr form))) + form)) + + ;; String split by character + (define (string-split-by str ch) + (let ([len (string-length str)]) + (let loop ([i 0] [start 0] [acc '()]) + (cond + [(= i len) + (reverse (cons (substring str start i) acc))] + [(char=? (string-ref str i) ch) + (loop (+ i 1) (+ i 1) (cons (substring str start i) acc))] + [else + (loop (+ i 1) start acc)])))) + + ;; ========== Recursive S-expr Walk ========== + + ;; Apply a list of s-expr transforms to a form recursively. + ;; Each transform is a procedure (form → form). + (define (walk-transform form transforms) + (let ([form* (let loop ([ts transforms] [f form]) + (if (null? ts) + f + (loop (cdr ts) ((car ts) f))))]) + (if (pair? form*) + (cons (walk-transform (car form*) transforms) + (walk-transform (cdr form*) transforms)) + form*))) + + ;; ========== Transform Pipeline ========== + + ;; make-translator: compose a chain of transforms into a single procedure. + ;; Each transform is either: + ;; - a procedure (datum → datum) applied after reading, or + ;; - a pair (string-transform . sexpr-transform) for mixed pipelines. + ;; For simplicity, make-translator takes s-expr transforms. + (define (make-translator . transforms) + (lambda (form) + (walk-transform form transforms))) + + ;; default-transforms: the standard set of s-expr transforms. + (define (default-transforms) + (list translate-defstruct + translate-let-hash + translate-using + translate-parameterize + translate-imports)) + + ;; ========== String-level Pipeline ========== + + ;; Apply all string transforms in order. + (define (apply-string-transforms str) + (translate-hash-bang + (translate-keywords str))) + ;; Note: translate-brackets is intentionally NOT in the default pipeline + ;; because bracket handling is done properly at the s-expr level via the + ;; (jerboa reader). Callers can opt-in explicitly. + + ;; ========== File-level Operation ========== + + ;; translate-file: read a Gerbil .ss file, apply transforms, write .sls. + ;; Optional `transforms` argument is a list of s-expr transform procedures. + ;; If omitted, (default-transforms) is used. + ;; + ;; The output file is wrapped in a (library ...) form when the source + ;; contains a (package: ...) or (export ...) declaration, otherwise the + ;; top-level forms are emitted directly. + (define translate-file + (case-lambda + [(input-path output-path) + (translate-file input-path output-path (default-transforms))] + [(input-path output-path transforms) + ;; 1. Read raw text and apply string-level transforms + (let* ([raw (call-with-input-file input-path + (lambda (p) (read-string-all p)))] + [cooked (apply-string-transforms raw)]) + ;; 2. Parse the transformed text into s-expressions + (let* ([forms (read-all-from-string cooked)] + ;; 3. Apply s-expr transforms + [translator (apply make-translator transforms)] + [translated (map translator forms)]) + ;; 4. Write to output with pretty-print + (call-with-output-file output-path + (lambda (out) + (display "#!chezscheme\n" out) + (for-each + (lambda (f) + (pretty-print f out) + (newline out)) + translated)) + 'replace)))])) + + ;; Read all forms from a string. + (define (read-all-from-string str) + (let ([p (open-input-string str)]) + (let loop ([acc '()]) + (let ([f (read p)]) + (if (eof-object? f) + (reverse acc) + (loop (cons f acc))))))) + + ;; Read entire port as a string. + (define (read-string-all port) + (let loop ([acc '()]) + (let ([ch (read-char port)]) + (if (eof-object? ch) + (list->string (reverse acc)) + (loop (cons ch acc)))))) + +) ;; end library (jerboa translator) new file mode 100644 --- /dev/null +++ b/lib/std/parser.sls @@ -0,0 +1,217 @@ +#!chezscheme +(library (std parser) + (export + ;; Core types + make-parse-result parse-result-value parse-result-rest parse-result? + make-parse-failure parse-failure-message parse-failure-position parse-failure? + parse-success? + + ;; Base parsers + parse-char + parse-literal + parse-eof + parse-satisfy + parse-any-char + + ;; Combinators + parse-seq + parse-alt + parse-many + parse-many1 + parse-optional + parse-between + parse-sep-by + parse-map + + ;; Running + parse-string + parse-string*) + + (import (chezscheme)) + + ;;; ------------------------------------------------------------------------- + ;;; Core record types + ;;; ------------------------------------------------------------------------- + + (define-record-type parse-result + (fields value rest)) + + (define-record-type parse-failure + (fields message position)) + + ;; Alias: parse-success? is the same predicate as parse-result? + (define parse-success? parse-result?) + + ;;; ------------------------------------------------------------------------- + ;;; Base parsers + ;;; + ;;; A parser is a procedure: (lambda (str pos) -> parse-result | parse-failure) + ;;; where str is the input string and pos is the current index (fixnum). + ;;; ------------------------------------------------------------------------- + + ;; Match a single character satisfying predicate pred. + (define (parse-char pred) + (lambda (str pos) + (if (< pos (string-length str)) + (let ((c (string-ref str pos))) + (if (pred c) + (make-parse-result c (+ pos 1)) + (make-parse-failure + (string-append "unexpected character: " + (string c)) + pos))) + (make-parse-failure "unexpected end of input" pos)))) + + ;; Alias for parse-char. + (define parse-satisfy parse-char) + + ;; Match any single character. + (define (parse-any-char) + (parse-char (lambda (c) #t))) + + ;; Match the exact string literal lit. + (define (parse-literal lit) + (let ((len (string-length lit))) + (lambda (str pos) + (let ((end (+ pos len))) + (if (and (<= end (string-length str)) + (string=? lit (substring str pos end))) + (make-parse-result lit end) + (make-parse-failure + (string-append "expected literal: " lit) + pos)))))) + + ;; Match end of input. + (define (parse-eof) + (lambda (str pos) + (if (= pos (string-length str)) + (make-parse-result 'eof pos) + (make-parse-failure "expected end of input" pos)))) + + ;;; ------------------------------------------------------------------------- + ;;; Combinators + ;;; ------------------------------------------------------------------------- + + ;; Run parsers in sequence; return a list of their results. + ;; Returns a failure as soon as any parser fails. + (define (parse-seq . parsers) + (lambda (str pos) + (let loop ((ps parsers) (pos pos) (acc '())) + (if (null? ps) + (make-parse-result (reverse acc) pos) + (let ((r ((car ps) str pos))) + (if (parse-failure? r) + r + (loop (cdr ps) + (parse-result-rest r) + (cons (parse-result-value r) acc)))))))) + + ;; Try each parser in order; return the first success. + ;; Returns the failure from the last parser if all fail. + (define (parse-alt . parsers) + (lambda (str pos) + (let loop ((ps parsers) (last-fail #f)) + (if (null? ps) + (or last-fail + (make-parse-failure "no alternatives" pos)) + (let ((r ((car ps) str pos))) + (if (parse-result? r) + r + (loop (cdr ps) r))))))) + + ;; Zero or more repetitions of parser p; always succeeds. + (define (parse-many p) + (lambda (str pos) + (let loop ((pos pos) (acc '())) + (let ((r (p str pos))) + (if (parse-failure? r) + (make-parse-result (reverse acc) pos) + (loop (parse-result-rest r) + (cons (parse-result-value r) acc))))))) + + ;; One or more repetitions of parser p; fails if p doesn't match at least once. + (define (parse-many1 p) + (lambda (str pos) + (let ((first (p str pos))) + (if (parse-failure? first) + first + (let loop ((pos (parse-result-rest first)) + (acc (list (parse-result-value first)))) + (let ((r (p str pos))) + (if (parse-failure? r) + (make-parse-result (reverse acc) pos) + (loop (parse-result-rest r) + (cons (parse-result-value r) acc))))))))) + + ;; Zero or one occurrence of p; returns default if p fails (without consuming input). + (define (parse-optional p default) + (lambda (str pos) + (let ((r (p str pos))) + (if (parse-failure? r) + (make-parse-result default pos) + r)))) + + ;; Parse p bracketed by open and close parsers; returns value of p. + (define (parse-between open close p) + (lambda (str pos) + (let ((r-open (open str pos))) + (if (parse-failure? r-open) + r-open + (let ((r-p (p str (parse-result-rest r-open)))) + (if (parse-failure? r-p) + r-p + (let ((r-close (close str (parse-result-rest r-p)))) + (if (parse-failure? r-close) + r-close + (make-parse-result (parse-result-value r-p) + (parse-result-rest r-close)))))))))) + + ;; Parse one or more occurrences of p separated by sep. + ;; Returns a list of p's values (sep values are discarded). + (define (parse-sep-by p sep) + (lambda (str pos) + (let ((first (p str pos))) + (if (parse-failure? first) + ;; Zero occurrences — return empty list as success. + (make-parse-result '() pos) + (let loop ((pos (parse-result-rest first)) + (acc (list (parse-result-value first)))) + (let ((r-sep (sep str pos))) + (if (parse-failure? r-sep) + (make-parse-result (reverse acc) pos) + (let ((r-p (p str (parse-result-rest r-sep)))) + (if (parse-failure? r-p) + ;; sep matched but p did not — do not consume sep + (make-parse-result (reverse acc) pos) + (loop (parse-result-rest r-p) + (cons (parse-result-value r-p) acc))))))))))) + + ;; Transform the successful result of p with function f. + (define (parse-map p f) + (lambda (str pos) + (let ((r (p str pos))) + (if (parse-failure? r) + r + (make-parse-result (f (parse-result-value r)) + (parse-result-rest r)))))) + + ;;; ------------------------------------------------------------------------- + ;;; Running + ;;; ------------------------------------------------------------------------- + + ;; Run parser on string str starting at position 0. + ;; Returns the parse-result on success or raises an error on failure. + ;; Non-throwing: returns parse-result or parse-failure + (define (parse-string* parser str) + (parser str 0)) + + ;; Throwing: raises error on failure + (define (parse-string parser str) + (let ((r (parser str 0))) + (if (parse-failure? r) + (error 'parse-string + (parse-failure-message r) + (parse-failure-position r)) + r))) + +) ;; end library (std parser) new file mode 100644 --- /dev/null +++ b/lib/std/srfi/srfi-128.sls @@ -0,0 +1,111 @@ +#!chezscheme +;;; :std/srfi/128 -- Comparators (SRFI-128) +;;; Provides comparator objects for use with sorted containers. + +(library (std srfi srfi-128) + (export + make-comparator comparator? + comparator-type-test-predicate + comparator-equality-predicate + comparator-ordering-predicate + comparator-hash-function + comparator-ordered? comparator-hashable? + comparator-test-type comparator-check-type + comparator-hash + =? <? >? <=? >=? + make-default-comparator + default-hash + boolean-comparator char-comparator + string-comparator number-comparator + symbol-comparator) + + (import (chezscheme)) + + (define-record-type comparator-rec + (fields + (immutable type-test) + (immutable equality) + (immutable ordering) + (immutable hash-fn)) + (sealed #t)) + + (define (make-comparator type-test equality ordering hash-fn) + (make-comparator-rec + (or type-test (lambda (x) #t)) + (or equality equal?) + ordering + hash-fn)) + + (define (comparator? x) (comparator-rec? x)) + + (define (comparator-type-test-predicate c) (comparator-rec-type-test c)) + (define (comparator-equality-predicate c) (comparator-rec-equality c)) + (define (comparator-ordering-predicate c) (comparator-rec-ordering c)) + (define (comparator-hash-function c) (comparator-rec-hash-fn c)) + + (define (comparator-ordered? c) + (and (comparator-rec-ordering c) #t)) + (define (comparator-hashable? c) + (and (comparator-rec-hash-fn c) #t)) + + (define (comparator-test-type c obj) + ((comparator-rec-type-test c) obj)) + (define (comparator-check-type c obj) + (unless ((comparator-rec-type-test c) obj) + (error 'comparator-check-type "type test failed" obj))) + + (define (comparator-hash c obj) + (if (comparator-rec-hash-fn c) + ((comparator-rec-hash-fn c) obj) + (error 'comparator-hash "comparator has no hash function"))) + + (define (=? c a b) ((comparator-rec-equality c) a b)) + (define (<? c a b) ((comparator-rec-ordering c) a b)) + (define (>? c a b) ((comparator-rec-ordering c) b a)) + (define (<=? c a b) (or (=? c a b) (<? c a b))) + (define (>=? c a b) (or (=? c a b) (>? c a b))) + + (define (default-hash obj) + (cond + [(string? obj) (string-hash obj)] + [(number? obj) (equal-hash obj)] + [(symbol? obj) (symbol-hash obj)] + [(char? obj) (char->integer obj)] + [(boolean? obj) (if obj 1 0)] + [else (equal-hash obj)])) + + (define (make-default-comparator) + (make-comparator + (lambda (x) #t) + equal? + (lambda (a b) + (cond + [(and (number? a) (number? b)) (< a b)] + [(and (string? a) (string? b)) (string<? a b)] + [(and (char? a) (char? b)) (char<? a b)] + [(and (symbol? a) (symbol? b)) + (string<? (symbol->string a) (symbol->string b))] + [else (string<? (format "~s" a) (format "~s" b))])) + default-hash)) + + (define boolean-comparator + (make-comparator boolean? boolean=? + (lambda (a b) (and (not a) b)) + (lambda (x) (if x 1 0)))) + + (define char-comparator + (make-comparator char? char=? char<? char->integer)) + + (define string-comparator + (make-comparator string? string=? string<? string-hash)) + + (define number-comparator + (make-comparator number? = < equal-hash)) + + (define symbol-comparator + (make-comparator symbol? eq? + (lambda (a b) + (string<? (symbol->string a) (symbol->string b))) + symbol-hash)) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/srfi/srfi-141.sls @@ -0,0 +1,75 @@ +#!chezscheme +;;; :std/srfi/141 -- Integer Division (SRFI-141) +;;; Chez Scheme provides most of these operations natively. + +(library (std srfi srfi-141) + (export + floor/ + floor-quotient floor-remainder + truncate/ + truncate-quotient truncate-remainder + ceiling/ + ceiling-quotient ceiling-remainder + round/ + round-quotient round-remainder + euclidean/ + euclidean-quotient euclidean-remainder + balanced/ + balanced-quotient balanced-remainder) + + (import (chezscheme)) + + ;; Floor division (like Python's //) + (define (floor/ n d) + (values (floor-quotient n d) (floor-remainder n d))) + (define (floor-quotient n d) + (floor (/ n d))) + (define (floor-remainder n d) + (- n (* d (floor-quotient n d)))) + + ;; Truncate division (like C's /) + (define (truncate/ n d) + (values (truncate-quotient n d) (truncate-remainder n d))) + (define (truncate-quotient n d) + (truncate (/ n d))) + (define (truncate-remainder n d) + (- n (* d (truncate-quotient n d)))) + + ;; Ceiling division + (define (ceiling/ n d) + (values (ceiling-quotient n d) (ceiling-remainder n d))) + (define (ceiling-quotient n d) + (ceiling (/ n d))) + (define (ceiling-remainder n d) + (- n (* d (ceiling-quotient n d)))) + + ;; Round division + (define (round/ n d) + (values (round-quotient n d) (round-remainder n d))) + (define (round-quotient n d) + (round (/ n d))) + (define (round-remainder n d) + (- n (* d (round-quotient n d)))) + + ;; Euclidean division (remainder always non-negative) + (define (euclidean/ n d) + (values (euclidean-quotient n d) (euclidean-remainder n d))) + (define (euclidean-quotient n d) + (let ([q (floor-quotient n d)] + [r (floor-remainder n d)]) + (if (negative? r) + (if (positive? d) (+ q 1) (- q 1)) + q))) + (define (euclidean-remainder n d) + (let ([r (floor-remainder n d)]) + (if (negative? r) (+ r (abs d)) r))) + + ;; Balanced division (remainder in [-|d/2|, |d/2|)) + (define (balanced/ n d) + (values (balanced-quotient n d) (balanced-remainder n d))) + (define (balanced-quotient n d) + (round-quotient n d)) + (define (balanced-remainder n d) + (round-remainder n d)) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/srfi/srfi-43.sls @@ -0,0 +1,157 @@ +#!chezscheme +;;; :std/srfi/43 -- Vector Library (SRFI-43 subset) +;;; Chez Scheme provides most vector operations natively. +;;; This module provides the remaining SRFI-43 functions. + +(library (std srfi srfi-43) + (export + vector-unfold vector-unfold-right + vector-copy! vector-reverse-copy! + vector-append + vector-concatenate + vector-empty? + vector-count + vector-index vector-index-right + vector-skip vector-skip-right + vector-any vector-every + vector-swap! + vector-reverse! + vector-fold vector-fold-right + vector-map! vector-for-each) + + (import (except (chezscheme) vector-copy! vector-append)) + + (define (vector-unfold f len . seeds) + (let ([v (make-vector len)] + [seed (if (pair? seeds) (car seeds) 0)]) + (let loop ([i 0] [s seed]) + (if (= i len) v + (call-with-values + (lambda () (f i s)) + (lambda (val . rest) + (vector-set! v i val) + (loop (+ i 1) (if (pair? rest) (car rest) (+ s 1))))))))) + + (define (vector-unfold-right f len . seeds) + (let ([v (make-vector len)] + [seed (if (pair? seeds) (car seeds) 0)]) + (let loop ([i (- len 1)] [s seed]) + (if (< i 0) v + (call-with-values + (lambda () (f i s)) + (lambda (val . rest) + (vector-set! v i val) + (loop (- i 1) (if (pair? rest) (car rest) (+ s 1))))))))) + + (define vector-copy! + (case-lambda + [(target tstart source) + (vector-copy! target tstart source 0 (vector-length source))] + [(target tstart source sstart) + (vector-copy! target tstart source sstart (vector-length source))] + [(target tstart source sstart send) + (let loop ([i sstart] [j tstart]) + (when (< i send) + (vector-set! target j (vector-ref source i)) + (loop (+ i 1) (+ j 1))))])) + + (define (vector-reverse-copy! target tstart source . rest) + (let ([sstart (if (pair? rest) (car rest) 0)] + [send (if (and (pair? rest) (pair? (cdr rest))) + (cadr rest) (vector-length source))]) + (let loop ([i (- send 1)] [j tstart]) + (when (>= i sstart) + (vector-set! target j (vector-ref source i)) + (loop (- i 1) (+ j 1)))))) + + (define (vector-append . vecs) + (let* ([total (apply + (map vector-length vecs))] + [result (make-vector total)]) + (let loop ([vecs vecs] [pos 0]) + (if (null? vecs) result + (let ([v (car vecs)]) + (vector-copy! result pos v) + (loop (cdr vecs) (+ pos (vector-length v)))))))) + + (define (vector-concatenate vecs) + (apply vector-append vecs)) + + (define (vector-empty? v) + (= (vector-length v) 0)) + + (define (vector-count pred v) + (let ([len (vector-length v)]) + (let loop ([i 0] [c 0]) + (if (= i len) c + (loop (+ i 1) (if (pred (vector-ref v i)) (+ c 1) c)))))) + + (define (vector-index pred v) + (let ([len (vector-length v)]) + (let loop ([i 0]) + (cond + [(= i len) #f] + [(pred (vector-ref v i)) i] + [else (loop (+ i 1))])))) + + (define (vector-index-right pred v) + (let loop ([i (- (vector-length v) 1)]) + (cond + [(< i 0) #f] + [(pred (vector-ref v i)) i] + [else (loop (- i 1))]))) + + (define (vector-skip pred v) + (vector-index (lambda (x) (not (pred x))) v)) + + (define (vector-skip-right pred v) + (vector-index-right (lambda (x) (not (pred x))) v)) + + (define (vector-any pred v) + (let ([len (vector-length v)]) + (let loop ([i 0]) + (cond + [(= i len) #f] + [(pred (vector-ref v i)) => (lambda (x) x)] + [else (loop (+ i 1))])))) + + (define (vector-every pred v) + (let ([len (vector-length v)]) + (let loop ([i 0] [last #t]) + (cond + [(= i len) last] + [(pred (vector-ref v i)) => (lambda (x) (loop (+ i 1) x))] + [else #f])))) + + (define (vector-swap! v i j) + (let ([tmp (vector-ref v i)]) + (vector-set! v i (vector-ref v j)) + (vector-set! v j tmp)))