mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-06-06 10:55:05 +02:00
Compare commits
No commits in common. "master" and "0.11" have entirely different histories.
38 changed files with 88 additions and 1254 deletions
|
|
@ -27,7 +27,7 @@ see the manual for instructions on compiling with fewer features or
|
|||
requesting a smaller language on startup.
|
||||
|
||||
Chibi-Scheme is known to work on **32** and **64-bit** Linux, FreeBSD,
|
||||
NetBSD, OpenBSD, DragonFlyBSD, OS X, Plan 9, Windows, iOS, Android,
|
||||
NetBSD, OpenBSD and OS X, Plan 9, Windows, iOS, Android,
|
||||
ARM and [Emscripten](https://kripken.github.io/emscripten-site). Basic
|
||||
support for native Windows desktop also exists. See README-win32.md
|
||||
for details and build instructions.
|
||||
|
|
@ -56,5 +56,4 @@ shared libraries.
|
|||
To make the emscripten build run `make js` (_not_ `emmake make js`).
|
||||
|
||||
For more detailed documentation, run `make doc` and see the generated
|
||||
*doc/chibi.html* or read the [manual](http://synthcode.com/scheme/chibi/)
|
||||
online.
|
||||
*doc/chibi.html*.
|
||||
|
|
|
|||
|
|
@ -28,8 +28,8 @@ standard modules. You can choose whichever layer suits your needs
|
|||
best and customize the rest. Adding your own primitives or wrappers
|
||||
around existing C libraries is easy with the C FFI.
|
||||
|
||||
Chibi is known to build and run on 32 and 64-bit Linux, OpenBSD, FreeBSD,
|
||||
DragonFlyBSD, OS X, iOS, Windows (under Cygwin) and Plan9.
|
||||
Chibi is known to build and run on 32 and 64-bit Linux, FreeBSD,
|
||||
DragonFly, OS X, iOS, Windows (under Cygwin) and Plan9.
|
||||
|
||||
\section{Installation}
|
||||
|
||||
|
|
@ -435,7 +435,7 @@ temporary values we may generate, which is what the
|
|||
\cmacro{sexp_gc_var2}, \cmacro{sexp_gc_preserve2} and
|
||||
\cmacro{sexp_gc_release2} macros do (there are similar macros for
|
||||
values 1-6). Precise GCs prevent a class of memory leaks (and
|
||||
potential attacks based thereon), but if you prefer convenience then
|
||||
potential attackes based thereon), but if you prefer convenience then
|
||||
Chibi can be compiled with a conservative GC and you can ignore these.
|
||||
|
||||
The interesting part is then the calls to \cfun{sexp_load},
|
||||
|
|
@ -1403,7 +1403,7 @@ namespace.
|
|||
|
||||
\item{\hyperlink["lib/chibi/shell.html"]{(chibi shell) - Process combinators with high-level pipeline syntax in the spirit of SCSH.}}
|
||||
|
||||
\item{\hyperlink["lib/chibi/show.html"]{(chibi show) - Monadic formatting.}}
|
||||
\item{\hyperlink["lib/chibi/show.html"]{(chibi show) - Monadic formattinga.}}
|
||||
|
||||
\item{\hyperlink["lib/chibi/scribble.html"]{(chibi scribble) - A parser for the scribble syntax used to write this manual}}
|
||||
|
||||
|
|
|
|||
4
eval.c
4
eval.c
|
|
@ -1947,8 +1947,8 @@ sexp sexp_inexact_to_exact (sexp ctx, sexp self, sexp_sint_t n, sexp z) {
|
|||
res = sexp_xtype_exception(ctx, self, "exact: not an integer", z);
|
||||
#endif
|
||||
#if SEXP_USE_BIGNUMS
|
||||
} else if ((sexp_flonum_value(z) > (double)SEXP_MAX_FIXNUM)
|
||||
|| sexp_flonum_value(z) < (double)SEXP_MIN_FIXNUM) {
|
||||
} else if ((sexp_flonum_value(z) > SEXP_MAX_FIXNUM)
|
||||
|| sexp_flonum_value(z) < SEXP_MIN_FIXNUM) {
|
||||
res = sexp_double_to_bignum(ctx, sexp_flonum_value(z));
|
||||
#endif
|
||||
} else {
|
||||
|
|
|
|||
|
|
@ -301,7 +301,7 @@
|
|||
|
||||
/* uncomment this to make the VM adhere to alignment rules */
|
||||
/* This is required on some platforms, e.g. ARM */
|
||||
/* #define SEXP_USE_ALIGNED_BYTECODE 1 */
|
||||
/* #define SEXP_USE_ALIGNED_BYTECODE */
|
||||
|
||||
/************************************************************************/
|
||||
/* These settings are configurable but only recommended for */
|
||||
|
|
|
|||
|
|
@ -1079,7 +1079,6 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
|
|||
#define sexp_negate_flonum(x) sexp_flonum_value(x) = -(sexp_flonum_value(x))
|
||||
#endif
|
||||
|
||||
/* TODO: Doesn't support x == SEXP_MIN_FIXNUM. */
|
||||
#define sexp_negate(x) \
|
||||
if (sexp_flonump(x)) \
|
||||
sexp_negate_flonum(x); \
|
||||
|
|
|
|||
|
|
@ -40,10 +40,5 @@
|
|||
(test 'error
|
||||
(guard (exn (else 'error))
|
||||
(run-application zoo-app-spec
|
||||
'("zoo" "--soap" "wash" "--animals" "rhino"))))
|
||||
(let ((out (open-output-string)))
|
||||
(parameterize ((current-output-port out))
|
||||
(run-application zoo-app-spec '("zoo" "help"))
|
||||
(test "Usage: zoo [options] <command>\nCommands:\n feed animals ... - feed the animals\n wash animals ... - wash the animals\n help - print help\nOptions:\n --animals - list of animals to act on (default all)\n -l, --lions - also apply the action to lions\n"
|
||||
(get-output-string out))))
|
||||
'("zoo" "--soap" "wash" "--animals" "rhino"))))
|
||||
(test-end))))
|
||||
|
|
|
|||
|
|
@ -538,7 +538,7 @@
|
|||
(and (pair? (car ls)) (memq (caar ls) '(begin: end:) )))
|
||||
(lp (cdr ls) (car ls) commands options))
|
||||
((and (pair? (car ls)) (eq? '@ (caar ls)))
|
||||
(lp (cdr ls) docs commands (append options (cdar ls))))
|
||||
(lp (cdr ls) docs commands (append options (cadr (car ls)))))
|
||||
((and (pair? (car ls)) (symbol? (caar ls)))
|
||||
;; don't print nested commands
|
||||
(if (pair? commands)
|
||||
|
|
|
|||
|
|
@ -1,98 +0,0 @@
|
|||
|
||||
(define-library (chibi csv-test)
|
||||
(import (scheme base)
|
||||
(srfi 227)
|
||||
(chibi csv)
|
||||
(chibi test))
|
||||
(export run-tests)
|
||||
(begin
|
||||
(define string->csv
|
||||
(opt-lambda (str (reader (csv-read->list)))
|
||||
(reader (open-input-string str))))
|
||||
(define csv->string
|
||||
(opt-lambda (row (writer (csv-writer)))
|
||||
(let ((out (open-output-string)))
|
||||
(writer row out)
|
||||
(get-output-string out))))
|
||||
(define (run-tests)
|
||||
(test-begin "(chibi csv)")
|
||||
(test-assert (eof-object? (string->csv "")))
|
||||
(test '("1997" "Ford" "E350")
|
||||
(string->csv "1997,Ford,E350"))
|
||||
(test '("1997" "Ford" "E350")
|
||||
(string->csv "\n1997,Ford,E350"))
|
||||
(test '(" ")
|
||||
(string->csv " \n1997,Ford,E350"))
|
||||
(test '("" "")
|
||||
(string->csv ",\n1997,Ford,E350"))
|
||||
(test '("1997" "Ford" "E350")
|
||||
(string->csv "\"1997\",\"Ford\",\"E350\""))
|
||||
(test '("1997" "Ford" "E350" "Super, luxurious truck")
|
||||
(string->csv "1997,Ford,E350,\"Super, luxurious truck\""))
|
||||
(test '("1997" "Ford" "E350" "Super, \"luxurious\" truck")
|
||||
(string->csv "1997,Ford,E350,\"Super, \"\"luxurious\"\" truck\""))
|
||||
(test '("1997" "Ford" "E350" "Go get one now\nthey are going fast")
|
||||
(string->csv "1997,Ford,E350,\"Go get one now
|
||||
they are going fast\""))
|
||||
(test '("1997" "Ford" "E350")
|
||||
(string->csv
|
||||
"# this is a comment\n1997,Ford,E350"
|
||||
(csv-read->list
|
||||
(csv-parser (csv-grammar '((comment-chars #\#)))))))
|
||||
(let ((parser (csv-parser (csv-grammar '((quote-non-numeric? . #t))))))
|
||||
(test-error (string->csv "1997,\"Ford\",E350" (csv-read->list parser)))
|
||||
(test '(1997 "Ford" "E350")
|
||||
(string->csv "1997,\"Ford\",\"E350\"" (csv-read->list parser))))
|
||||
(test '("1997" "Fo\"rd" "E3\"50")
|
||||
(string->csv "1997\tFo\"rd\tE3\"50"
|
||||
(csv-read->list (csv-parser default-tsv-grammar))))
|
||||
(test '#("1997" "Ford" "E350")
|
||||
(string->csv "1997,Ford,E350" (csv-read->vector)))
|
||||
(test '#("1997" "Ford" "E350")
|
||||
(string->csv "1997,Ford,E350" (csv-read->fixed-vector 3)))
|
||||
(test-error
|
||||
(string->csv "1997,Ford,E350" (csv-read->fixed-vector 2)))
|
||||
(let ((city-csv "Los Angeles,34°03′N,118°15′W
|
||||
New York City,40°42′46″N,74°00′21″W
|
||||
Paris,48°51′24″N,2°21′03″E"))
|
||||
(test '(*TOP*
|
||||
(row (col-0 "Los Angeles")
|
||||
(col-1 "34°03′N")
|
||||
(col-2 "118°15′W"))
|
||||
(row (col-0 "New York City")
|
||||
(col-1 "40°42′46″N")
|
||||
(col-2 "74°00′21″W"))
|
||||
(row (col-0 "Paris")
|
||||
(col-1 "48°51′24″N")
|
||||
(col-2 "2°21′03″E")))
|
||||
((csv->sxml) (open-input-string city-csv)))
|
||||
(test '(*TOP*
|
||||
(city (name "Los Angeles")
|
||||
(latitude "34°03′N")
|
||||
(longitude "118°15′W"))
|
||||
(city (name "New York City")
|
||||
(latitude "40°42′46″N")
|
||||
(longitude "74°00′21″W"))
|
||||
(city (name "Paris")
|
||||
(latitude "48°51′24″N")
|
||||
(longitude "2°21′03″E")))
|
||||
((csv->sxml 'city '(name latitude longitude))
|
||||
(open-input-string city-csv)))
|
||||
(test 3 (csv-num-rows default-csv-grammar (open-input-string city-csv)))
|
||||
(test 0 (csv-num-rows default-csv-grammar (open-input-string "")))
|
||||
(test 1 (csv-num-rows default-csv-grammar (open-input-string "x"))))
|
||||
(test "1997,Ford,E350\n"
|
||||
(csv->string '("1997" "Ford" "E350")))
|
||||
(test "1997,Ford,E350,\"Super, luxurious truck\"\n"
|
||||
(csv->string '("1997" "Ford" "E350" "Super, luxurious truck")))
|
||||
(test "1997,Ford,E350,\"Super, \"\"luxurious\"\" truck\"\n"
|
||||
(csv->string '("1997" "Ford" "E350" "Super, \"luxurious\" truck")))
|
||||
(test "1997,Ford,E350,\"Go get one now\nthey are going fast\"\n"
|
||||
(csv->string
|
||||
'("1997" "Ford" "E350" "Go get one now\nthey are going fast")))
|
||||
(test "1997,Ford,E350\n"
|
||||
(csv->string '(1997 "Ford" E350)))
|
||||
(test "1997,\"Ford\",\"E350\"\n"
|
||||
(csv->string '(1997 "Ford" E350)
|
||||
(csv-writer (csv-grammar '((quote-non-numeric? . #t))))))
|
||||
(test-end))))
|
||||
|
|
@ -1,498 +0,0 @@
|
|||
|
||||
;;> \section{CSV Grammars}
|
||||
|
||||
;;> CSV is a simple and compact format for tabular data, which has
|
||||
;;> made it popular for a variety of tasks since the early days of
|
||||
;;> computing. Unfortunately, there are many incompatible dialects
|
||||
;;> requiring a grammar to specify all of the different options.
|
||||
|
||||
(define-record-type Csv-Grammar
|
||||
(make-csv-grammar separator-chars quote-char quote-doubling-escapes? escape-char record-separator comment-chars quote-non-numeric?)
|
||||
csv-grammar?
|
||||
(separator-chars csv-grammar-separator-chars csv-grammar-separator-chars-set!)
|
||||
(quote-char csv-grammar-quote-char csv-grammar-quote-char-set!)
|
||||
(quote-doubling-escapes? csv-grammar-quote-doubling-escapes? csv-grammar-quote-doubling-escapes?-set!)
|
||||
(escape-char csv-grammar-escape-char csv-grammar-escape-char-set!)
|
||||
(record-separator csv-grammar-record-separator csv-grammar-record-separator-set!)
|
||||
(comment-chars csv-grammar-comment-chars csv-grammar-comment-chars-set!)
|
||||
(quote-non-numeric? csv-grammar-quote-non-numeric? csv-grammar-quote-non-numeric?-set!))
|
||||
|
||||
;; TODO: Other options to consider:
|
||||
;; - strip-leading/trailing-whitespace?
|
||||
;; - newlines-in-quotes?
|
||||
|
||||
;;> Creates a new CSV grammar from the given spec, an alist of symbols
|
||||
;;> to values. The following options are supported:
|
||||
;;>
|
||||
;;> \itemlist[
|
||||
;;> \item{\scheme{'separator-chars} - A non-empty list of characters used to delimit fields, by default \scheme{'(#\\,)} (comma-separated).}
|
||||
;;> \item{\scheme{'quote-char} - A single character used to quote fields containing special characters, or \scheme{#f} to disable quoting, by default \scheme{#\\"} (a double-quote).}
|
||||
;;> \item{\scheme{'quote-doubling-escapes?} - If true, two successive \scheme{quote-char}s within quotes are treated as a single escaped \scheme{quote-char} (default true).}
|
||||
;;> \item{\scheme{'escape-char} - A single character used to escape characters within quoted fields, or \scheme{#f} to disable escapes, by default \scheme{#f} (no explicit escape, use quote doubling).}
|
||||
;;> \item{\scheme{'record-separator} - A single character used to delimit the record (row), or one of the symbols \scheme{'cr}, \scheme{'crlf}, \scheme{'lf} or \scheme{'lax}. These correspond to sequences of carriage return and line feed, or in the case of \scheme{'lax} any of the other three sequences. Defaults to \scheme{'lax}.}
|
||||
;;> \item{\scheme{'comment-chars} - A list of characters which if found at the start of a record indicate it is a comment, discarding all characters through to the next record-separator. Defaults to the empty list (no comments).}
|
||||
;;> ]
|
||||
;;>
|
||||
;;> Example Gecos grammar:
|
||||
;;>
|
||||
;;> \example{
|
||||
;;> (csv-grammar
|
||||
;;> '((separator-chars #\\:)
|
||||
;;> (quote-char . #f)))
|
||||
;;> }
|
||||
(define (csv-grammar spec)
|
||||
(let ((grammar (make-csv-grammar '(#\,) #\" #t #f 'lax '() #f)))
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(case (car x)
|
||||
((separator-chars delimiter)
|
||||
(csv-grammar-separator-chars-set! grammar (cdr x)))
|
||||
((quote-char)
|
||||
(csv-grammar-quote-char-set! grammar (cdr x)))
|
||||
((quote-doubling-escapes?)
|
||||
(csv-grammar-quote-doubling-escapes?-set! grammar (cdr x)))
|
||||
((escape-char)
|
||||
(csv-grammar-escape-char-set! grammar (cdr x)))
|
||||
((record-separator newline-type)
|
||||
(let ((rec-sep
|
||||
(case (cdr x)
|
||||
((crlf lax) (cdr x))
|
||||
((cr) #\return)
|
||||
((lf) #\newline)
|
||||
(else
|
||||
(if (char? (cdr x))
|
||||
(cdr x)
|
||||
(error "invalid record-separator, expected a char or one of 'lax or 'crlf" (cdr x)))))))
|
||||
(csv-grammar-escape-char-set! grammar (cdr x))))
|
||||
((comment-chars)
|
||||
(csv-grammar-comment-chars-set! grammar (cdr x)))
|
||||
((quote-non-numeric?)
|
||||
(csv-grammar-quote-non-numeric?-set! grammar (cdr x)))
|
||||
(else
|
||||
(error "unknown csv-grammar spec" x))))
|
||||
spec)
|
||||
grammar))
|
||||
|
||||
;;> The default CSV grammar for convenience, with all of the defaults
|
||||
;;> from \scheme{csv-grammar}, i.e. comma-delimited with \scheme{#\"}
|
||||
;;> for quoting, doubled to escape.
|
||||
(define default-csv-grammar
|
||||
(csv-grammar '()))
|
||||
|
||||
;;> The default TSV grammar for convenience, splitting fields only on
|
||||
;;> tabs, with no quoting or escaping.
|
||||
(define default-tsv-grammar
|
||||
(csv-grammar '((separator-chars #\tab) (quote-char . #f))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;> \section{CSV Parsers}
|
||||
|
||||
;;> Parsers are low-level utilities to perform operations on records a
|
||||
;;> field at a time. You generally want to work with readers, which
|
||||
;;> build on this to build records into familiar data structures.
|
||||
|
||||
;;> Parsers follow the rules of a grammar to parse a single CSV
|
||||
;;> record, possible comprised of multiple fields. A parser is a
|
||||
;;> procedure of three arguments which performs a fold operation over
|
||||
;;> the fields of the record. The parser signature is:
|
||||
;;> \scheme{(parser kons knil in)}, where \scheme{kons} itself is
|
||||
;;> a procedure of three arguments: \scheme{(proc acc index field)}.
|
||||
;;> \scheme{proc} is called on each field of the record, in order,
|
||||
;;> along with its zero-based \scheme{index} and the accumulated
|
||||
;;> result of the last call, starting with \scheme{knil}.
|
||||
|
||||
;;> Returns a new CSV parser for the given \var{grammar}. The parser
|
||||
;;> by itself can be used to parse a record at a time.
|
||||
;;>
|
||||
;;> \example{
|
||||
;;> (let ((parse (csv-parser)))
|
||||
;;> (parse (lambda (vec i field) (vector-set! vec i (string->number field)) vec)
|
||||
;;> (make-vector 3)
|
||||
;;> (open-input-string "1,2,3")))
|
||||
;;> }
|
||||
(define csv-parser
|
||||
(opt-lambda ((grammar default-csv-grammar))
|
||||
(lambda (kons knil in)
|
||||
(when (pair? (csv-grammar-comment-chars grammar))
|
||||
(let lp ()
|
||||
(when (memv (peek-char in) (csv-grammar-comment-chars grammar))
|
||||
(csv-skip-line in grammar)
|
||||
(lp))))
|
||||
(let lp ((acc knil)
|
||||
(index 0)
|
||||
(quoted? #f)
|
||||
(out (open-output-string)))
|
||||
(define (get-field)
|
||||
(let ((field (get-output-string out)))
|
||||
(cond
|
||||
((and (zero? index) (equal? field "")) field)
|
||||
((and (csv-grammar-quote-non-numeric? grammar) (not quoted?))
|
||||
(or (string->number field)
|
||||
(error "unquoted field is not numeric" field)))
|
||||
(else field))))
|
||||
(define (finish-row)
|
||||
(let ((field (get-field)))
|
||||
(if (and (zero? index) (equal? field ""))
|
||||
;; empty row, read again
|
||||
(lp acc index #f out)
|
||||
(kons acc index field))))
|
||||
(let ((ch (read-char in)))
|
||||
(cond
|
||||
((eof-object? ch)
|
||||
(let ((field (get-field)))
|
||||
(if (and (zero? index) (equal? field ""))
|
||||
;; no data
|
||||
ch
|
||||
(kons acc index field))))
|
||||
((memv ch (csv-grammar-separator-chars grammar))
|
||||
(lp (kons acc index (get-field))
|
||||
(+ index 1)
|
||||
#f
|
||||
(open-output-string)))
|
||||
((eqv? ch (csv-grammar-quote-char grammar))
|
||||
;; TODO: Consider a strict mode to enforce no text
|
||||
;; before/after the quoted text.
|
||||
(csv-read-quoted in out grammar)
|
||||
(lp acc index #t out))
|
||||
((eqv? ch (csv-grammar-record-separator grammar))
|
||||
(finish-row))
|
||||
((and (eqv? ch #\return)
|
||||
(memq (csv-grammar-record-separator grammar) '(crlf lax)))
|
||||
(cond
|
||||
((eqv? (peek-char in) #\newline)
|
||||
(read-char in)
|
||||
(finish-row))
|
||||
((eq? (csv-grammar-record-separator grammar) 'lax)
|
||||
(finish-row))
|
||||
(else
|
||||
(write-char ch out)
|
||||
(lp acc (+ index 1) quoted? out))))
|
||||
((and (eqv? ch #\newline)
|
||||
(eq? (csv-grammar-record-separator grammar) 'lax))
|
||||
(finish-row))
|
||||
(else
|
||||
(write-char ch out)
|
||||
(lp acc index quoted? out))))))))
|
||||
|
||||
(define (csv-skip-line in grammar)
|
||||
(let lp ()
|
||||
(let ((ch (read-char in)))
|
||||
(cond
|
||||
((eof-object? ch))
|
||||
((eqv? ch (csv-grammar-record-separator grammar)))
|
||||
((and (eqv? ch #\newline)
|
||||
(eq? (csv-grammar-record-separator grammar) 'lax)))
|
||||
((and (eqv? ch #\return)
|
||||
(memq (csv-grammar-record-separator grammar) '(crlf lax)))
|
||||
(cond
|
||||
((eqv? (peek-char in) #\newline) (read-char in))
|
||||
((eq? (csv-grammar-record-separator grammar) 'lax))
|
||||
(else (lp))))
|
||||
(else (lp))))))
|
||||
|
||||
(define (csv-read-quoted in out grammar)
|
||||
(let lp ()
|
||||
(let ((ch (read-char in)))
|
||||
(cond
|
||||
((eof-object? ch)
|
||||
(error "unterminated csv quote" (get-output-string out)))
|
||||
((eqv? ch (csv-grammar-quote-char grammar))
|
||||
(when (and (csv-grammar-quote-doubling-escapes? grammar)
|
||||
(eqv? ch (peek-char in)))
|
||||
(write-char (read-char in) out)
|
||||
(lp)))
|
||||
((eqv? ch (csv-grammar-escape-char grammar))
|
||||
(write-char (read-char in) out)
|
||||
(lp))
|
||||
(else
|
||||
;; TODO: Consider an option to disable newlines in quotes.
|
||||
(write-char ch out)
|
||||
(lp))))))
|
||||
|
||||
(define (csv-skip-quoted in grammar)
|
||||
(let lp ()
|
||||
(let ((ch (read-char in)))
|
||||
(cond
|
||||
((eof-object? ch)
|
||||
(error "unterminated csv quote"))
|
||||
((eqv? ch (csv-grammar-quote-char grammar))
|
||||
(when (and (csv-grammar-quote-doubling-escapes? grammar)
|
||||
(eqv? ch (peek-char in)))
|
||||
(read-char in)
|
||||
(lp)))
|
||||
((eqv? ch (csv-grammar-escape-char grammar))
|
||||
(read-char in)
|
||||
(lp))
|
||||
(else
|
||||
(lp))))))
|
||||
|
||||
;;> Returns the number of rows in the input.
|
||||
(define csv-num-rows
|
||||
(opt-lambda ((grammar default-csv-grammar)
|
||||
(in (current-input-port)))
|
||||
(let lp ((num-rows 0) (start? #t))
|
||||
(let ((ch (read-char in)))
|
||||
(cond
|
||||
((eof-object? ch) (if start? num-rows (+ num-rows 1)))
|
||||
((eqv? ch (csv-grammar-quote-char grammar))
|
||||
(csv-skip-quoted in grammar)
|
||||
(lp num-rows #f))
|
||||
((eqv? ch (csv-grammar-record-separator grammar))
|
||||
(lp (+ num-rows 1) #f))
|
||||
((and (eqv? ch #\return)
|
||||
(memq (csv-grammar-record-separator grammar) '(crlf lax)))
|
||||
(cond
|
||||
((eqv? (peek-char in) #\newline)
|
||||
(read-char in)
|
||||
(lp (+ num-rows 1) #t))
|
||||
((eq? (csv-grammar-record-separator grammar) 'lax)
|
||||
(lp (+ num-rows 1) #t))
|
||||
(else
|
||||
(lp num-rows #f))))
|
||||
((and (eqv? ch #\newline)
|
||||
(eq? (csv-grammar-record-separator grammar) 'lax))
|
||||
(lp (+ num-rows 1) #t))
|
||||
(else
|
||||
(lp num-rows #f)))))))
|
||||
|
||||
;;> \section{CSV Readers}
|
||||
|
||||
;;> A CSV reader reads a single record, returning some representation
|
||||
;;> of it. You can either loop manually with these or pass them to
|
||||
;;> one of the high-level utilities to operate on a whole CSV file at
|
||||
;;> a time.
|
||||
|
||||
;;> The simplest reader, simply returns the field string values in
|
||||
;;> order as a list.
|
||||
;;>
|
||||
;;> \example{
|
||||
;;> ((csv-read->list) (open-input-string "foo,bar,baz"))
|
||||
;;> }
|
||||
(define csv-read->list
|
||||
(opt-lambda ((parser (csv-parser)))
|
||||
(opt-lambda ((in (current-input-port)))
|
||||
(let ((res (parser (lambda (ls i field) (cons field ls)) '() in)))
|
||||
(if (pair? res)
|
||||
(reverse res)
|
||||
res)))))
|
||||
|
||||
;;> The equivalent of \scheme{csv-read->list} but returns a vector.
|
||||
;;>
|
||||
;;> \example{
|
||||
;;> ((csv-read->vector) (open-input-string "foo,bar,baz"))
|
||||
;;> }
|
||||
(define csv-read->vector
|
||||
(opt-lambda ((parser (csv-parser)))
|
||||
(let ((reader (csv-read->list parser)))
|
||||
(opt-lambda ((in (current-input-port)))
|
||||
(let ((res (reader in)))
|
||||
(if (pair? res)
|
||||
(list->vector res)
|
||||
res))))))
|
||||
|
||||
;;> The same as \scheme{csv-read->vector} but requires the vector to
|
||||
;;> be of a fixed size, and may be more efficient.
|
||||
;;>
|
||||
;;> \example{
|
||||
;;> ((csv-read->fixed-vector 3) (open-input-string "foo,bar,baz"))
|
||||
;;> }
|
||||
(define csv-read->fixed-vector
|
||||
(opt-lambda (size (parser (csv-parser)))
|
||||
(opt-lambda ((in (current-input-port)))
|
||||
(let ((res (make-vector size)))
|
||||
(let ((len (parser (lambda (prev-i i field) (vector-set! res i field) i)
|
||||
0
|
||||
in)))
|
||||
(if (zero? len)
|
||||
(eof-object)
|
||||
res))))))
|
||||
|
||||
;;> Returns an SXML representation of the record, as a row with
|
||||
;;> multiple named columns.
|
||||
;;>
|
||||
;;> \example{
|
||||
;;> ((csv-read->sxml 'city '(name latitude longitude))
|
||||
;;> (open-input-string "Tokyo,35°41′23″N,139°41′32″E"))
|
||||
;;> }
|
||||
(define csv-read->sxml
|
||||
(opt-lambda ((row-name 'row)
|
||||
(column-names
|
||||
(lambda (i)
|
||||
(string->symbol (string-append "col-" (number->string i)))))
|
||||
(parser (csv-parser)))
|
||||
(define (get-column-name i)
|
||||
(if (procedure? column-names)
|
||||
(column-names i)
|
||||
(list-ref column-names i)))
|
||||
(opt-lambda ((in (current-input-port)))
|
||||
(let ((res (parser (lambda (ls i field)
|
||||
`((,(get-column-name i) ,field) ,@ls))
|
||||
(list row-name)
|
||||
in)))
|
||||
(if (pair? res)
|
||||
(reverse res)
|
||||
res)))))
|
||||
|
||||
;;> \section{CSV Utilities}
|
||||
|
||||
;;> A folding operation on records. \var{proc} is called successively
|
||||
;;> on each row and the accumulated result.
|
||||
;;>
|
||||
;;> \example{
|
||||
;;> (csv-fold
|
||||
;;> (lambda (row acc) (cons (cadr (assq 'name (cdr row))) acc))
|
||||
;;> '()
|
||||
;;> (csv-read->sxml 'city '(name latitude longitude))
|
||||
;;> (open-input-string
|
||||
;;> "Tokyo,35°41′23″N,139°41′32″E
|
||||
;;> Paris,48°51′24″N,2°21′03″E"))
|
||||
;;> }
|
||||
(define csv-fold
|
||||
(opt-lambda (proc
|
||||
knil
|
||||
(reader (csv-read->list))
|
||||
(in (current-input-port)))
|
||||
(let lp ((acc knil))
|
||||
(let ((row (reader in)))
|
||||
(cond
|
||||
((eof-object? row) acc)
|
||||
(else (lp (proc row acc))))))))
|
||||
|
||||
;;> An iterator which simply calls \var{proc} on each record in the
|
||||
;;> input in order.
|
||||
;;>
|
||||
;;> \example{
|
||||
;;> (let ((count 0))
|
||||
;;> (csv-for-each
|
||||
;;> (lambda (row) (if (string->number (car row)) (set! count (+ 1 count))))
|
||||
;;> (csv-read->list)
|
||||
;;> (open-input-string
|
||||
;;> "1,foo\\n2,bar\\nthree,baz\\n4,qux"))
|
||||
;;> count)
|
||||
;;> }
|
||||
(define csv-for-each
|
||||
(opt-lambda (proc
|
||||
(reader (csv-read->list))
|
||||
(in (current-input-port)))
|
||||
(csv-fold (lambda (row acc) (proc row)) #f reader in)))
|
||||
|
||||
;;> Returns a list containing the result of calling \var{proc} on each
|
||||
;;> element in the input.
|
||||
;;>
|
||||
;;> \example{
|
||||
;;> (csv-map
|
||||
;;> (lambda (row) (string->symbol (cadr row)))
|
||||
;;> (csv-read->list)
|
||||
;;> (open-input-string
|
||||
;;> "1,foo\\n2,bar\\nthree,baz\\n4,qux"))
|
||||
;;> }
|
||||
(define csv-map
|
||||
(opt-lambda (proc
|
||||
(reader (csv-read->list))
|
||||
(in (current-input-port)))
|
||||
(reverse (csv-fold (lambda (row acc) (cons (proc row) acc)) '() reader in))))
|
||||
|
||||
;;> Returns a list of all of the read records in the input.
|
||||
;;>
|
||||
;;> \example{
|
||||
;;> (csv->list
|
||||
;;> (csv-read->list)
|
||||
;;> (open-input-string
|
||||
;;> "1,foo\\n2,bar\\nthree,baz\\n4,qux"))
|
||||
;;> }
|
||||
(define csv->list
|
||||
(opt-lambda ((reader (csv-read->list))
|
||||
(in (current-input-port)))
|
||||
(csv-map (lambda (row) row) reader in)))
|
||||
|
||||
;;> Returns an SXML representation of the CSV.
|
||||
;;>
|
||||
;;> \example{
|
||||
;;> ((csv->sxml 'city '(name latitude longitude))
|
||||
;;> (open-input-string
|
||||
;;> "Tokyo,35°41′23″N,139°41′32″E
|
||||
;;> Paris,48°51′24″N,2°21′03″E"))
|
||||
;;> }
|
||||
(define csv->sxml
|
||||
(opt-lambda ((row-name 'row)
|
||||
(column-names
|
||||
(lambda (i)
|
||||
(string->symbol (string-append "col-" (number->string i)))))
|
||||
(parser (csv-parser)))
|
||||
(opt-lambda ((in (current-input-port)))
|
||||
(cons '*TOP*
|
||||
(csv->list (csv-read->sxml row-name column-names parser) in)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;> \section{CSV Writers}
|
||||
|
||||
(define (write->string obj)
|
||||
(let ((out (open-output-string)))
|
||||
(write obj out)
|
||||
(get-output-string out)))
|
||||
|
||||
(define (csv-grammar-char-needs-quoting? grammar ch)
|
||||
(or (eqv? ch (csv-grammar-quote-char grammar))
|
||||
(eqv? ch (csv-grammar-escape-char grammar))
|
||||
(memv ch (csv-grammar-separator-chars grammar))
|
||||
(eqv? ch (csv-grammar-record-separator grammar))
|
||||
(memv ch '(#\newline #\return))))
|
||||
|
||||
(define (csv-write-quoted obj out grammar)
|
||||
(let ((in (open-input-string (if (string? obj) obj (write->string obj)))))
|
||||
(write-char (csv-grammar-quote-char grammar) out)
|
||||
(let lp ()
|
||||
(let ((ch (read-char in)))
|
||||
(cond
|
||||
((eof-object? ch))
|
||||
((or (eqv? ch (csv-grammar-quote-char grammar))
|
||||
(eqv? ch (csv-grammar-escape-char grammar)))
|
||||
(cond
|
||||
((and (csv-grammar-quote-doubling-escapes? grammar)
|
||||
(eqv? ch (csv-grammar-quote-char grammar)))
|
||||
(write-char ch out))
|
||||
((csv-grammar-escape-char grammar)
|
||||
=> (lambda (esc) (write-char esc out)))
|
||||
(else (error "no quote defined for" ch grammar)))
|
||||
(write-char ch out)
|
||||
(lp))
|
||||
(else
|
||||
(write-char ch out)
|
||||
(lp)))))
|
||||
(write-char (csv-grammar-quote-char grammar) out)))
|
||||
|
||||
(define csv-writer
|
||||
(opt-lambda ((grammar default-csv-grammar))
|
||||
(opt-lambda (row (out (current-output-port)))
|
||||
(let lp ((ls row) (first? #t))
|
||||
(when (pair? ls)
|
||||
(unless first?
|
||||
(write-char (car (csv-grammar-separator-chars grammar)) out))
|
||||
(if (or (and (csv-grammar-quote-non-numeric? grammar)
|
||||
(not (number? (car ls))))
|
||||
(and (string? (car ls))
|
||||
(string-any
|
||||
(lambda (ch) (csv-grammar-char-needs-quoting? grammar ch))
|
||||
(car ls)))
|
||||
(and (not (string? (car ls)))
|
||||
(not (number? (car ls)))
|
||||
(not (symbol? (car ls)))))
|
||||
(csv-write-quoted (car ls) out grammar)
|
||||
(display (car ls) out))
|
||||
(lp (cdr ls) #f)))
|
||||
(write-string
|
||||
(case (csv-grammar-record-separator grammar)
|
||||
((crlf) "\r\n")
|
||||
((lf lax) "\n")
|
||||
((cr) "\r")
|
||||
(else (string (csv-grammar-record-separator grammar))))
|
||||
out))))
|
||||
|
||||
(define csv-write
|
||||
(opt-lambda ((writer (csv-writer)))
|
||||
(opt-lambda (rows (out (current-output-port)))
|
||||
(for-each
|
||||
(lambda (row) (writer row out))
|
||||
rows))))
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
|
||||
(define-library (chibi csv)
|
||||
(import (scheme base) (scheme write) (srfi 130) (srfi 227))
|
||||
(export csv-grammar csv-parser csv-grammar?
|
||||
default-csv-grammar default-tsv-grammar
|
||||
csv-read->list csv-read->vector csv-read->fixed-vector
|
||||
csv-read->sxml csv-num-rows
|
||||
csv-fold csv-map csv->list csv-for-each csv->sxml
|
||||
csv-writer csv-write
|
||||
csv-skip-line)
|
||||
(include "csv.scm"))
|
||||
|
|
@ -65,7 +65,7 @@ sexp json_read_number (sexp ctx, sexp self, sexp in) {
|
|||
res *= pow(10.0, scale_sign * scale);
|
||||
}
|
||||
if (ch != EOF) sexp_push_char(ctx, ch, in);
|
||||
return (inexactp || fabs(res) > (double)SEXP_MAX_FIXNUM) ?
|
||||
return (inexactp || fabs(res) > SEXP_MAX_FIXNUM) ?
|
||||
sexp_make_flonum(ctx, sign * res) :
|
||||
sexp_make_fixnum(sign * res); /* always return inexact? */
|
||||
}
|
||||
|
|
|
|||
|
|
@ -32,11 +32,6 @@
|
|||
|
||||
;;> If no patterns match an error is signalled.
|
||||
|
||||
;;> Note there is no \scheme{else} clause. \scheme{else} is sometimes
|
||||
;;> used descriptively for the last pattern, since an identifier used
|
||||
;;> only once matches anything, but it's preferred to use \scheme{_}
|
||||
;;> described below.
|
||||
|
||||
;;> Identifiers will match anything, and make the corresponding
|
||||
;;> binding available in the body.
|
||||
|
||||
|
|
@ -133,7 +128,7 @@
|
|||
;;> are bound if the \scheme{or} operator matches, but the binding is
|
||||
;;> only defined for identifiers from the subpattern which matched.
|
||||
|
||||
;;> \example{(match 1 ((or) #t) (_ #f))}
|
||||
;;> \example{(match 1 ((or) #t) (else #f))}
|
||||
;;> \example{(match 1 ((or x) x))}
|
||||
;;> \example{(match 1 ((or x 2) x))}
|
||||
|
||||
|
|
|
|||
|
|
@ -151,9 +151,6 @@
|
|||
(test-re '("abc " "")
|
||||
'(: ($ (*? alpha)) (* any))
|
||||
"abc ")
|
||||
;; (test-re-search '("a-z")
|
||||
;; '(: "a" (*? any) "z")
|
||||
;; "a-z-z")
|
||||
(test-re '("<em>Hello World</em>" "em>Hello World</em")
|
||||
'(: "<" ($ (* any)) ">" (* any))
|
||||
"<em>Hello World</em>")
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
;; repl.scm - friendlier repl with line editing and signal handling
|
||||
;; Copyright (c) 2012-2024 Alex Shinn. All rights reserved.
|
||||
;; Copyright (c) 2012-2013 Alex Shinn. All rights reserved.
|
||||
;; BSD-style license: http://synthcode.com/license.txt
|
||||
|
||||
;;> A user-friendly REPL with line editing and signal handling. The
|
||||
|
|
@ -296,8 +296,6 @@
|
|||
(pair? (exception-irritants exn)))
|
||||
(let ((name (car (exception-irritants exn))))
|
||||
(cond
|
||||
((and (identifier? name) (not (env-parent (current-environment))))
|
||||
(display "Did you forget to import a language? e.g. (import (scheme base))\n" out))
|
||||
((identifier? name)
|
||||
(display "Searching for modules exporting " out)
|
||||
(display name out)
|
||||
|
|
@ -402,16 +400,6 @@
|
|||
((= (length value) 1) (push-history-value! (car value)))
|
||||
(else (push-history-value! value))))
|
||||
|
||||
(define-generic repl-print)
|
||||
|
||||
(define-method (repl-print obj (out output-port?))
|
||||
(write/ss obj out))
|
||||
|
||||
(define-generic repl-print-exception)
|
||||
|
||||
(define-method (repl-print-exception obj (out output-port?))
|
||||
(print-exception obj out))
|
||||
|
||||
(define (repl/eval rp expr-list)
|
||||
(let ((thread (current-thread))
|
||||
(out (repl-out rp)))
|
||||
|
|
@ -421,7 +409,7 @@
|
|||
(lambda ()
|
||||
(protect (exn
|
||||
(else
|
||||
(repl-print-exception exn out)
|
||||
(print-exception exn out)
|
||||
(repl-advise-exception exn (current-error-port))))
|
||||
(for-each
|
||||
(lambda (expr)
|
||||
|
|
@ -432,17 +420,17 @@
|
|||
(null? expr))
|
||||
(eval expr (repl-env rp))
|
||||
expr))
|
||||
(lambda res-values
|
||||
(lambda res-list
|
||||
(cond
|
||||
((not (or (null? res-values)
|
||||
(equal? res-values (list undefined-value))))
|
||||
(push-history-value-maybe! res-values)
|
||||
(repl-print (car res-values) out)
|
||||
((not (or (null? res-list)
|
||||
(equal? res-list (list (if #f #f)))))
|
||||
(push-history-value-maybe! res-list)
|
||||
(write/ss (car res-list) out)
|
||||
(for-each
|
||||
(lambda (res)
|
||||
(write-char #\space out)
|
||||
(repl-print res out))
|
||||
(cdr res-values))
|
||||
(write/ss res out))
|
||||
(cdr res-list))
|
||||
(newline out))))))
|
||||
expr-list))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,8 @@
|
|||
|
||||
(define-library (chibi repl)
|
||||
(export repl repl-print repl-print-exception
|
||||
$0 $1 $2 $3 $4 $5 $6 $7 $8 $9)
|
||||
(export repl $0 $1 $2 $3 $4 $5 $6 $7 $8 $9)
|
||||
(import (chibi) (only (meta) load-module module-name->file)
|
||||
(chibi ast) (chibi modules) (chibi doc) (chibi generic)
|
||||
(chibi ast) (chibi modules) (chibi doc)
|
||||
(chibi string) (chibi io) (chibi optional)
|
||||
(chibi process) (chibi term edit-line)
|
||||
(srfi 1)
|
||||
|
|
|
|||
|
|
@ -15,9 +15,6 @@
|
|||
(test-scribble '((foo "blah \"blah\" (`blah'?)")) "\\foo{blah \"blah\" (`blah'?)}")
|
||||
(test-scribble '((foo 1 2 "3 4")) "\\foo[1 2]{3 4}")
|
||||
(test-scribble '((foo 1 2 3 4)) "\\foo[1 2 3 4]")
|
||||
(test-scribble '(123.456) "\\123.456")
|
||||
(test-scribble '((123.456)) "\\(123.456)")
|
||||
(test-scribble '((123.456)) "\\(123.456 )")
|
||||
(test-scribble '((foo width: 2 "blah blah")) "\\foo[width: 2]{blah blah}")
|
||||
(test-scribble '((foo "blah blah" "\n" " yada yada")) "\\foo{blah blah
|
||||
yada yada}")
|
||||
|
|
|
|||
|
|
@ -53,11 +53,9 @@
|
|||
|
||||
(define (read-float-tail in acc)
|
||||
(let lp ((res acc) (k 0.1))
|
||||
(let ((ch (peek-char in)))
|
||||
(let ((ch (read-char in)))
|
||||
(cond ((or (eof-object? ch) (char-delimiter? ch)) res)
|
||||
((char-numeric? ch)
|
||||
(read-char in)
|
||||
(lp (+ res (* k (char-digit ch))) (* k 0.1)))
|
||||
((char-numeric? ch) (lp (+ res (* k (char-digit ch))) (* k 0.1)))
|
||||
(else (error "invalid numeric syntax"))))))
|
||||
|
||||
(define (read-number in acc base)
|
||||
|
|
@ -69,7 +67,7 @@
|
|||
((eqv? #\. ch)
|
||||
(read-char in)
|
||||
(if (= base 10)
|
||||
(read-float-tail in (inexact acc))
|
||||
(begin (read-char in) (read-float-tail in (inexact acc)))
|
||||
(error "non-base-10 floating point")))
|
||||
(else (error "invalid numeric syntax"))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -794,18 +794,10 @@
|
|||
(http-post uri params))))
|
||||
|
||||
(define (remote-command cfg name path params)
|
||||
(let* ((uri (remote-uri cfg name path))
|
||||
(response
|
||||
(port->string (snow-post cfg uri (cons '(fmt . "sexp") params)))))
|
||||
(guard (exn (else
|
||||
(display "ERROR: couldn't display sxml response: ")
|
||||
(write response)
|
||||
(newline)))
|
||||
(let ((sxml (call-with-input-string response read)))
|
||||
(if (null? sxml)
|
||||
(display "WARN: () response from server")
|
||||
(sxml-display-as-text sxml))
|
||||
(newline)))))
|
||||
(let ((uri (remote-uri cfg name path)))
|
||||
(sxml-display-as-text
|
||||
(read (snow-post cfg uri (cons '(fmt . "sexp") params))))
|
||||
(newline)))
|
||||
|
||||
(define (command/reg-key cfg spec)
|
||||
(let* ((keys (call-with-input-file
|
||||
|
|
|
|||
|
|
@ -167,7 +167,7 @@
|
|||
sxml)))
|
||||
(let lp ((sxml sxml))
|
||||
(cond
|
||||
((proper-list? sxml)
|
||||
((pair? sxml)
|
||||
(let ((tag (car sxml)))
|
||||
(cond
|
||||
;; skip headers and the menu
|
||||
|
|
@ -176,18 +176,16 @@
|
|||
(pair? (cdr sxml))
|
||||
(pair? (cadr sxml))
|
||||
(eq? '@ (car (cadr sxml)))
|
||||
(equal? '(id . "menu") (assq 'id (cdr (cadr sxml))))))
|
||||
)
|
||||
(equal? '(id . "menu") (assq 'id (cdr (cadr sxml)))))))
|
||||
;; recurse other tags, appending newlines for new sections
|
||||
((symbol? tag)
|
||||
(if (memq tag '(h1 h2 h3 h4 h5 h6))
|
||||
(newline out))
|
||||
(let ((ls (if (and (pair? (cdr sxml))
|
||||
(pair? (cadr sxml))
|
||||
(eq? '@ (car (cadr sxml))))
|
||||
(cddr sxml)
|
||||
(cdr sxml))))
|
||||
(for-each lp ls))
|
||||
(for-each
|
||||
lp
|
||||
(if (and (pair? (cdr sxml)) (eq? '@ (cadr sxml)))
|
||||
(cddr sxml)
|
||||
(cdr sxml)))
|
||||
(if (memq tag '(p li br h1 h2 h3 h4 h5 h6))
|
||||
(newline out)))
|
||||
(else
|
||||
|
|
|
|||
|
|
@ -4,5 +4,5 @@
|
|||
(define-library (chibi sxml)
|
||||
(export sxml->xml sxml-display-as-html sxml-display-as-text sxml-strip
|
||||
html-escape html-tag->string)
|
||||
(import (scheme base) (scheme list) (scheme write))
|
||||
(import (scheme base) (scheme write))
|
||||
(include "sxml.scm"))
|
||||
|
|
|
|||
|
|
@ -144,11 +144,10 @@
|
|||
(test name (call-with-values (lambda () expect) (lambda results results))
|
||||
(call-with-values (lambda () expr) (lambda results results))))))
|
||||
|
||||
;;> \macro{(test-error [name [pred]] expr)}
|
||||
;;> \macro{(test-error [name] expr)}
|
||||
|
||||
;;> Like \scheme{test} but evaluates \var{expr} and checks that it
|
||||
;;> raises an error. If \var{pred} is provided, the raised error
|
||||
;;> object must additionally satisfy the given type test.
|
||||
;;> raises an error.
|
||||
|
||||
(define-syntax test-error
|
||||
(syntax-rules ()
|
||||
|
|
@ -156,12 +155,8 @@
|
|||
(test-error #f expr))
|
||||
((_ name expr)
|
||||
(test-propagate-info name #f expr ((expect-error . #t))))
|
||||
((_ name pred expr)
|
||||
(test-propagate-info name #f expr ((expect-error . #t)
|
||||
(error-type-test . ,pred)
|
||||
(error-type-test-expr . pred))))
|
||||
((test a ...)
|
||||
(test-syntax-error 'test-error "1, 2, or 3 arguments required"
|
||||
(test-syntax-error 'test-error "1 or 2 arguments required"
|
||||
(test a ...)))))
|
||||
|
||||
;;> Low-level macro to pass alist info to the underlying \var{test-run}.
|
||||
|
|
@ -526,7 +521,6 @@
|
|||
(not (assq-ref info 'line-number)))
|
||||
`((file-name . ,(car (pair-source expr)))
|
||||
(line-number . ,(cdr (pair-source expr)))
|
||||
(format . ,(current-test-value-formatter))
|
||||
,@info)
|
||||
info)))
|
||||
|
||||
|
|
@ -541,12 +535,6 @@
|
|||
(expect))))
|
||||
(guard
|
||||
(exn
|
||||
((and (assq-ref info 'expect-error)
|
||||
(assq-ref info 'error-type-test))
|
||||
=> (lambda (pred)
|
||||
((current-test-reporter)
|
||||
(if (pred exn) 'PASS 'FAIL)
|
||||
(append `((exception . ,exn)) info))))
|
||||
(else
|
||||
((current-test-reporter)
|
||||
(if (assq-ref info 'expect-error) 'PASS 'ERROR)
|
||||
|
|
@ -585,20 +573,14 @@
|
|||
((SKIP) "-")
|
||||
(else "."))))
|
||||
|
||||
(define (display-expected/actual expected actual format)
|
||||
(let ((e-str (format expected))
|
||||
(a-str (format actual)))
|
||||
(if (and (equal? e-str a-str)
|
||||
(not (eqv? format write-to-string)))
|
||||
;; If the formatter can't display any difference, fall back to
|
||||
;; write-to-string.
|
||||
(display-expected/actual expected actual write-to-string)
|
||||
(let ((diff (diff e-str a-str read-char)))
|
||||
(write-string "expected ")
|
||||
(write-string (edits->string/color (car diff) (car (cddr diff)) 1))
|
||||
(write-string " but got ")
|
||||
(write-string (edits->string/color (cadr diff) (car (cddr diff)) 2))
|
||||
))))
|
||||
(define (display-expected/actual expected actual)
|
||||
(let* ((e-str (write-to-string expected))
|
||||
(a-str (write-to-string actual))
|
||||
(diff (diff e-str a-str read-char)))
|
||||
(write-string "expected ")
|
||||
(write-string (edits->string/color (car diff) (car (cddr diff)) 1))
|
||||
(write-string " but got ")
|
||||
(write-string (edits->string/color (cadr diff) (car (cddr diff)) 2))))
|
||||
|
||||
(define (test-print-explanation indent status info)
|
||||
(cond
|
||||
|
|
@ -613,20 +595,12 @@
|
|||
(display "assertion failed"))
|
||||
((and (eq? status 'FAIL) (assq-ref info 'expect-error))
|
||||
(display indent)
|
||||
(if (assq-ref info 'exception)
|
||||
(begin
|
||||
(display "error should satisfy ")
|
||||
(write (assq-ref info 'error-type-test-expr))
|
||||
(display " but raised ")
|
||||
(write (assq-ref info 'exception)))
|
||||
(begin
|
||||
(display "expected an error but got ")
|
||||
(write (assq-ref info 'result)))))
|
||||
(display "expected an error but got ")
|
||||
(write (assq-ref info 'result)))
|
||||
((eq? status 'FAIL)
|
||||
(display indent)
|
||||
(display-expected/actual (assq-ref info 'expected)
|
||||
(assq-ref info 'result)
|
||||
(or (assq-ref info 'format) write-to-string))))
|
||||
(display-expected/actual
|
||||
(assq-ref info 'expected) (assq-ref info 'result))))
|
||||
;; print variables
|
||||
(cond
|
||||
((and (memq status '(FAIL ERROR)) (assq-ref info 'var-names))
|
||||
|
|
@ -871,11 +845,6 @@
|
|||
|
||||
;;> \section{Parameters}
|
||||
|
||||
;;> If specified, takes a single object as input (the expected or
|
||||
;;> actual value of a test) and returns the string representation
|
||||
;;> (default \scheme{write-to-string}).
|
||||
(define current-test-value-formatter (make-parameter #f))
|
||||
|
||||
;;> The current test group as started by \scheme{test-group} or
|
||||
;;> \scheme{test-begin}.
|
||||
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@
|
|||
test-get-name! test-group-name test-group-ref
|
||||
test-group-set! test-group-inc! test-group-push!
|
||||
;; parameters
|
||||
current-test-value-formatter current-test-verbosity
|
||||
current-test-verbosity
|
||||
current-test-applier current-test-skipper current-test-reporter
|
||||
current-test-group-reporter test-failure-count
|
||||
current-test-epsilon current-test-comparator
|
||||
|
|
|
|||
|
|
@ -187,22 +187,12 @@
|
|||
(lp (cdr ls) (+ i v-len)))))))
|
||||
|
||||
(define (vector-map proc vec . lov)
|
||||
(cond
|
||||
((null? lov)
|
||||
(let lp ((i (vector-length vec)) (res '()))
|
||||
(if (zero? i)
|
||||
(list->vector res)
|
||||
(lp (- i 1) (cons (proc (vector-ref vec (- i 1))) res)))))
|
||||
((null? (cdr lov))
|
||||
(let ((vec2 (car lov)))
|
||||
(if (null? lov)
|
||||
(let lp ((i (vector-length vec)) (res '()))
|
||||
(if (zero? i)
|
||||
(list->vector res)
|
||||
(lp (- i 1)
|
||||
(cons (proc (vector-ref vec (- i 1)) (vector-ref vec2 (- i 1)))
|
||||
res))))))
|
||||
(else
|
||||
(list->vector (apply map proc (map vector->list (cons vec lov)))))))
|
||||
(lp (- i 1) (cons (proc (vector-ref vec (- i 1))) res))))
|
||||
(list->vector (apply map proc (map vector->list (cons vec lov))))))
|
||||
|
||||
(define (vector-for-each proc vec . lov)
|
||||
(if (null? lov)
|
||||
|
|
|
|||
|
|
@ -4,5 +4,4 @@
|
|||
(export as-red as-blue as-green as-cyan as-yellow
|
||||
as-magenta as-white as-black
|
||||
as-bold as-underline)
|
||||
(begin (define (make-state-variable . o) #f))
|
||||
(include "../166/color.scm"))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
|
||||
(define-library (srfi 160 mini-test)
|
||||
(import (scheme base) (scheme inexact)
|
||||
(import (scheme base)
|
||||
(srfi 160 base) (srfi 160 f8) (srfi 160 f16)
|
||||
(chibi test))
|
||||
(export run-tests)
|
||||
|
|
@ -82,11 +82,7 @@
|
|||
(test '#f16(1 2)
|
||||
(vector->f16vector '#(0 1 2 3) 1 3))
|
||||
(test '#(1.0 2.0)
|
||||
(f16vector->vector '#f16(0 1 2 3) 1 3))
|
||||
(test '(-inf.0 -1.0 -0.0 0.0 1.0 +inf.0)
|
||||
(f16vector->list
|
||||
'#f16(-inf.0 -1.0 -0.0 0.0 1.0 +inf.0)))
|
||||
(test-assert (nan? (f16vector-ref '#f16(+nan.0) 0)))
|
||||
(f16vector->vector '#f16(0 1 2 3) 1 3))
|
||||
)
|
||||
|
||||
(test-end))))
|
||||
|
|
|
|||
|
|
@ -334,7 +334,6 @@
|
|||
|
||||
(define (array-freeze! array)
|
||||
(%array-setter-set! array #f)
|
||||
(make-immutable! (array-body array))
|
||||
array)
|
||||
|
||||
;; Indexing
|
||||
|
|
|
|||
|
|
@ -46,9 +46,4 @@
|
|||
specialized-getter specialized-setter
|
||||
array-freeze!
|
||||
)
|
||||
(cond-expand
|
||||
(chibi
|
||||
(import (only (chibi) make-immutable!)))
|
||||
(else
|
||||
(begin (define-syntax make-immutable! (syntax-rules () ((_ x) #f))))))
|
||||
(include "base.scm"))
|
||||
|
|
|
|||
|
|
@ -2188,19 +2188,6 @@
|
|||
(array-curry (list*->array 3 '(((4 7) (2 6)) ((1 0) (0 1))))
|
||||
2)
|
||||
0)))
|
||||
(let* ((A (array-copy
|
||||
(make-array (make-interval '#(0 0) '#(10 10))
|
||||
(lambda (i j) (inexact (+ (* i 10.) j))))
|
||||
f32-storage-class))
|
||||
(A3 (array-ref (array-curry A 1) 3)))
|
||||
(test 37. (array-ref A 3 7))
|
||||
(test 37. (array-ref A3 7))
|
||||
(array-set! A 0. 3 7)
|
||||
(test 0. (array-ref A 3 7))
|
||||
(test 0. (array-ref A3 7))
|
||||
(array-freeze! A)
|
||||
(test-error (array-set! A 1. 3 7))
|
||||
(test-error (array-set! A3 1. 7)))
|
||||
|
||||
;; (test-error
|
||||
;; (array-curry (make-array (make-interval '#(0 0) '#(1 1)) list) 0))
|
||||
|
|
|
|||
|
|
@ -47,16 +47,16 @@
|
|||
u64vector-ref u64vector-set! u64? u64vector? make-u64vector u64vector-length 0)
|
||||
|
||||
(define-storage-class f32-storage-class
|
||||
f32vector-ref f32vector-set! f32? f32vector? make-f32vector f32vector-length 0.)
|
||||
f32vector-ref f32vector-set! f32? f32vector? make-f32vector f32vector-length 0)
|
||||
|
||||
(define-storage-class f64-storage-class
|
||||
f64vector-ref f64vector-set! f64? f64vector? make-f64vector f64vector-length 0.)
|
||||
f64vector-ref f64vector-set! f64? f64vector? make-f64vector f64vector-length 0)
|
||||
|
||||
(define-storage-class c64-storage-class
|
||||
c64vector-ref c64vector-set! c64? c64vector? make-c64vector c64vector-length 0.+0.i)
|
||||
c64vector-ref c64vector-set! c64? c64vector? make-c64vector c64vector-length 0)
|
||||
|
||||
(define-storage-class c128-storage-class
|
||||
c128vector-ref c128vector-set! c128? c128vector? make-c128vector c128vector-length 0.+0.i)
|
||||
c128vector-ref c128vector-set! c128? c128vector? make-c128vector c128vector-length 0)
|
||||
|
||||
(define-storage-class char-storage-class
|
||||
(lambda (vec i) (integer->char (u32vector-ref vec i)))
|
||||
|
|
|
|||
|
|
@ -1,24 +0,0 @@
|
|||
(define-library (srfi 35)
|
||||
(import (srfi 35 internal))
|
||||
(export make-condition-type
|
||||
condition-type?
|
||||
make-condition
|
||||
condition?
|
||||
condition-has-type?
|
||||
condition-ref
|
||||
make-compound-condition
|
||||
extract-condition
|
||||
define-condition-type
|
||||
condition
|
||||
|
||||
&condition
|
||||
|
||||
&message
|
||||
message-condition?
|
||||
condition-message
|
||||
|
||||
&serious
|
||||
serious-condition?
|
||||
|
||||
&error
|
||||
error?))
|
||||
|
|
@ -1,249 +0,0 @@
|
|||
(define-record-type Simple-Condition
|
||||
(make-simple-condition)
|
||||
simple-condition?)
|
||||
|
||||
(define-record-type Compound-Condition
|
||||
(%make-compound-condition components)
|
||||
compound-condition?
|
||||
(components compound-condition-components))
|
||||
|
||||
(define (make-condition-type id parent field-names)
|
||||
(make-rtd id
|
||||
(list->vector
|
||||
(map
|
||||
(lambda (field-name)
|
||||
(list 'immutable field-name))
|
||||
field-names))
|
||||
parent))
|
||||
|
||||
(define (condition? obj)
|
||||
(or (simple-condition? obj)
|
||||
(compound-condition? obj)))
|
||||
|
||||
(define (condition-type? obj)
|
||||
(condition-subtype? obj Simple-Condition))
|
||||
|
||||
(define (condition-subtype? maybe-child-ct maybe-parent-ct)
|
||||
(and (rtd? maybe-child-ct)
|
||||
(or (eqv? maybe-child-ct maybe-parent-ct)
|
||||
(condition-subtype? (rtd-parent maybe-child-ct)
|
||||
maybe-parent-ct))))
|
||||
|
||||
(define (condition-type-ancestors ct)
|
||||
(unfold (lambda (a) (not (condition-type? a)))
|
||||
(lambda (a) a)
|
||||
(lambda (a) (rtd-parent a))
|
||||
ct))
|
||||
|
||||
(define (condition-type-common-ancestor ct_1 ct_2)
|
||||
(let ((ct_1-as (condition-type-ancestors ct_1))
|
||||
(ct_2-as (condition-type-ancestors ct_2)))
|
||||
(find (lambda (a)
|
||||
(memv a ct_2-as))
|
||||
ct_1-as)))
|
||||
|
||||
(define (make-condition ct . plist)
|
||||
(define *undef* (cons '*undef* '()))
|
||||
(let* ((field-names (rtd-all-field-names ct))
|
||||
(field-values (make-vector (vector-length field-names) *undef*)))
|
||||
(let loop ((property plist))
|
||||
(if (null? property)
|
||||
(cond ((vector-any (lambda (name value)
|
||||
(and (eq? value *undef*) name))
|
||||
field-names
|
||||
field-values)
|
||||
=> (lambda (undef-field-name)
|
||||
(error "make-condition: value not given for field"
|
||||
undef-field-name
|
||||
ct)))
|
||||
(else
|
||||
(apply (rtd-constructor ct) (vector->list field-values))))
|
||||
(let ((idx (vector-index (lambda (x) (eq? x (car property)))
|
||||
field-names)))
|
||||
(if idx
|
||||
(begin
|
||||
(vector-set! field-values idx (cadr property))
|
||||
(loop (cddr property)))
|
||||
(error "make-condition: unknown field" (car property))))))))
|
||||
|
||||
(define (make-compound-condition . cs)
|
||||
(if (= (length cs) 1)
|
||||
(car cs)
|
||||
;; SRFI 35 requires at least one component, but R6RS doesn’t;
|
||||
;; defer to R6RS’s less strict error checking (!)
|
||||
(%make-compound-condition
|
||||
(append-map
|
||||
(lambda (c)
|
||||
(if (simple-condition? c)
|
||||
(list c)
|
||||
(compound-condition-components c)))
|
||||
cs))))
|
||||
|
||||
(define (condition-has-type? c ct)
|
||||
(if (simple-condition? c)
|
||||
(is-a? c ct)
|
||||
(any
|
||||
(lambda (comp) (condition-has-type? comp ct))
|
||||
(compound-condition-components c))))
|
||||
|
||||
(define (condition-ref c field-name)
|
||||
(if (simple-condition? c)
|
||||
((rtd-accessor (record-rtd c) field-name) c)
|
||||
(condition-ref
|
||||
(find
|
||||
(lambda (comp)
|
||||
(find field-name
|
||||
(vector->list
|
||||
(rtd-all-field-names (record-rtd c)))))
|
||||
(compound-condition-components c))
|
||||
field-name)))
|
||||
|
||||
(define (simple-conditions c)
|
||||
(if (simple-condition? c)
|
||||
(list c)
|
||||
(compound-condition-components c)))
|
||||
|
||||
(define (extract-condition c ct)
|
||||
(if (and (simple-condition? c)
|
||||
(condition-has-type? c ct))
|
||||
c
|
||||
(find
|
||||
(lambda (comp)
|
||||
(condition-has-type? comp ct))
|
||||
(compound-condition-components ct))))
|
||||
|
||||
(define (condition-predicate ct)
|
||||
(lambda (obj)
|
||||
(and (condition? obj)
|
||||
(condition-has-type? obj ct))))
|
||||
(define (condition-accessor ct proc)
|
||||
(lambda (c)
|
||||
(cond ((and (simple-condition? c)
|
||||
(condition-has-type? c ct))
|
||||
(proc c))
|
||||
((find (lambda (comp) (condition-has-type? comp ct))
|
||||
(compound-condition-components c))
|
||||
=> (lambda (comp)
|
||||
(proc comp)))
|
||||
(else (error "condition-accessor: condition does not have the right type"
|
||||
c ct)))))
|
||||
|
||||
(define-syntax define-condition-type/constructor
|
||||
(syntax-rules ()
|
||||
((_ name parent constructor predicate
|
||||
(field-name field-accessor) ...)
|
||||
(begin
|
||||
(define ct (make-condition-type 'name
|
||||
parent
|
||||
'(field-name ...)))
|
||||
(define name ct)
|
||||
(define constructor (rtd-constructor ct))
|
||||
(define predicate (condition-predicate ct))
|
||||
(define field-accessor
|
||||
(condition-accessor ct
|
||||
(rtd-accessor ct 'field-name))) ...))))
|
||||
|
||||
(define-syntax define-condition-type
|
||||
(syntax-rules ()
|
||||
((_ name parent predicate (field-name field-accessor) ...)
|
||||
(define-condition-type/constructor
|
||||
name parent blah-ignored predicate
|
||||
(field-name field-accessor) ...))))
|
||||
|
||||
(define (%condition . specs)
|
||||
(define (find-common-field-spec ct name)
|
||||
(let loop ((more-specs specs))
|
||||
(if (null? more-specs)
|
||||
#f
|
||||
(let* ((other-ct (caar more-specs))
|
||||
(field-specs (cdar more-specs))
|
||||
(a (condition-type-common-ancestor ct other-ct)))
|
||||
(cond ((and (vector-index
|
||||
(lambda (n)
|
||||
(eq? n name))
|
||||
(rtd-all-field-names a))
|
||||
(assq name field-specs)))
|
||||
(else (loop (cdr more-specs))))))))
|
||||
(let loop ((more-specs specs)
|
||||
(components '()))
|
||||
(if (null? more-specs)
|
||||
(apply make-compound-condition (reverse components))
|
||||
(let* ((this-spec (car more-specs))
|
||||
(ct (car this-spec))
|
||||
(field-specs (cdr this-spec))
|
||||
(field-names (rtd-all-field-names ct))
|
||||
(field-values
|
||||
(vector-map
|
||||
(lambda (field-name)
|
||||
(cond ((assq field-name field-specs) => cdr)
|
||||
((find-common-field-spec ct field-name) => cdr)
|
||||
(else
|
||||
(error "condition: value not given for field"
|
||||
field-name
|
||||
ct))))
|
||||
field-names)))
|
||||
(loop
|
||||
(cdr more-specs)
|
||||
(cons
|
||||
(apply (rtd-constructor ct) (vector->list field-values))
|
||||
components))))))
|
||||
(define-syntax condition
|
||||
(syntax-rules ()
|
||||
((_ (ct (field-name field-value) ...) ...)
|
||||
(%condition (list ct (cons 'field-name field-value) ...) ...))))
|
||||
|
||||
(define &condition Simple-Condition)
|
||||
|
||||
(define-condition-type/constructor &message &condition
|
||||
make-message-condition message-condition?
|
||||
(message condition-message))
|
||||
|
||||
(define-condition-type/constructor &serious &condition
|
||||
make-serious-condition serious-condition?)
|
||||
|
||||
(define-condition-type/constructor &error &serious
|
||||
make-error error?)
|
||||
|
||||
;; (chibi repl) support
|
||||
(define-method (repl-print-exception (exn condition?) (out output-port?))
|
||||
(define components (simple-conditions exn))
|
||||
(define n-components (length components))
|
||||
(display "CONDITION: " out)
|
||||
(display n-components out)
|
||||
(display " component" out)
|
||||
(if (not (= n-components 1)) (display "s" out))
|
||||
(display "\n" out)
|
||||
(for-each
|
||||
(lambda (component idx)
|
||||
(define component-type (record-rtd component))
|
||||
(display " " out)
|
||||
(display idx out)
|
||||
(display ". " out)
|
||||
(display (rtd-name component-type) out)
|
||||
(display "\n" out)
|
||||
(let loop ((as (reverse
|
||||
(condition-type-ancestors component-type)))
|
||||
(idx 0))
|
||||
(if (not (null? as))
|
||||
(let ((a (car as)))
|
||||
(let a-loop ((fields (vector->list (rtd-field-names a)))
|
||||
(idx idx))
|
||||
(if (null? fields)
|
||||
(loop (cdr as) idx)
|
||||
(begin
|
||||
(display " " out)
|
||||
(display (if (pair? (car fields))
|
||||
(car (cdar fields))
|
||||
(car fields))
|
||||
out)
|
||||
(if (not (eqv? a component-type))
|
||||
(begin
|
||||
(display " (" out)
|
||||
(display (rtd-name a) out)
|
||||
(display ")" out)))
|
||||
(display ": " out)
|
||||
(write (slot-ref component-type component idx) out)
|
||||
(display "\n" out)
|
||||
(a-loop (cdr fields) (+ idx 1)))))))))
|
||||
components
|
||||
(iota n-components 1)))
|
||||
|
|
@ -1,48 +0,0 @@
|
|||
(define-library (srfi 35 internal)
|
||||
(import (except (scheme base)
|
||||
define-record-type
|
||||
;; exclude (srfi 1 immutable) duplicate imports:
|
||||
map cons list append reverse)
|
||||
(scheme write)
|
||||
(only (chibi)
|
||||
slot-ref
|
||||
is-a?)
|
||||
(only (chibi repl) repl-print-exception)
|
||||
(only (chibi generic) define-method)
|
||||
;; don’t let people go messing with a compound condition
|
||||
;; components list:
|
||||
(srfi 1 immutable)
|
||||
(srfi 99)
|
||||
(srfi 133))
|
||||
(export make-condition-type
|
||||
condition?
|
||||
condition-type?
|
||||
condition-subtype?
|
||||
make-condition
|
||||
make-compound-condition
|
||||
condition-has-type?
|
||||
condition-ref
|
||||
simple-conditions
|
||||
extract-condition
|
||||
condition-predicate
|
||||
condition-accessor
|
||||
define-condition-type/constructor
|
||||
define-condition-type
|
||||
condition
|
||||
|
||||
&condition
|
||||
|
||||
&message
|
||||
make-message-condition
|
||||
message-condition?
|
||||
condition-message
|
||||
|
||||
&serious
|
||||
make-serious-condition
|
||||
serious-condition?
|
||||
|
||||
&error
|
||||
make-error
|
||||
error?)
|
||||
|
||||
(include "internal.scm"))
|
||||
|
|
@ -1,94 +0,0 @@
|
|||
(define-library (srfi 35 test)
|
||||
(import (scheme base)
|
||||
(srfi 35 internal)
|
||||
(chibi test))
|
||||
(export run-tests)
|
||||
(begin
|
||||
(define (run-tests)
|
||||
(test-begin "srfi-35: condition types")
|
||||
(test-group "Adapted from the SRFI 35 examples"
|
||||
(define-condition-type &c &condition
|
||||
c?
|
||||
(x c-x))
|
||||
|
||||
(define-condition-type &c1 &c
|
||||
c1?
|
||||
(a c1-a))
|
||||
|
||||
(define-condition-type &c2 &c
|
||||
c2?
|
||||
(b c2-b))
|
||||
(define v1 (make-condition &c1 'x "V1" 'a "a1"))
|
||||
(define v2 (condition (&c2
|
||||
(x "V2")
|
||||
(b "b2"))))
|
||||
(define v3 (condition (&c1
|
||||
(x "V3/1")
|
||||
(a "a3"))
|
||||
(&c2
|
||||
(b "b3"))))
|
||||
(define v4 (make-compound-condition v1 v2))
|
||||
(define v5 (make-compound-condition v2 v3))
|
||||
|
||||
(test #t (c? v1))
|
||||
(test #t (c1? v1))
|
||||
(test #f (c2? v1))
|
||||
(test "V1" (c-x v1))
|
||||
(test "a1" (c1-a v1))
|
||||
|
||||
(test #t (c? v2))
|
||||
(test #f (c1? v2))
|
||||
(test #t (c2? v2))
|
||||
(test "V2" (c-x v2))
|
||||
(test "b2" (c2-b v2))
|
||||
|
||||
(test #t (c? v3))
|
||||
(test #t (c1? v3))
|
||||
(test #t (c2? v3))
|
||||
(test "V3/1" (c-x v3))
|
||||
(test "a3" (c1-a v3))
|
||||
(test "b3" (c2-b v3))
|
||||
|
||||
(test #t (c? v4))
|
||||
(test #t (c1? v4))
|
||||
(test #t (c2? v4))
|
||||
(test "V1" (c-x v4))
|
||||
(test "a1" (c1-a v4))
|
||||
(test "b2" (c2-b v4))
|
||||
|
||||
(test #t (c? v5))
|
||||
(test #t (c1? v5))
|
||||
(test #t (c2? v5))
|
||||
(test "V2" (c-x v5))
|
||||
(test "a3" (c1-a v5))
|
||||
(test "b2" (c2-b v5)))
|
||||
|
||||
(test-group "Standard condition hierarchy"
|
||||
(let ((mc (make-message-condition "foo!")))
|
||||
(test #t (message-condition? mc))
|
||||
(test "foo!" (condition-message mc))
|
||||
|
||||
(let ((ec (make-error)))
|
||||
(test #t (error? ec))
|
||||
(test #t (serious-condition? ec))
|
||||
|
||||
(let ((cc (make-compound-condition ec mc)))
|
||||
(test #t (error? cc))
|
||||
(test #t (serious-condition? cc))
|
||||
(test #t (message-condition? cc))
|
||||
(test "foo!" (condition-message mc))))))
|
||||
|
||||
(test-group "R6RS extension: shadowing field names"
|
||||
(define-condition-type/constructor &a &condition
|
||||
make-a a?
|
||||
(val a-val))
|
||||
(define-condition-type/constructor &b &a
|
||||
make-b b?
|
||||
(val b-val))
|
||||
|
||||
(define c (make-b 'a 'b))
|
||||
|
||||
(test 'a (a-val c))
|
||||
(test 'b (b-val c)))
|
||||
|
||||
(test-end))))
|
||||
|
|
@ -9,13 +9,7 @@
|
|||
(type? x))
|
||||
|
||||
(define (rtd-constructor rtd . o)
|
||||
(let ((fields
|
||||
(if (pair? o)
|
||||
(map
|
||||
(lambda (field)
|
||||
(rtd-field-offset rtd field))
|
||||
(vector->list (car o)))
|
||||
(iota (vector-length (rtd-all-field-names rtd)))))
|
||||
(let ((fields (vector->list (if (pair? o) (car o) (rtd-all-field-names rtd))))
|
||||
(make (make-constructor (type-name rtd) rtd)))
|
||||
(lambda args
|
||||
(let ((res (make)))
|
||||
|
|
@ -24,7 +18,7 @@
|
|||
((null? a) (if (null? p) res (error "not enough args" p)))
|
||||
((null? p) (error "too many args" a))
|
||||
(else
|
||||
(slot-set! rtd res (car p) (car a))
|
||||
(slot-set! rtd res (rtd-field-offset rtd (car p)) (car a))
|
||||
(lp (cdr a) (cdr p)))))))))
|
||||
|
||||
(define (rtd-predicate rtd)
|
||||
|
|
@ -41,13 +35,13 @@
|
|||
|
||||
(define (rtd-field-offset rtd field)
|
||||
(let ((p (type-parent rtd)))
|
||||
(or (let ((i (field-index-of (type-slots rtd) field)))
|
||||
(or (and (type? p)
|
||||
(rtd-field-offset p field))
|
||||
(let ((i (field-index-of (type-slots rtd) field)))
|
||||
(and i
|
||||
(if (type? p)
|
||||
(+ i (vector-length (rtd-all-field-names p)))
|
||||
i)))
|
||||
(and (type? p)
|
||||
(rtd-field-offset p field)))))
|
||||
i))))))
|
||||
|
||||
(define (rtd-accessor rtd field)
|
||||
(make-getter (type-name rtd) rtd (rtd-field-offset rtd field)))
|
||||
|
|
|
|||
|
|
@ -1,8 +1,5 @@
|
|||
|
||||
(define-library (srfi 99 records procedural)
|
||||
(export make-rtd rtd? rtd-constructor rtd-predicate rtd-accessor rtd-mutator)
|
||||
(import (chibi)
|
||||
(chibi ast)
|
||||
(only (srfi 1) iota)
|
||||
(srfi 99 records inspection))
|
||||
(import (chibi) (chibi ast) (srfi 99 records inspection))
|
||||
(include "procedural.scm"))
|
||||
|
|
|
|||
32
sexp.c
32
sexp.c
|
|
@ -2890,13 +2890,6 @@ sexp sexp_make_ratio (sexp ctx, sexp num, sexp den) {
|
|||
sexp sexp_ratio_normalize (sexp ctx, sexp rat, sexp in) {
|
||||
sexp tmp;
|
||||
sexp_gc_var2(num, den);
|
||||
if (sexp_exact_negativep(sexp_ratio_denominator(rat))) {
|
||||
/* Prevent overflow in the sexp_negate. */
|
||||
if (sexp_ratio_numerator(rat) == sexp_make_fixnum(SEXP_MIN_FIXNUM))
|
||||
sexp_ratio_numerator(rat) = sexp_fixnum_to_bignum(ctx, sexp_ratio_numerator(rat));
|
||||
sexp_negate(sexp_ratio_numerator(rat));
|
||||
sexp_negate(sexp_ratio_denominator(rat));
|
||||
}
|
||||
num = sexp_ratio_numerator(rat), den = sexp_ratio_denominator(rat);
|
||||
if (den == SEXP_ZERO)
|
||||
return sexp_read_error(ctx, "zero denominator in ratio", rat, in);
|
||||
|
|
@ -2916,9 +2909,6 @@ sexp sexp_ratio_normalize (sexp ctx, sexp rat, sexp in) {
|
|||
sexp_ratio_numerator(rat)
|
||||
= sexp_quotient(ctx, sexp_ratio_numerator(rat), num);
|
||||
if (sexp_exact_negativep(sexp_ratio_denominator(rat))) {
|
||||
/* Prevent overflow in the sexp_negate. */
|
||||
if (sexp_ratio_numerator(rat) == sexp_make_fixnum(SEXP_MIN_FIXNUM))
|
||||
sexp_ratio_numerator(rat) = sexp_fixnum_to_bignum(ctx, sexp_ratio_numerator(rat));
|
||||
sexp_negate(sexp_ratio_numerator(rat));
|
||||
sexp_negate(sexp_ratio_denominator(rat));
|
||||
}
|
||||
|
|
@ -3029,8 +3019,7 @@ sexp sexp_read_number (sexp ctx, sexp in, int base, int exactp) {
|
|||
} else if (c=='/') {
|
||||
sexp_gc_preserve2(ctx, res, den);
|
||||
den = sexp_read_number(ctx, in, base, exactp);
|
||||
if (! (sexp_fixnump(den) || sexp_bignump(den) ||
|
||||
(sexp_complexp(den) && sexp_exactp(sexp_complex_real(den)) && sexp_exactp(sexp_complex_imag(den)))))
|
||||
if (! (sexp_fixnump(den) || sexp_bignump(den) || sexp_complexp(den)))
|
||||
res = (sexp_exceptionp(den)
|
||||
? den : sexp_read_error(ctx, "invalid rational syntax", den, in));
|
||||
else {
|
||||
|
|
@ -3217,23 +3206,16 @@ static float int_as_float(const unsigned int n) {
|
|||
|
||||
/* https://arxiv.org/abs/2112.08926 */
|
||||
double sexp_half_to_double(unsigned short x) {
|
||||
unsigned int e, m, v;
|
||||
if (x == 31744) return INFINITY;
|
||||
if (x == 32767) return NAN;
|
||||
if (x == 64512) return -INFINITY;
|
||||
e = (x&0x7C00)>>10;
|
||||
m = (x&0x03FF)<<13;
|
||||
v = float_as_int((float)m)>>23;
|
||||
unsigned int e = (x&0x7C00)>>10,
|
||||
m = (x&0x03FF)<<13,
|
||||
v = float_as_int((float)m)>>23;
|
||||
return int_as_float((x&0x8000)<<16 | (e!=0)*((e+112)<<23|m) | ((e==0)&(m!=0))*((v-37)<<23|((m<<(150-v))&0x007FE000)));
|
||||
}
|
||||
|
||||
unsigned short sexp_double_to_half(double x) {
|
||||
unsigned int b, e, m;
|
||||
if (isnan(x)) return 32767;
|
||||
if (isinf(x)) return x < 0 ? 64512 : 31744;
|
||||
b = float_as_int(x)+0x00001000;
|
||||
e = (b&0x7F800000)>>23;
|
||||
m = b&0x007FFFFF;
|
||||
unsigned int b = float_as_int(x)+0x00001000,
|
||||
e = (b&0x7F800000)>>23,
|
||||
m = b&0x007FFFFF;
|
||||
return (b&0x80000000)>>16 | (e>112)*((((e-112)<<10)&0x7C00)|m>>13) | ((e<113)&(e>101))*((((0x007FF000+m)>>(125-e))+1)>>1) | (e>143)*0x7FFF;
|
||||
}
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -8,7 +8,6 @@
|
|||
(rename (srfi 18 test) (run-tests run-srfi-18-tests))
|
||||
(rename (srfi 26 test) (run-tests run-srfi-26-tests))
|
||||
(rename (srfi 27 test) (run-tests run-srfi-27-tests))
|
||||
(rename (srfi 35 test) (run-tests run-srfi-35-tests))
|
||||
(rename (srfi 38 test) (run-tests run-srfi-38-tests))
|
||||
(rename (srfi 41 test) (run-tests run-srfi-41-tests))
|
||||
(rename (srfi 69 test) (run-tests run-srfi-69-tests))
|
||||
|
|
@ -84,7 +83,6 @@
|
|||
(run-srfi-18-tests)
|
||||
(run-srfi-26-tests)
|
||||
(run-srfi-27-tests)
|
||||
(run-srfi-35-tests)
|
||||
(run-srfi-38-tests)
|
||||
(run-srfi-41-tests)
|
||||
(run-srfi-69-tests)
|
||||
|
|
|
|||
27
vm.c
27
vm.c
|
|
@ -912,12 +912,12 @@ static sexp sexp_restore_stack (sexp ctx, sexp saved) {
|
|||
return SEXP_VOID;
|
||||
}
|
||||
|
||||
#define _ARG1 (stack[top-1])
|
||||
#define _ARG2 (stack[top-2])
|
||||
#define _ARG3 (stack[top-3])
|
||||
#define _ARG4 (stack[top-4])
|
||||
#define _ARG5 (stack[top-5])
|
||||
#define _ARG6 (stack[top-6])
|
||||
#define _ARG1 stack[top-1]
|
||||
#define _ARG2 stack[top-2]
|
||||
#define _ARG3 stack[top-3]
|
||||
#define _ARG4 stack[top-4]
|
||||
#define _ARG5 stack[top-5]
|
||||
#define _ARG6 stack[top-6]
|
||||
#define _PUSH(x) (stack[top++]=(x))
|
||||
#define _POP() (stack[--top])
|
||||
|
||||
|
|
@ -1869,12 +1869,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
|
|||
if (sexp_flonum_value(_ARG1) == trunc(sexp_flonum_value(_ARG1)))
|
||||
_ARG1 = sexp_make_fixnum(sexp_flonum_value(_ARG1));
|
||||
#else
|
||||
if (tmp1 == sexp_make_fixnum(SEXP_MIN_FIXNUM) && tmp2 == SEXP_NEG_ONE) {
|
||||
_ARG1 = sexp_fixnum_to_bignum(ctx, tmp1);
|
||||
sexp_negate_exact(_ARG1);
|
||||
} else {
|
||||
_ARG1 = sexp_fx_div(tmp1, tmp2);
|
||||
}
|
||||
_ARG1 = sexp_fx_div(tmp1, tmp2);
|
||||
#endif
|
||||
#endif
|
||||
}
|
||||
|
|
@ -1901,11 +1896,9 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
|
|||
if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
|
||||
if (tmp2 == SEXP_ZERO)
|
||||
sexp_raise("divide by zero", SEXP_NULL);
|
||||
if (tmp1 == sexp_make_fixnum(SEXP_MIN_FIXNUM) && tmp2 == SEXP_NEG_ONE) {
|
||||
_ARG1 = sexp_fixnum_to_bignum(ctx, tmp1);
|
||||
sexp_negate_exact(_ARG1);
|
||||
} else {
|
||||
_ARG1 = sexp_fx_div(tmp1, tmp2);
|
||||
_ARG1 = sexp_fx_div(tmp1, tmp2);
|
||||
if ((sexp_sint_t)tmp1 < 0 && (sexp_sint_t)tmp2 < 0 && (sexp_sint_t)_ARG1 < 0) {
|
||||
_ARG1 = sexp_quotient(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2);
|
||||
}
|
||||
}
|
||||
#if SEXP_USE_BIGNUMS
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue