From 70089dacfa6bab5a1e1d0d5aa257e2d671493beb Mon Sep 17 00:00:00 2001 From: Taylan Kammer Date: Sat, 5 Apr 2025 17:11:29 +0200 Subject: uhhhh buncha changes --- _tests/test.zig | 10 +- docs/parser.md | 56 +- spec/parser.bnf | 23 +- src/test/data/parser-torture.scm | 132358 ------------------------------------ src/test/parse.zig | 70 +- src/test/strings.zig | 14 +- src/test/values.zig | 49 +- src/zisp.zig | 3 +- src/zisp/gc.zig | 60 +- src/zisp/io/Parser.zig | 165 +- src/zisp/io/unparser.zig | 98 +- src/zisp/lib/list.zig | 8 +- src/zisp/value.zig | 432 +- src/zisp/value/boole.zig | 4 +- src/zisp/value/char.zig | 4 +- src/zisp/value/fixnum.zig | 6 +- src/zisp/value/istr.zig | 51 +- src/zisp/value/pair.zig | 36 +- src/zisp/value/ptr.zig | 134 +- src/zisp/value/rune.zig | 35 +- src/zisp/value/seq.zig | 3 +- src/zisp/value/sstr.zig | 39 +- 22 files changed, 635 insertions(+), 133023 deletions(-) delete mode 100644 src/test/data/parser-torture.scm diff --git a/_tests/test.zig b/_tests/test.zig index e746851..7e86ed2 100644 --- a/_tests/test.zig +++ b/_tests/test.zig @@ -5,9 +5,15 @@ pub fn main() u8 { // const x: struct { u8, u64, u8 } = y; // @import("std").debug.print("{}\n", .{x[0] + x[1] + x[2]}); - std.debug.print("{}\n", .{@sizeOf(struct { u64, ?u8 })}); + // std.debug.print("{}\n", .{@sizeOf(struct { u64, ?u8 })}); - return while (true) if (true) break 1; + // return while (true) if (true) break 1; + + const x: ?*u64 = null; + const y: ?*u32 = @ptrCast(x); + _ = y; + + return 0; } // const x: ?u8 = 5; diff --git a/docs/parser.md b/docs/parser.md index a4e5d78..eb41362 100644 --- a/docs/parser.md +++ b/docs/parser.md @@ -4,39 +4,38 @@ Zisp s-expressions are defined in terms of an extremely minimal set of data types; only that which is necessary to build representations of more complex expressions and data types: - +--------+-----------------+---------------+--------+----------+------+ - | TYPE | Bare String | Quoted String | Rune | Pair | Nil | - +--------+-----------------+---------------+--------+----------+------+ - | E.G. | foo, |foo bar| | "foo bar" | #name | (X . Y) | () | - +--------+-----------------+---------------+--------+----------+------+ - -Bare strings and quoted strings are polymorphic sub-types of the generic -string type. Bare strings are implicitly interned. + +--------+-----------------+--------+----------+------+ + | TYPE | String | Rune | Pair | Nil | + +--------+-----------------+--------+----------+------+ + | E.G. | foo, |foo bar| | #name | (X . Y) | () | + +--------+-----------------+--------+----------+------+ The parser can also output non-negative integers, but this is only used for datum labels; number literals are handled by the decoder (see next section). -The parser recognizes various "syntax sugar" and transforms it into uses of -the above data types. The most ubiquitous example is of course the list: +The parser recognizes various "syntax sugar" and transforms it into uses of the +above data types. The most ubiquitous example is of course the list: (datum1 datum2 ...) -> (datum1 . (datum2 . (... . ()))) The following table summarizes the other supported transformations: - #datum -> (#HASH . datum) #rune(...) -> (#rune ...) + "xyz" -> (#QUOTE . |xyz|) #datum -> (#HASH . datum) + + [...] -> (#SQUARE ...) #rune(...) -> (#rune ...) - [...] -> (#SQUARE ...) dat1dat2 -> (#JOIN dat1 . dat2) + {...} -> (#BRACE ...) dat1dat2 -> (#JOIN dat1 . dat2) - {...} -> (#BRACE ...) dat1.dat2 -> (#DOT dat1 . dat2) + 'datum -> (#QUOTE . datum) dat1.dat2 -> (#DOT dat1 . dat2) - 'datum -> (#QUOTE . datum) dat1:dat2 -> (#COLON dat1 . dat2) + `datum -> (#GRAVE . datum) dat1:dat2 -> (#COLON dat1 . dat2) - `datum -> (#GRAVE . datum) #%hex% -> (#LABEL . hex) + ,datum -> (#COMMA . datum) #%hex% -> (#LABEL . hex) - ,datum -> (#COMMA . datum) #%hex=datum -> (#LABEL hex . datum) + #%hex=datum -> (#LABEL hex . datum) -A separate process called "decoding" can transform these objects into other -data types. For example, `(#HASH x y z)` could become a vector, so that the +A separate process called "decoding" can transform such data into more complex +types. For example, `(#HASH x y z)` could be decoded into a vector, so the expression `#(x y z)` works just like in Scheme. See the next section for details about the decoder. @@ -50,19 +49,12 @@ Further notes about the syntax sugar table and examples above: means zero or more data; hex is a hexadecimal number of up to 12 digits. * The `#datum` form only applies when the datum following the hash sign is a - list, quoted string, quote expression, another expression starting with a - hash sign, a bare string starting with a backslash escape (see next), or a - pipe-quoted bare string (see next). - -* A backslash causes the immediately following character to lose any special - meaning it would have, and be considered as part of a bare string instead. - (This does not apply to space or control characters.) For example, the - following three character sequences are each a valid bare string: - - foo\(bar\) \]blah \#\'xyz + list, quoted string, quote expression, another expression starting with the + hash sign, or a pipe-quoted bare string (see next). A bare string can follow + the hash sign by separating the two with a backslash: `#\string` - Bare strings can also be "quoted" with pipes as in Scheme; it should be - noted that this still produces a "bare string" in terms of data type: +* Bare strings can be "quoted" with pipes as in Scheme; it should be noted that + this still produces a "bare string" in terms of data type: |foo bar baz| @@ -79,7 +71,7 @@ Further notes about the syntax sugar table and examples above: #rune'string -> (#rune #QUOTE . string) As a counter-example, following a rune immediately with a bare string isn't - possible, since it's ambiguous: + possible without the delimiting backslash, since that would be ambiguous: #abcdefgh ;Could be (#abcdef . gh) or (#abcde . fgh) or ... @@ -117,6 +109,6 @@ Further notes about the syntax sugar table and examples above: diff --git a/spec/parser.bnf b/spec/parser.bnf index caa24f3..338dc10 100644 --- a/spec/parser.bnf +++ b/spec/parser.bnf @@ -17,11 +17,11 @@ skip_line : ( ~LF )* LF? ; one_datum : bare_string | clad_datum ; -bare_string : ( '.' | '+' | '-' | DIGIT ) ( bare_str_elt | '.' )* - | bare_str_elt+ +bare_string : ( '.' | '+' | '-' | DIGIT ) ( bare_char | '.' )* + | bare_char+ ; -clad_datum : '\' bare_esc_str +clad_datum : '\' bare_string | '|' pipe_str_elt* '|' | '"' quot_str_elt* '"' | '#' hash_expr @@ -32,16 +32,20 @@ clad_datum : '\' bare_esc_str ; -bare_str_elt : bare_char | '\' bare_esc ; +bare_char : ALPHA | DIGIT | bare_punct ; +bare_punct : '!' | '$' | '%' | '&' | '*' | '+' | '-' | '/' + | '<' | '=' | '>' | '?' | '@' | '^' | '_' | '~' + ; -bare_esc_str : bare_esc bare_str_elt* ; pipe_str_elt : ~( '|' | '\' ) | '\' pipe_esc ; quot_str_elt : ~( '"' | '\' ) | '\' quot_esc ; hash_expr : rune clad_datum? + | rune '\' bare_string + | '\' bare_string | '%' label ( '%' | '=' datum ) | clad_datum ; @@ -51,15 +55,6 @@ list : unit* ( '.' unit )? blank* ; quote_expr : ( "'" | "`" | "," ) datum ; -bare_char : ALPHA | DIGIT | bare_punct ; - -bare_punct : '!' | '$' | '%' | '&' | '*' | '+' | '-' | '/' - | '<' | '=' | '>' | '?' | '@' | '^' | '_' | '~' - ; - -bare_esc : 33...126 ; - - pipe_esc : string_esc | '|' ; quot_esc : string_esc | '"' ; diff --git a/src/test/data/parser-torture.scm b/src/test/data/parser-torture.scm deleted file mode 100644 index d475379..0000000 --- a/src/test/data/parser-torture.scm +++ /dev/null @@ -1,132358 +0,0 @@ -;;; rnrs exceptions (6) --- R6RS exceptions - -;; Copyright (C) 2013 Taylan Ulrich Bayırlı/Kammer - -;; Author: Taylan Ulrich Bayırlı/Kammer -;; Keywords: ffi struct bytevector bytestructure - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;; Commentary: - -;; A clean implementation of (rnrs exceptions (6)). The dynamic environment -;; capturing operations are noteworthy. - - -;;; Code: - -(library - (rnrs exceptions (6)) - (export with-exception-handler raise raise-continuable guard) - (import (rnrs base (6)) - (srfi 39)) - -;;; Helpers - -;;; Ignores any extra `else' clauses. -;;; Helps to generate cond clauses with a default `else' clause. - (define-syntax cond+ - (syntax-rules (else) - ((cond+ clause ... (else else1) (else else2)) - (cond+ clause ... (else else1))) - ((cond+ clause ...) - (cond clause ...)))) - -;;; Captures the current dynamic environment. It is reified as a procedure that -;;; accepts a thunk and executes it in the captured dynenv. - (define (capture-dynenv) - ((call/cc - (lambda (captured-env) - (lambda () - (lambda (proc) - (call/cc - (lambda (go-back) - (captured-env - (lambda () - (call-with-values proc go-back))))))))))) - -;;; Captures the current dynamic environment and returns a procedure that -;;; accepts as many arguments as PROC and applies PROC to them in that dynenv. -;;; In other words, returns a version of PROC that's tied to the current dynenv. - (define (dynenv-proc proc) - (let ((env (capture-dynenv))) - (lambda args - (env (lambda () (apply proc args)))))) - -;;; Returns a procedure that's always executed in the current dynamic -;;; environment and not the one from which it's called. - (define-syntax dynenv-lambda - (syntax-rules () - ((_ args body body* ...) - (dynenv-proc (lambda args body body* ...))))) - - -;;; Main code: - - (define handlers (make-parameter '())) - - (define &non-continuable '&non-continuable) - - (define (with-exception-handler handler thunk) - (parameterize ((handlers (cons handler (handlers)))) - (thunk))) - - (define (%raise condition continuable?) - (if (null? (handlers)) - (error "unhandled exception" condition) - (let ((handler (car (handlers)))) - (parameterize ((handlers (cdr (handlers)))) - (if continuable? - (handler condition) - (begin - (handler condition) - (%raise &non-continuable #f))))))) - - (define (raise-continuable condition) - (%raise condition #t)) - - (define (raise condition) - (%raise condition #f)) - - (define-syntax guard - (syntax-rules () - ((guard (var clause clause* ...) - body body* ...) - (call/cc - (lambda (return) - (let ((handler (dynenv-lambda (var re-raise) - (return - (cond+ clause - clause* - ... - (else (re-raise))))))) - (with-exception-handler - (lambda (condition) - (let ((re-raise (dynenv-lambda () - (raise condition)))) - (handler condition re-raise))) - (lambda () - body body* ...)))))))) - ) -(define-module (test) - #\use-module (bytestructures guile)) - -(display cstring-pointer) -(newline) -;;; align.scm --- Alignment calculation helpers. - -;; Copyright © 2018 Taylan Kammer - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;; Commentary: - - -;;; Code: - -;;; Either remains at 'position' or rounds up to the next multiple of -;;; 'alignment' depending on whether 'size' (if not greater than 'alignment') -;;; would fit. Returns three values: the chosen position, the start of the -;;; alignment boundary of the chosen position, and the bit offset of the chosen -;;; position from the start of the alignment boundary. A bit is represented by -;;; the value 1/8. -(define (align position size alignment) - (let* ((integer (floor position)) - (fraction (- position integer))) - (let-values (((prev-boundary-index offset) (floor/ integer alignment))) - (let* ((prev-boundary (* prev-boundary-index alignment)) - (next-boundary (+ prev-boundary alignment))) - (if (< next-boundary (+ position (min size alignment))) - (values next-boundary next-boundary 0) - (values position prev-boundary (* 8 (+ offset fraction)))))))) - -;;; Returns 'position' if it's already a multiple of 'alignment'; otherwise -;;; returns the next multiple. -(define (next-boundary position alignment) - (align position +inf.0 alignment)) - -;;; align.scm ends here -;;; bytestructures --- Structured access to bytevector contents. - -;; Copyright © 2015, 2016 Taylan Kammer - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;; Commentary: - -;; This is the base of the module, defining the data types and procedures that -;; make up the bytestructures framework. - - -;;; Code: - -;;; Descriptors - -(define-record-type - (%make-bytestructure-descriptor size alignment unwrapper getter setter meta) - bytestructure-descriptor? - (size bd-size) - (alignment bd-alignment) - (unwrapper bd-unwrapper) - (getter bd-getter) - (setter bd-setter) - (meta bd-meta)) - -(define make-bytestructure-descriptor - (case-lambda - ((size alignment unwrapper getter setter) - (%make-bytestructure-descriptor - size alignment unwrapper getter setter #f)) - ((size alignment unwrapper getter setter meta) - (%make-bytestructure-descriptor - size alignment unwrapper getter setter meta)))) - -(define bytestructure-descriptor-size - (case-lambda - ((descriptor) (bytestructure-descriptor-size descriptor #f #f)) - ((descriptor bytevector offset) - (let ((size (bd-size descriptor))) - (if (procedure? size) - (size #f bytevector offset) - size))))) - -(define (bytestructure-descriptor-size/syntax bytevector offset descriptor) - (let ((size (bd-size descriptor))) - (if (procedure? size) - (size #t bytevector offset) - size))) - -(define bytestructure-descriptor-alignment bd-alignment) -(define bytestructure-descriptor-unwrapper bd-unwrapper) -(define bytestructure-descriptor-getter bd-getter) -(define bytestructure-descriptor-setter bd-setter) -(define bytestructure-descriptor-metadata bd-meta) - - -;;; Bytestructures - -(define-record-type - (make-bytestructure bytevector offset descriptor) - bytestructure? - (bytevector bytestructure-bytevector) - (offset bytestructure-offset) - (descriptor bytestructure-descriptor)) - -(define bytestructure - (case-lambda ((descriptor) (%bytestructure descriptor #f #f)) - ((descriptor values) (%bytestructure descriptor #t values)))) - -(define (%bytestructure descriptor init? values) - (let ((bytevector (make-bytevector - (bytestructure-descriptor-size descriptor)))) - (when init? - (bytestructure-primitive-set! bytevector 0 descriptor values)) - (make-bytestructure bytevector 0 descriptor))) - -(define (bytestructure-size bytestructure) - (bytestructure-descriptor-size (bytestructure-descriptor bytestructure) - (bytestructure-bytevector bytestructure) - (bytestructure-offset bytestructure))) - -(define-syntax-rule (bytestructure-unwrap ...) - (let ((bytestructure )) - (let ((bytevector (bytestructure-bytevector bytestructure)) - (offset (bytestructure-offset bytestructure)) - (descriptor (bytestructure-descriptor bytestructure))) - (bytestructure-unwrap* bytevector offset descriptor ...)))) - -(define-syntax bytestructure-unwrap* - (syntax-rules () - ((_ ) - (values )) - ((_ ...) - (let ((bytevector ) - (offset ) - (descriptor )) - (let ((unwrapper (bd-unwrapper descriptor))) - (when (not unwrapper) - (error "Cannot index through this descriptor." descriptor)) - (let-values (((bytevector* offset* descriptor*) - (unwrapper #f bytevector offset ))) - (bytestructure-unwrap* - bytevector* offset* descriptor* ...))))))) - -(define-syntax-rule (bytestructure-ref ...) - (let-values (((bytevector offset descriptor) - (bytestructure-unwrap ...))) - (bytestructure-primitive-ref bytevector offset descriptor))) - -(define-syntax-rule (bytestructure-ref* - ...) - (let-values (((bytevector offset descriptor) - (bytestructure-unwrap* - ...))) - (bytestructure-primitive-ref bytevector offset descriptor))) - -(define (bytestructure-primitive-ref bytevector offset descriptor) - (let ((getter (bd-getter descriptor))) - (if getter - (getter #f bytevector offset) - (make-bytestructure bytevector offset descriptor)))) - -(define-syntax-rule (bytestructure-set! ... ) - (let-values (((bytevector offset descriptor) - (bytestructure-unwrap ...))) - (bytestructure-primitive-set! bytevector offset descriptor ))) - -(define-syntax-rule (bytestructure-set!* - ... ) - (let-values (((bytevector offset descriptor) - (bytestructure-unwrap* - ...))) - (bytestructure-primitive-set! bytevector offset descriptor ))) - -(define (bytestructure-primitive-set! bytevector offset descriptor value) - (let ((setter (bd-setter descriptor))) - (if setter - (setter #f bytevector offset value) - (if (bytevector? value) - (bytevector-copy! bytevector offset value 0 - (bytestructure-descriptor-size - descriptor bytevector offset)) - (error "Cannot write value with this bytestructure descriptor." - value descriptor))))) - -(define (bytestructure-ref/dynamic bytestructure . indices) - (let-values (((bytevector offset descriptor) - (bytestructure-unwrap bytestructure))) - (let loop ((bytevector bytevector) - (offset offset) - (descriptor descriptor) - (indices indices)) - (if (null? indices) - (bytestructure-primitive-ref bytevector offset descriptor) - (let-values (((bytevector* offset* descriptor*) - (bytestructure-unwrap* - bytevector offset descriptor (car indices)))) - (loop bytevector* - offset* - descriptor* - (cdr indices))))))) - -(define (bytestructure-set!/dynamic bytestructure . args) - (let-values (((bytevector offset descriptor) - (bytestructure-unwrap bytestructure))) - (let loop ((bytevector bytevector) - (offset offset) - (descriptor descriptor) - (args args)) - (if (null? (cdr args)) - (bytestructure-primitive-set! bytevector offset descriptor (car args)) - (let-values (((bytevector* offset* descriptor*) - (bytestructure-unwrap* - bytevector offset descriptor (car args)))) - (loop bytevector* - offset* - descriptor* - (cdr args))))))) - -(define-syntax-case-stubs - bytestructure-unwrap/syntax - bytestructure-ref/syntax - bytestructure-set!/syntax - define-bytestructure-accessors) - -(cond-expand - (guile (include-from-path "bytestructures/body/base.syntactic.scm")) - (syntax-case (include "base.syntactic.scm")) - (else)) - -;;; base.scm ends here -;;; bytestructures --- Structured access to bytevector contents. - -;; Copyright © 2015 Taylan Kammer - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;; Commentary: - -;; This is an extension to the base of the module which allows using the API -;; purely in the macro-expand phase, which puts some limitations on its use but -;; reduces run-time overhead to zero or nearly zero. - - -;;; Code: - -(define-syntax-rule (syntax-case-lambda ) - (lambda (stx) - (syntax-case stx () - ( )))) - -(define syntax-car (syntax-case-lambda (car . cdr) #'car)) -(define syntax-cdr (syntax-case-lambda (car . cdr) #'cdr)) -(define syntax-null? (syntax-case-lambda stx (null? (syntax->datum #'stx)))) - -(define (syntactic-unwrap bytevector offset descriptor indices) - (let loop ((bytevector bytevector) - (offset offset) - (descriptor descriptor) - (indices indices)) - (if (not (syntax-null? indices)) - (let ((unwrapper (bd-unwrapper descriptor))) - (when (not unwrapper) - (error "Cannot index through this descriptor." descriptor)) - (let-values (((bytevector* offset* descriptor*) - (unwrapper #t bytevector offset (syntax-car indices)))) - (loop bytevector* offset* descriptor* (syntax-cdr indices)))) - (let ((getter (bd-getter descriptor)) - (setter (bd-setter descriptor))) - (values bytevector offset descriptor getter setter))))) - -(define (bytestructure-unwrap/syntax bytevector offset descriptor indices) - (let-values (((bytevector* offset* _descriptor _getter _setter) - (syntactic-unwrap bytevector offset descriptor indices))) - #`(values #,bytevector* #,offset*))) - -(define (bytestructure-ref/syntax bytevector offset descriptor indices) - (let-values (((bytevector* offset* descriptor* getter _setter) - (syntactic-unwrap bytevector offset descriptor indices))) - (if getter - (getter #t bytevector* offset*) - (error "The indices given to bytestructure-ref/syntax do not lead to a -bytestructure descriptor that can decode values. You must have used the wrong -getter macro, forgot to provide some of the indices, or meant to use the -unwrapper instead of the getter. The given indices follow." indices)))) - -(define (bytestructure-set!/syntax bytevector offset descriptor indices value) - (let-values (((bytevector* offset* descriptor* _getter setter) - (syntactic-unwrap bytevector offset descriptor indices))) - (if setter - (setter #t bytevector* offset* value) - (error "The indices given to bytestructure-set!/syntax do not lead to a -bytestructure descriptor that can encode values. You must have used the wrong -setter macro, or forgot to provide some of the indices. The given indices -follow." indices)))) - -(define-syntax-rule (define-bytestructure-unwrapper ) - (define-syntax - (let ((descriptor )) - (syntax-case-lambda (_ . ) - (bytestructure-unwrap/syntax - #' #' descriptor #'))))) - -(define-syntax-rule (define-bytestructure-getter* ) - (define-syntax - (let ((descriptor )) - (syntax-case-lambda (_ . ) - (bytestructure-ref/syntax - #' #' descriptor #'))))) - -(define-syntax-rule (define-bytestructure-setter* ) - (define-syntax - (let ((descriptor )) - (syntax-case-lambda (_ (... ...) ) - (bytestructure-set!/syntax - #' #' descriptor #'( (... ...)) #'))))) - -(define-syntax-rule (define-bytestructure-getter ) - (define-syntax - (let ((descriptor )) - (syntax-case-lambda (_ . ) - (bytestructure-ref/syntax #' 0 descriptor #'))))) - -(define-syntax-rule (define-bytestructure-setter ) - (define-syntax - (let ((descriptor )) - (syntax-case-lambda (_ (... ...) ) - (bytestructure-set!/syntax - #' 0 descriptor #'( (... ...)) #'))))) - -(define-syntax define-bytestructure-accessors - (syntax-rules () - ((_ ) - (begin - (define-bytestructure-unwrapper ) - (define-bytestructure-getter ) - (define-bytestructure-setter ))) - ((_ ) - (begin - (define-bytestructure-unwrapper ) - (define-bytestructure-getter ) - (define-bytestructure-setter ) - (define-bytestructure-getter* ) - (define-bytestructure-setter* ))))) - -;; Local Variables: -;; eval: (put (quote syntax-case-lambda) (quote scheme-indent-function) 1) -;; End: - -;;; base.syntactic.scm ends here -;;; bitfields.scm --- Struct bitfield constructor. - -;; Copyright © 2015, 2016 Taylan Kammer - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;; Commentary: - -;; This module is complementary to the struct module. It isn't used on its own. - -;; This code partly uses rational numbers for byte counts and offsets, to -;; represent granularity down to bits. I.e. 1/8 is a size or offset of one bit. - - -;;; Code: - -;;; Only a macro for efficiency reasons. -(define-syntax bit-field/signed - (syntax-rules () - ((_ ) - (let ((unsigned-value (bit-field ))) - (if (not ) - unsigned-value - (let ((sign (bit-set? (- 1) unsigned-value))) - (if sign - (- unsigned-value (expt 2 )) - unsigned-value))))))) - -(define (validate-integer-descriptor descriptor) - (when (not (assq descriptor integer-descriptors)) - (error "Invalid descriptor for bitfield." descriptor))) - -(define (integer-descriptor-signed? descriptor) - (assq descriptor signed-integer-descriptors)) - -(define integer-descriptor-signed->unsigned-mapping - (map cons - (map car signed-integer-descriptors) - (map car unsigned-integer-descriptors))) - -(define (integer-descriptor-signed->unsigned descriptor) - (cdr (assq descriptor integer-descriptor-signed->unsigned-mapping))) - -(define (unsigned-integer-descriptor integer-descriptor) - (if (integer-descriptor-signed? integer-descriptor) - (integer-descriptor-signed->unsigned integer-descriptor) - integer-descriptor)) - -(define-record-type - (make-bitfield-metadata int-descriptor width) - bitfield-metadata? - (int-descriptor bitfield-metadata-int-descriptor) - (width bitfield-metadata-width)) - -(define (bitfield-descriptor int-descriptor bit-offset width) - (validate-integer-descriptor int-descriptor) - (let ((signed? (integer-descriptor-signed? int-descriptor)) - (uint-descriptor (unsigned-integer-descriptor int-descriptor))) - (let ((num-getter (bytestructure-descriptor-getter uint-descriptor)) - (num-setter (bytestructure-descriptor-setter uint-descriptor))) - (define start bit-offset) - (define end (+ start width)) - (define (getter syntax? bytevector offset) - (let ((num (num-getter syntax? bytevector offset))) - (if syntax? - (quasisyntax - (bit-field/signed (unsyntax num) (unsyntax width) - (unsyntax start) (unsyntax end) - (unsyntax signed?))) - (bit-field/signed num width start end signed?)))) - (define (setter syntax? bytevector offset value) - (let* ((oldnum (num-getter syntax? bytevector offset)) - (newnum (if syntax? - (quasisyntax - (copy-bit-field (unsyntax oldnum) (unsyntax value) - (unsyntax start) (unsyntax end))) - (copy-bit-field oldnum value start end)))) - (num-setter syntax? bytevector offset newnum))) - (define meta (make-bitfield-metadata int-descriptor width)) - (make-bytestructure-descriptor #f #f #f getter setter meta)))) - -;;; bitfields.scm ends here -;;; explicit-endianness.scm --- Auxiliary bytevector operations. - -;; Copyright © 2015 Taylan Kammer - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;; Commentary: - -;; The numeric module requires top-level bindings to bytevector procedures with -;; an explicit endianness, instead of the ones that take an endianness -;; argument. This library provides them. - - -;;; Code: - -(define-syntax define-explicit-endianness-getters - (syntax-rules () - ((_ (original le-name be-name) ...) - (begin - (begin - (define (le-name bytevector index) - (original bytevector index (endianness little))) - (define (be-name bytevector index) - (original bytevector index (endianness big)))) - ...)))) - -(define-explicit-endianness-getters - (bytevector-ieee-single-ref bytevector-ieee-single-le-ref - bytevector-ieee-single-be-ref) - (bytevector-ieee-double-ref bytevector-ieee-double-le-ref - bytevector-ieee-double-be-ref) - (bytevector-s16-ref bytevector-s16le-ref - bytevector-s16be-ref) - (bytevector-u16-ref bytevector-u16le-ref - bytevector-u16be-ref) - (bytevector-s32-ref bytevector-s32le-ref - bytevector-s32be-ref) - (bytevector-u32-ref bytevector-u32le-ref - bytevector-u32be-ref) - (bytevector-s64-ref bytevector-s64le-ref - bytevector-s64be-ref) - (bytevector-u64-ref bytevector-u64le-ref - bytevector-u64be-ref)) - -(define-syntax define-explicit-endianness-setters - (syntax-rules () - ((_ (original le-name be-name) ...) - (begin - (begin - (define (le-name bytevector index value) - (original bytevector index value (endianness little))) - (define (be-name bytevector index value) - (original bytevector index value (endianness big)))) - ...)))) - -(define-explicit-endianness-setters - (bytevector-ieee-single-set! bytevector-ieee-single-le-set! - bytevector-ieee-single-be-set!) - (bytevector-ieee-double-set! bytevector-ieee-double-le-set! - bytevector-ieee-double-be-set!) - (bytevector-s16-set! bytevector-s16le-set! - bytevector-s16be-set!) - (bytevector-u16-set! bytevector-u16le-set! - bytevector-u16be-set!) - (bytevector-s32-set! bytevector-s32le-set! - bytevector-s32be-set!) - (bytevector-u32-set! bytevector-u32le-set! - bytevector-u32be-set!) - (bytevector-s64-set! bytevector-s64le-set! - bytevector-s64be-set!) - (bytevector-u64-set! bytevector-u64le-set! - bytevector-u64be-set!)) - -;;; explicit-endianness.scm ends here -;;; numeric.scm --- Numeric types as supported by (rnrs bytevectors). - -;; Copyright © 2015, 2016 Taylan Kammer - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;; Commentary: - -;; This module defines descriptors for numeric types of specific size, and -;; native or specific endianness, as made possible by the bytevector referencing -;; and assigning procedures in the (rnrs bytevectors) module. - -;; We use the strange cond-expand/runtime macro to make sure that certain checks -;; for CPU architecture and data model are done at library-load-time and not -;; compile time, since one might cross-compile the library. - - -;;; Code: - -(define base-environment - (cond-expand - (guile-2 - (current-module)) - (else - (environment '(scheme base))))) - -(define-syntax cond-expand/runtime - (syntax-rules () - ((_ ( ) ...) - (let ((const (eval '(cond-expand ( ') ...) - base-environment))) - (cond - ((equal? const ') ) - ...))))) - -(define i8align 1) - -(define i16align 2) - -(define i32align 4) - -(define i64align - (cond-expand/runtime - (i386 4) - (else 8))) - -(define f32align 4) - -(define f64align - (cond-expand/runtime - (i386 4) - (else 8))) - -(define-syntax-rule (make-numeric-descriptor ) - (let () - (define size ) - (define alignment ) - (define (getter syntax? bytevector offset) - (if syntax? - (quasisyntax - ( (unsyntax bytevector) (unsyntax offset))) - ( bytevector offset))) - (define (setter syntax? bytevector offset value) - (if syntax? - (quasisyntax - ( (unsyntax bytevector) (unsyntax offset) (unsyntax value))) - ( bytevector offset value))) - (make-bytestructure-descriptor size alignment #f getter setter))) - -(define-syntax-rule (define-numeric-descriptors - ( ) - ...) - (begin - (define - (make-numeric-descriptor )) - ... - (define (list (list ' ) ...)))) - -(define-numeric-descriptors - signed-integer-native-descriptors - (int8 1 i8align bytevector-s8-ref bytevector-s8-set!) - (int16 2 i16align bytevector-s16-native-ref bytevector-s16-native-set!) - (int32 4 i32align bytevector-s32-native-ref bytevector-s32-native-set!) - (int64 8 i64align bytevector-s64-native-ref bytevector-s64-native-set!)) - -(define-numeric-descriptors - unsigned-integer-native-descriptors - (uint8 1 i8align bytevector-u8-ref bytevector-u8-set!) - (uint16 2 i16align bytevector-u16-native-ref bytevector-u16-native-set!) - (uint32 4 i32align bytevector-u32-native-ref bytevector-u32-native-set!) - (uint64 8 i64align bytevector-u64-native-ref bytevector-u64-native-set!)) - -(define-numeric-descriptors - float-native-descriptors - (float32 4 f32align - bytevector-ieee-single-native-ref - bytevector-ieee-single-native-set!) - (float64 8 f64align - bytevector-ieee-double-native-ref - bytevector-ieee-double-native-set!)) - -(define-syntax-rule (define-with-endianness - ( ) - ...) - (begin - (define - (if (equal? (native-endianness)) - - (make-numeric-descriptor ))) - ... - (define (list (list ' ) ...)))) - -(define-with-endianness - signed-integer-le-descriptors (endianness little) - (int16le 2 i16align int16 bytevector-s16le-ref bytevector-s16le-set!) - (int32le 4 i32align int32 bytevector-s32le-ref bytevector-s32le-set!) - (int64le 8 i64align int64 bytevector-s64le-ref bytevector-s64le-set!)) - -(define-with-endianness - signed-integer-be-descriptors (endianness big) - (int16be 2 i16align int16 bytevector-s16be-ref bytevector-s16be-set!) - (int32be 4 i32align int32 bytevector-s32be-ref bytevector-s32be-set!) - (int64be 8 i64align int64 bytevector-s64be-ref bytevector-s64be-set!)) - -(define-with-endianness - unsigned-integer-le-descriptors (endianness little) - (uint16le 2 i16align uint16 bytevector-u16le-ref bytevector-u16le-set!) - (uint32le 4 i32align uint32 bytevector-u32le-ref bytevector-u32le-set!) - (uint64le 8 i64align uint64 bytevector-u64le-ref bytevector-u64le-set!)) - -(define-with-endianness - unsigned-integer-be-descriptors (endianness big) - (uint16be 2 i16align uint16 bytevector-u16be-ref bytevector-u16be-set!) - (uint32be 4 i32align uint32 bytevector-u32be-ref bytevector-u32be-set!) - (uint64be 8 i64align uint64 bytevector-u64be-ref bytevector-u64be-set!)) - -(define-with-endianness - float-le-descriptors (endianness little) - (float32le 4 f32align float32 - bytevector-ieee-single-le-ref - bytevector-ieee-single-le-set!) - (float64le 8 f64align float64 - bytevector-ieee-double-le-ref - bytevector-ieee-double-le-set!)) - -(define-with-endianness - float-be-descriptors (endianness big) - (float32be 4 f32align float32 - bytevector-ieee-single-be-ref - bytevector-ieee-single-be-set!) - (float64be 8 f64align float64 - bytevector-ieee-double-be-ref - bytevector-ieee-double-be-set!)) - -(define-syntax-rule (make-complex-descriptor - ) - (let () - (define size (* 2 )) - (define alignment ) - (define (getter syntax? bytevector offset) - (if syntax? - (quasisyntax - (let ((real ( (unsyntax bytevector) - (unsyntax offset))) - (imag ( (unsyntax bytevector) - (+ (unsyntax offset) )))) - (make-rectangular real imag))) - (let ((real ( bytevector offset)) - (imag ( bytevector (+ offset )))) - (make-rectangular real imag)))) - (define (setter syntax? bytevector offset value) - (if syntax? - (quasisyntax - (let ((val (unsyntax value))) - (let ((real (real-part val)) - (imag (imag-part val))) - ( (unsyntax bytevector) - (unsyntax offset) - real) - ( (unsyntax bytevector) - (+ (unsyntax offset) ) - imag)))) - (let ((real (real-part value)) - (imag (imag-part value))) - ( bytevector offset real) - ( bytevector (+ offset ) imag)))) - (make-bytestructure-descriptor size alignment #f getter setter))) - -(define-syntax-rule (define-complex-descriptors - ( - ) - ...) - (begin - (define - (make-complex-descriptor - )) - ... - (define (list (list ' ) - ...)))) - -(define-complex-descriptors - complex-native-descriptors - (complex64 4 f32align - bytevector-ieee-single-native-ref - bytevector-ieee-single-native-set!) - (complex128 8 f64align - bytevector-ieee-double-native-ref - bytevector-ieee-double-native-set!)) - -(define-syntax-rule (define-complex-with-endianness - ( - ) - ...) - (begin - (define - (if (equal? (native-endianness)) - - (make-complex-descriptor - ))) - ... - (define (list (list ' ) - ...)))) - -(define-complex-with-endianness - complex-le-descriptors (endianness little) - (complex64le 4 f32align complex64 - bytevector-ieee-single-le-ref - bytevector-ieee-single-le-set!) - (complex128le 8 f64align complex128 - bytevector-ieee-double-le-ref - bytevector-ieee-double-le-set!)) - -(define-complex-with-endianness - complex-be-descriptors (endianness big) - (complex64be 4 f32align complex64 - bytevector-ieee-single-be-ref - bytevector-ieee-single-be-set!) - (complex128be 8 f64align complex128 - bytevector-ieee-double-be-ref - bytevector-ieee-double-be-set!)) - -(define signed-integer-descriptors - (append signed-integer-native-descriptors - signed-integer-le-descriptors - signed-integer-be-descriptors)) - -(define unsigned-integer-descriptors - (append unsigned-integer-native-descriptors - unsigned-integer-le-descriptors - unsigned-integer-be-descriptors)) - -(define integer-descriptors - (append signed-integer-descriptors unsigned-integer-descriptors)) - -(define float-descriptors - (append float-native-descriptors - float-le-descriptors - float-be-descriptors)) - -(define complex-descriptors - (append complex-native-descriptors - complex-le-descriptors - complex-be-descriptors)) - -(define numeric-descriptors - (append integer-descriptors float-descriptors complex-descriptors)) - -(define short int16) -(define unsigned-short uint16) - -(define int (cond-expand/runtime - (lp32 int16) - (ilp64 int64) - (else int32))) - -(define unsigned-int (cond-expand/runtime - (lp32 uint16) - (ilp64 uint64) - (else uint32))) - -(define long (cond-expand/runtime - (ilp64 int64) - (lp64 int64) - (else int32))) - -(define unsigned-long (cond-expand/runtime - (ilp64 uint64) - (lp64 uint64) - (else uint32))) - -(define long-long int64) -(define unsigned-long-long uint64) - -(define arch32bit? (cond-expand/runtime - (lp32 #t) - (ilp32 #t) - (else #f))) - -(define intptr_t (if arch32bit? - int32 - int64)) - -(define uintptr_t (if arch32bit? - uint32 - uint64)) - -(define size_t uintptr_t) - -(define ssize_t intptr_t) - -(define ptrdiff_t intptr_t) - -(define float float32) -(define double float64) - -;;; numeric.scm ends here -;;; string.scm --- Strings in encodings supported by (rnrs bytevectors). - -;; Copyright © 2017 Taylan Kammer - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;; Commentary: - -;; This module defines descriptors for strings encoded in various encodings, as -;; supported by (rnrs bytevectors). - - -;;; Code: - -(define (ascii->string bytevector start end) - (let ((string (utf8->string bytevector start end))) - (when (not (= (string-length string) (bytevector-length bytevector))) - (error "Bytevector contains non-ASCII characters." bytevector)) - string)) - -(define (string->ascii string) - (let ((bytevector (string->utf8 string))) - (when (not (= (string-length string) (bytevector-length bytevector))) - (error "String contains non-ASCII characters." string)) - bytevector)) - -(define (bytevector->string bytevector offset size encoding) - (case encoding - ((ascii) (ascii->string bytevector offset (+ offset size))) - ((utf8) (utf8->string bytevector offset (+ offset size))) - (else - (let ((bytevector (bytevector-copy bytevector offset (+ offset size)))) - (case encoding - ((utf16le) (utf16->string bytevector 'little #t)) - ((utf16be) (utf16->string bytevector 'big #t)) - ((utf32le) (utf32->string bytevector 'little #t)) - ((utf32be) (utf32->string bytevector 'big #t)) - (else (error "Unknown string encoding." encoding))))))) - -(define (string->bytevector string encoding) - (case encoding - ((ascii) (string->ascii string)) - ((utf8) (string->utf8 string)) - ((utf16le) (string->utf16 string 'little)) - ((utf16be) (string->utf16 string 'big)) - ((utf32le) (string->utf32 string 'little)) - ((utf32be) (string->utf32 string 'big)))) - -;;; Note: because macro output may not contain raw symbols, we cannot output -;;; (quote foo) for raw symbol foo either, so there's no way to inject symbol -;;; literals into macro output. Hence we inject references to the following -;;; variables instead. - -(define ascii 'ascii) -(define utf8 'utf8) -(define utf16le 'utf16le) -(define utf16be 'utf16be) -(define utf32le 'utf32le) -(define utf32be 'utf32be) - -;;; Make sure this returns a boolean and not any other type of value, as the -;;; output will be part of macro output. -(define (fixed-width-encoding? encoding) - (not (not (memq encoding '(ascii utf32le utf32be))))) - -(define (bytevector-zero! bv start end) - (do ((i start (+ i 1))) - ((= i end)) - (bytevector-u8-set! bv i #x00))) - -(define (bs:string size encoding) - (define alignment 1) - (define (getter syntax? bytevector offset) - (if syntax? - (quasisyntax - (bytevector->string (unsyntax bytevector) - (unsyntax offset) - (unsyntax size) - (unsyntax - (datum->syntax (syntax utf8) encoding)))) - (bytevector->string bytevector offset size encoding))) - (define (setter syntax? bytevector offset string) - (if syntax? - (quasisyntax - (let* ((bv (string->bytevector - (unsyntax string) - (unsyntax - (datum->syntax (syntax utf8) encoding)))) - (length (bytevector-length bv))) - (when (> length (unsyntax size)) - (error "String too long." (unsyntax string))) - (when (and (unsyntax (fixed-width-encoding? encoding)) - (< length (unsyntax size))) - (error "String too short." (unsyntax string))) - (bytevector-copy! (unsyntax bytevector) - (unsyntax offset) - bv) - (when (not (unsyntax (fixed-width-encoding? encoding))) - (bytevector-zero! (unsyntax bytevector) - (+ (unsyntax offset) (bytevector-length bv)) - (+ (unsyntax offset) (unsyntax size)))))) - (let* ((bv (string->bytevector string encoding)) - (length (bytevector-length bv))) - (when (> length size) - (error "String too long." string)) - (when (and (fixed-width-encoding? encoding) (< length size)) - (error "String too short." string)) - (bytevector-copy! bytevector offset bv) - (when (not (fixed-width-encoding? encoding)) - (bytevector-zero! bytevector - (+ offset (bytevector-length bv)) - (+ offset size)))))) - (make-bytestructure-descriptor size alignment #f getter setter)) - -;;; string.scm ends here -;;; struct.scm --- Struct descriptor constructor. - -;; Copyright © 2015, 2016, 2021 Taylan Kammer - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;; Commentary: - -;; This constructor allows the creation of struct descriptors with named and -;; ordered fields with a specific content descriptor. - -;; This code partly uses rational numbers for byte counts and offsets, to -;; represent granularity down to bits. I.e. 1/8 is a size or offset of one bit. - - -;;; Code: - -(define (pack-alignment pack alignment) - (case pack - ((#t) 1) - ((#f) alignment) - (else (min pack alignment)))) - -(define-record-type - (make-field name descriptor size alignment position) - field? - (name field-name) - (descriptor field-descriptor) - (size field-size) - (alignment field-alignment) - (position field-position)) - -(define (construct-normal-field pack position name descriptor) - (let*-values - (((size) - (bytestructure-descriptor-size descriptor)) - ((alignment) - (pack-alignment pack (bytestructure-descriptor-alignment descriptor))) - ((position _boundary _bit-offset) - (align position size alignment))) - (values (make-field name descriptor size alignment position) - (+ position size)))) - -(define (construct-bit-field pack position name descriptor width) - (if (zero? width) - (let* ((alignment (bytestructure-descriptor-alignment descriptor)) - (position (next-boundary position alignment))) - (values (make-field #f descriptor 0 1 position) - position)) - (let*-values - (((int-size) - (bytestructure-descriptor-size descriptor)) - ((size) - (* 1/8 width)) - ((int-alignment) - (bytestructure-descriptor-alignment descriptor)) - ((alignment) - (pack-alignment pack int-alignment)) - ((position boundary offset) - (align position size alignment)) - ((descriptor) - (bitfield-descriptor descriptor offset width))) - (values (make-field name descriptor int-size alignment boundary) - (+ position size))))) - -(define (construct-fields pack field-specs) - (let loop ((field-specs field-specs) - (position 0) - (fields '())) - (if (null? field-specs) - (reverse fields) - (let* ((field-spec (car field-specs)) - (field-specs (cdr field-specs)) - (name-or-type (car field-spec))) - (if (and (eq? name-or-type 'union) - (pair? (cadr field-spec))) - (let-values (((next-position fields) - (add-union-fields pack - position - (cadr field-spec) - fields))) - (loop field-specs - next-position - fields)) - (let-values (((field next-position) - (construct-field pack position field-spec))) - (loop field-specs - next-position - (cons field fields)))))))) - -(define (add-union-fields pack position field-specs fields) - (define (field-spec-alignment field-spec) - (let ((descriptor (cadr field-spec))) - (bytestructure-descriptor-alignment descriptor))) - (define (field-spec-size field-spec) - (let ((descriptor (cadr field-spec))) - (bytestructure-descriptor-size descriptor))) - (let* ((alignment (apply max (map field-spec-alignment field-specs))) - (alignment (pack-alignment pack alignment)) - (size (apply max (map field-spec-size field-specs))) - (position (align position size alignment))) - (let loop ((field-specs field-specs) - (next-position position) - (fields fields)) - (if (null? field-specs) - (values next-position fields) - (let ((field-spec (car field-specs)) - (field-specs (cdr field-specs))) - (let-values (((field next-position) - (construct-field pack position field-spec))) - (loop field-specs - (max position next-position) - (cons field fields)))))))) - -(define (construct-field pack position field-spec) - (let* ((name (car field-spec)) - (descriptor (cadr field-spec)) - (bitfield? (not (null? (cddr field-spec)))) - (width (if bitfield? - (car (cddr field-spec)) - #f))) - (if bitfield? - (construct-bit-field pack position name descriptor width) - (construct-normal-field pack position name descriptor)))) - -(define-record-type - (make-struct-metadata field-alist) - struct-metadata? - (field-alist struct-metadata-field-alist)) - -(define bs:struct - (case-lambda - ((field-specs) - (bs:struct #f field-specs)) - ((pack field-specs) - (define %fields (construct-fields pack field-specs)) - (define fields (filter field-name %fields)) - (define field-alist (map (lambda (field) - (cons (field-name field) field)) - fields)) - (define alignment (apply max (map field-alignment fields))) - (define (field-end field) - (+ (field-position field) (field-size field))) - (define size (let ((end (apply max (map field-end %fields)))) - (let-values (((size . _) (next-boundary end alignment))) - size))) - (define (unwrapper syntax? bytevector offset index) - (let* ((index (if syntax? (syntax->datum index) index)) - (field-entry (assq index field-alist)) - (field (if field-entry - (cdr field-entry) - (error "No such struct field." index)))) - (let* ((descriptor (field-descriptor field)) - (position (field-position field)) - (offset (if syntax? - (quasisyntax - (+ (unsyntax offset) (unsyntax position))) - (+ offset position)))) - (values bytevector offset descriptor)))) - (define (setter syntax? bytevector offset value) - (define (count-error fields values) - (error "Mismatch between number of struct fields and given values." - fields values)) - (when syntax? - (error "Writing into struct not supported with macro API.")) - (cond - ((bytevector? value) - (bytevector-copy! bytevector offset value 0 size)) - ((vector? value) - (let loop ((fields fields) - (values (vector->list value))) - (if (null? values) - (when (not (null? fields)) - (count-error fields value)) - (begin - (when (null? fields) - (count-error fields value)) - (let* ((field (car fields)) - (value (car values)) - (descriptor (field-descriptor field)) - (position (field-position field)) - (offset (+ offset position))) - (bytestructure-set!* bytevector offset descriptor value) - (loop (cdr fields) (cdr values))))))) - ((pair? value) - ;; Assumed to be a pseudo-alist like ((k1 v1) (k2 v2) ...). - (for-each - (lambda (pair) - (let ((key (car pair)) - (value (cadr pair))) - (let-values (((bytevector offset descriptor) - (unwrapper #f bytevector offset key))) - (bytestructure-set!* bytevector offset descriptor value)))) - value)) - (else - (error "Invalid value for writing into struct." value)))) - (define meta - (let ((simple-field-alist (map (lambda (field) - (cons (field-name field) - (field-descriptor field))) - fields))) - (make-struct-metadata simple-field-alist))) - (make-bytestructure-descriptor size alignment unwrapper #f setter meta)))) - -(define debug-alignment - (case-lambda - ((fields) (debug-alignment #f fields)) - ((pack fields) - (let* ((fields (construct-fields pack fields)) - (alignment (apply max (map field-alignment fields))) - (size (let* ((field (last fields)) - (end (+ (field-position field) (field-size field)))) - (let-values (((size . _) (next-boundary end alignment))) - size)))) - (format #t "{\n") - (for-each (lambda (field) - (let ((name (field-name field)) - (pos (* 8 (field-position field))) - (size (* 8 (field-size field))) - (align (* 8 (field-alignment field)))) - (format #t " ~a - ~a: ~a (~a, ~a)\n" - pos (+ pos size) name size align))) - fields) - (format #t "} = ~a\n" (* 8 size)) - (values))))) - -;;; struct.scm ends here -;;; union.scm --- Union descriptor constructor. - -;; Copyright © 2015, 2016 Taylan Kammer - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;; Commentary: - -;; This constructor allows the creation of union descriptors with named fields -;; with a specific content descriptor. - - -;;; Code: - -(define make-field cons) -(define field-name car) -(define field-content cdr) -(define find-field assq) - -(define (construct-fields fields) - (map (lambda (field) - (make-field (car field) (cadr field))) - fields)) - -(define-record-type - (make-union-metadata field-alist) - union-metadata? - (field-alist union-metadata-field-alist)) - -(define (bs:union %fields) - (define fields (construct-fields %fields)) - (define alignment (apply max (map (lambda (field) - (bytestructure-descriptor-alignment - (field-content field))) - fields))) - (define size (let ((max-element - (apply max (map (lambda (field) - (bytestructure-descriptor-size - (field-content field))) - fields)))) - (let-values (((size . _) (next-boundary max-element alignment))) - size))) - (define (unwrapper syntax? bytevector offset index) - (let ((index (if syntax? (syntax->datum index) index))) - (values bytevector - offset - (field-content (find-field index fields))))) - (define (setter syntax? bytevector offset value) - (when syntax? - (error "Writing into union not supported with macro API.")) - (cond - ((bytevector? value) - (bytevector-copy! bytevector offset value 0 size)) - ((and (list? value) (= 2 (length value))) - (let-values (((bytevector* offset* descriptor) - (unwrapper #f bytevector offset (car value)))) - (bytestructure-set!* bytevector* offset* descriptor (cadr value)))) - (else - (error "Invalid value for writing into union." value)))) - (define meta (make-union-metadata fields)) - (make-bytestructure-descriptor size alignment unwrapper #f setter meta)) - -;;; union.scm ends here -;;; utils.scm --- Utility library for bytestructures. - -;; Copyright © 2015 Taylan Kammer - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;; Commentary: - -;; Just some utility procedures and macros. - - -;;; Code: - -(define-syntax define-syntax-rule - (syntax-rules () - ((_ ( . ) ) - (define-syntax - (syntax-rules () - ((_ . ) - )))))) - -(cond-expand - ((or guile syntax-case) - (define-syntax-rule (if-syntax-case ) - )) - (else - (define-syntax-rule (if-syntax-case ) - ))) - -(define-syntax-rule (define-syntax-case-stubs ...) - (if-syntax-case - (begin) - (begin - (define ( . rest) - (error "Not supported. You need syntax-case.")) - ...))) - -(define-syntax-case-stubs - syntax - quasisyntax - unsyntax - unsyntax-splicing - syntax->datum - datum->syntax) - -;;; utils.scm ends here -;;; vector.scm --- Vector descriptor constructor. - -;; Copyright © 2015, 2016 Taylan Kammer - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;; Commentary: - -;; This constructor allows the creation of vector descriptors with a specific -;; length and element descriptor. - -;; Be careful with identifier names here; don't confuse vector descriptor and -;; Scheme vector APIs and variables. - - -;;; Code: - -(define-record-type - (make-vector-metadata length element-descriptor) - vector-metadata? - (length vector-metadata-length) - (element-descriptor vector-metadata-element-descriptor)) - -(define (bs:vector length descriptor) - (define element-size (bytestructure-descriptor-size descriptor)) - (define size (* length element-size)) - (define alignment (bytestructure-descriptor-alignment descriptor)) - (define (unwrapper syntax? bytevector offset index) - (values bytevector - (if syntax? - (quasisyntax - (+ (unsyntax offset) - (* (unsyntax index) (unsyntax element-size)))) - (+ offset (* index element-size))) - descriptor)) - (define (setter syntax? bytevector offset value) - (when syntax? - (error "Writing into vector not supported with macro API.")) - (cond - ((bytevector? value) - (bytevector-copy! bytevector offset value 0 size)) - ((vector? value) - (do ((i 0 (+ i 1)) - (offset offset (+ offset element-size))) - ((= i (vector-length value))) - (bytestructure-set!* - bytevector offset descriptor (vector-ref value i)))) - (else - (error "Invalid value for writing into vector." value)))) - (define meta (make-vector-metadata length descriptor)) - (make-bytestructure-descriptor size alignment unwrapper #f setter meta)) - -;;; vector.scm ends here -(define-module (bytestructures guile base)) -(import - (srfi 9) - (srfi 11) - (ice-9 format) - (bytestructures guile bytevectors) - (bytestructures guile utils)) -(include-from-path "bytestructures/body/base.scm") -(include-from-path "bytestructures/r7/base.exports.sld") - -(import (srfi srfi-9 gnu)) - -(set-record-type-printer! - - (lambda (record port) - (format port "#" (object-address record)))) - -(set-record-type-printer! - - (lambda (record port) - (format port "#" (object-address record)))) -(define-module (bytestructures guile bitfields)) -(import - (srfi 9) - (srfi 60) - (bytestructures guile utils) - (bytestructures guile base) - (bytestructures guile numeric-metadata)) -(include-from-path "bytestructures/body/bitfields.scm") -(include-from-path "bytestructures/r7/bitfields.exports.sld") -;;; Compatibility shim for Guile, because its implementation of utf16->string -;;; and utf32->string doesn't conform to R6RS. -(define-module (bytestructures guile bytevectors)) - -(import - (rnrs base) - (rnrs control) - (bytestructures r6 bytevectors)) - -(re-export - endianness native-endianness bytevector? - make-bytevector bytevector-length bytevector=? bytevector-fill! - bytevector-copy! - bytevector-copy - - bytevector-u8-ref bytevector-s8-ref - bytevector-u8-set! bytevector-s8-set! bytevector->u8-list - u8-list->bytevector - bytevector-uint-ref bytevector-uint-set! - bytevector-sint-ref bytevector-sint-set! - bytevector->sint-list bytevector->uint-list - uint-list->bytevector sint-list->bytevector - - bytevector-u16-ref bytevector-s16-ref - bytevector-u16-set! bytevector-s16-set! - bytevector-u16-native-ref bytevector-s16-native-ref - bytevector-u16-native-set! bytevector-s16-native-set! - - bytevector-u32-ref bytevector-s32-ref - bytevector-u32-set! bytevector-s32-set! - bytevector-u32-native-ref bytevector-s32-native-ref - bytevector-u32-native-set! bytevector-s32-native-set! - - bytevector-u64-ref bytevector-s64-ref - bytevector-u64-set! bytevector-s64-set! - bytevector-u64-native-ref bytevector-s64-native-ref - bytevector-u64-native-set! bytevector-s64-native-set! - - bytevector-ieee-single-ref - bytevector-ieee-single-set! - bytevector-ieee-single-native-ref - bytevector-ieee-single-native-set! - - bytevector-ieee-double-ref - bytevector-ieee-double-set! - bytevector-ieee-double-native-ref - bytevector-ieee-double-native-set! - - string->utf8 - utf8->string - string->utf16 string->utf32) - -(export - (r6rs-utf16->string . utf16->string) - (r6rs-utf32->string . utf32->string)) - -(define (read-bom16 bv) - (let ((c0 (bytevector-u8-ref bv 0)) - (c1 (bytevector-u8-ref bv 1))) - (cond - ((and (= c0 #xFE) (= c1 #xFF)) - 'big) - ((and (= c0 #xFF) (= c1 #xFE)) - 'little) - (else - #f)))) - -(define r6rs-utf16->string - (case-lambda - ((bv default-endianness) - (let ((bom-endianness (read-bom16 bv))) - (if (not bom-endianness) - (utf16->string bv default-endianness) - (substring/shared (utf16->string bv bom-endianness) 1)))) - ((bv endianness endianness-mandatory?) - (if endianness-mandatory? - (utf16->string bv endianness) - (r6rs-utf16->string bv endianness))))) - -(define (read-bom32 bv) - (let ((c0 (bytevector-u8-ref bv 0)) - (c1 (bytevector-u8-ref bv 1)) - (c2 (bytevector-u8-ref bv 2)) - (c3 (bytevector-u8-ref bv 3))) - (cond - ((and (= c0 #x00) (= c1 #x00) (= c2 #xFE) (= c3 #xFF)) - 'big) - ((and (= c0 #xFF) (= c1 #xFE) (= c2 #x00) (= c3 #x00)) - 'little) - (else - #f)))) - -(define r6rs-utf32->string - (case-lambda - ((bv default-endianness) - (let ((bom-endianness (read-bom32 bv))) - (if (not bom-endianness) - (utf32->string bv default-endianness) - (substring/shared (utf32->string bv bom-endianness) 1)))) - ((bv endianness endianness-mandatory?) - (if endianness-mandatory? - (utf32->string bv endianness) - (r6rs-utf32->string bv endianness))))) -;;; cstring-pointer.scm --- Pointers to null-terminated strings. - -;; Copyright © 2017 Taylan Kammer - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;; Commentary: - -;; The cstring-pointer descriptor represents a pointer to a null-terminated -;; string, and will return the string as a Scheme string upon a reference -;; operation. Its setter however does not take Scheme strings, only addresses -;; to existing strings in memory. The reason is: Guile's string->pointer -;; creates a new C string in memory, returning an FFI pointer object holding its -;; address; the string is freed when the pointer object is garbage collected. -;; We have no means of holding a reference to the FFI pointer object; we can -;; only write the address it holds into our bytevector, which won't protect the -;; pointer object from GC. - - -;;; Code: - -(define-module (bytestructures guile cstring-pointer)) -(import - (bytestructures guile base) - (bytestructures guile numeric) - (prefix (system foreign) ffi-)) -(export cstring-pointer) - -(define (bytevector-address-ref bv offset) - (bytestructure-ref* bv offset uintptr_t)) - -(define (bytevector-address-set! bv offset address) - (bytestructure-set!* bv offset uintptr_t address)) - -(define cstring-pointer - (let () - (define size (bytestructure-descriptor-size intptr_t)) - (define alignment (bytestructure-descriptor-alignment intptr_t)) - (define unwrapper #f) - (define (getter syntax? bv offset) - (if syntax? - #`(let* ((address (bytevector-address-ref #,bv #,offset)) - (pointer (ffi-make-pointer address))) - (ffi-pointer->string pointer)) - (let* ((address (bytevector-address-ref bv offset)) - (pointer (ffi-make-pointer address))) - (ffi-pointer->string pointer)))) - (define (setter syntax? bv offset address) - (if syntax? - #`(bytevector-address-set! #,bv #,offset #,address) - (bytevector-address-set! bv offset address))) - (make-bytestructure-descriptor size alignment unwrapper getter setter))) -(define-module (bytestructures guile explicit-endianness)) -(import - (bytestructures guile bytevectors) - (bytestructures guile utils)) -(include-from-path "bytestructures/body/explicit-endianness.scm") -(include-from-path "bytestructures/r7/explicit-endianness.exports.sld") -;;; ffi.scm --- Convert bytestructure descriptors to Guile/libffi types. - -;; Copyright © 2016 Taylan Kammer - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;; Commentary: - -;; This module offers a way to convert bytestructure descriptors to Guile/libffi -;; type objects. For instance, the bytestructure descriptor created with -;; (bs:struct `((x ,uint8) (y ,uint16))) gets converted into a two-element list -;; containing the libffi codes for uint8 and uint16. - - -;;; Code: - -(define-module (bytestructures guile ffi)) -(import - (ice-9 match) - (prefix (system foreign) ffi-) - (bytestructures guile base) - (bytestructures guile numeric) - (bytestructures guile vector) - (bytestructures guile struct) - (bytestructures guile union) - (bytestructures guile pointer) - (bytestructures guile bitfields)) -(export - bytestructure-descriptor->ffi-descriptor - bs:pointer->proc - ) - -(define numeric-type-mapping - `((,int8 . ,ffi-int8) - (,uint8 . ,ffi-uint8) - (,int16 . ,ffi-int16) - (,uint16 . ,ffi-uint16) - (,int32 . ,ffi-int32) - (,uint32 . ,ffi-uint32) - (,int64 . ,ffi-int64) - (,uint64 . ,ffi-uint64) - (,float32 . ,ffi-float) - (,float64 . ,ffi-double))) - -(define (bytestructure-descriptor->ffi-descriptor descriptor) - (define (convert descriptor) - (cond - ((assq descriptor numeric-type-mapping) - => (match-lambda ((key . val) val))) - (else - (let ((metadata (bytestructure-descriptor-metadata descriptor))) - (cond - ((vector-metadata? metadata) - (make-list - (vector-metadata-length metadata) - (convert (vector-metadata-element-descriptor metadata)))) - ((struct-metadata? metadata) - (map convert (map cdr (struct-metadata-field-alist metadata)))) - ((union-metadata? metadata) - ;; TODO: Add support once Guile/libffi supports this. - (error "Unions not supported." descriptor)) - ((pointer-metadata? metadata) - '*) - ((bitfield-metadata? metadata) - ;; TODO: Add support once Guile/libffi supports this. - (error "Bitfields not supported." descriptor)) - (else - (error "Unsupported bytestructure descriptor." descriptor))))))) - (cond - ((eq? descriptor 'void) - ffi-void) - ((vector-metadata? (bytestructure-descriptor-metadata descriptor)) - '*) - (else - (convert descriptor)))) - -(define (bs:pointer->proc ret-type func-ptr arg-types) - (define (type->raw-type type) - (if (bytestructure-descriptor? type) - (bytestructure-descriptor->ffi-descriptor type) - type)) - (define (value->raw-value value) - (if (bytestructure? value) - (ffi-bytevector->pointer (bytestructure-bytevector value)) - value)) - (define (raw-value->value raw-value type) - (if (bytestructure-descriptor? type) - (make-bytestructure (ffi-pointer->bytevector - raw-value - (bytestructure-descriptor-size type)) - 0 - type) - raw-value)) - (let* ((raw-ret-type (type->raw-type ret-type)) - (raw-arg-types (map type->raw-type arg-types)) - (raw-proc (ffi-pointer->procedure - raw-ret-type func-ptr raw-arg-types))) - (lambda args - (let* ((raw-args (map value->raw-value args)) - (raw-ret-val (apply raw-proc raw-args))) - (raw-value->value raw-ret-val ret-type))))) -(define-module (bytestructures guile numeric-all)) -(import - (bytestructures guile bytevectors) - (bytestructures guile utils) - (bytestructures guile base) - (bytestructures guile explicit-endianness) - (bytestructures guile numeric-data-model)) -(include-from-path "bytestructures/body/numeric.scm") -(include-from-path "bytestructures/r7/numeric.exports.sld") -(include-from-path "bytestructures/r7/numeric-metadata.exports.sld") -(define-module (bytestructures guile numeric-data-model)) - -(import (system foreign)) -(import (system base target)) - -(define architecture - (let ((cpu (target-cpu))) - (cond - ((member cpu '("i386" "i486" "i586" "i686")) - 'i386) - ((string=? "x86_64" cpu) - 'x86-64) - ((string-prefix? "arm" cpu) - 'arm) - ((string-prefix? "aarch64" cpu) - 'aarch64)))) - -(define data-model - (if (= 4 (sizeof '*)) - (if (= 2 (sizeof int)) - 'lp32 - 'ilp32) - (cond - ((= 8 (sizeof int)) 'ilp64) - ((= 4 (sizeof long)) 'llp64) - (else 'lp64)))) - -(cond-expand-provide - (current-module) - (list architecture data-model)) -(define-module (bytestructures guile numeric-metadata)) -(import (bytestructures guile numeric-all)) -(re-export - signed-integer-native-descriptors - signed-integer-le-descriptors - signed-integer-be-descriptors - signed-integer-descriptors - unsigned-integer-native-descriptors - unsigned-integer-le-descriptors - unsigned-integer-be-descriptors - unsigned-integer-descriptors - float-native-descriptors - float-le-descriptors - float-be-descriptors - integer-descriptors - float-descriptors - numeric-descriptors - ) -(define-module (bytestructures guile numeric)) -(import (bytestructures guile numeric-all)) -(re-export - - int8 uint8 int16 uint16 int32 uint32 int64 uint64 - int16le uint16le int32le uint32le int64le uint64le - int16be uint16be int32be uint32be int64be uint64be - float32 float64 float32le float64le float32be float64be - - short unsigned-short - int unsigned-int - long unsigned-long - long-long unsigned-long-long - intptr_t uintptr_t - size_t ssize_t ptrdiff_t - float double - - complex64 complex128 - complex64le complex128le - complex64be complex128be - ) -;;; pointer.scm --- Pointer descriptor constructor. - -;; Copyright © 2015 Taylan Kammer - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;; Commentary: - -;; This constructor allows the creation of pointer descriptors with a specific -;; pointed-to descriptor. - - -;;; Code: - -(define-module (bytestructures guile pointer)) -(import - (srfi 9) - (bytestructures guile bytevectors) - (bytestructures guile utils) - (bytestructures guile base) - (prefix (system foreign) ffi-)) -(export - bs:pointer - pointer-metadata? pointer-metadata-content-descriptor - ) - -(define pointer-size (ffi-sizeof '*)) - -(define bytevector-address-ref - (case pointer-size - ((1) bytevector-u8-ref) - ((2) bytevector-u16-native-ref) - ((4) bytevector-u32-native-ref) - ((8) bytevector-u64-native-ref))) - -(define bytevector-address-set! - (case pointer-size - ((1) bytevector-u8-set!) - ((2) bytevector-u16-native-set!) - ((4) bytevector-u32-native-set!) - ((8) bytevector-u64-native-set!))) - -(define (pointer-ref bytevector offset index content-size) - (let* ((base-address (bytevector-address-ref bytevector offset)) - (address (+ base-address (* index content-size)))) - (if (zero? base-address) - (error "Tried to dereference null-pointer.") - (ffi-pointer->bytevector (ffi-make-pointer address) content-size)))) - -(define (pointer-set! bytevector offset value) - (cond - ((exact-integer? value) - (bytevector-address-set! bytevector offset value)) - ((bytevector? value) - (bytevector-address-set! bytevector offset - (ffi-pointer-address - (ffi-bytevector->pointer value)))) - ((bytestructure? value) - (bytevector-address-set! bytevector offset - (ffi-pointer-address - (ffi-bytevector->pointer - (bytestructure-bytevector value))))))) - -(define-record-type - (make-pointer-metadata content-descriptor) - pointer-metadata? - (content-descriptor pointer-metadata-content-descriptor)) - -(define (bs:pointer %descriptor) - (define (get-descriptor) - (if (promise? %descriptor) - (force %descriptor) - %descriptor)) - (define size pointer-size) - (define alignment size) - (define (unwrapper syntax? bytevector offset index) - (define (syntax-list id . elements) - (datum->syntax id (map syntax->datum elements))) - (let ((descriptor (get-descriptor))) - (when (eq? 'void descriptor) - (error "Tried to follow void pointer.")) - (let* ((size (bytestructure-descriptor-size descriptor)) - (index-datum (if syntax? (syntax->datum index) index)) - (index (if (eq? '* index-datum) 0 index-datum)) - (bytevector* - (if syntax? - #`(pointer-ref #,bytevector #,offset #,index #,size) - (pointer-ref bytevector offset index size)))) - (values bytevector* 0 descriptor)))) - (define (getter syntax? bytevector offset) - (if syntax? - #`(bytevector-address-ref #,bytevector #,offset) - (bytevector-address-ref bytevector offset))) - (define (setter syntax? bytevector offset value) - (if syntax? - #`(pointer-set! #,bytevector #,offset #,value) - (pointer-set! bytevector offset value))) - (define meta (make-pointer-metadata %descriptor)) - (make-bytestructure-descriptor size alignment unwrapper getter setter meta)) - -;;; pointer.scm ends here -(define-module (bytestructures guile string)) -(import - (bytestructures guile bytevectors) - (bytestructures guile utils) - (bytestructures guile base)) -(include-from-path "bytestructures/body/string.scm") -(include-from-path "bytestructures/r7/string.exports.sld") -(define-module (bytestructures guile struct)) -(import - (srfi 1) - (srfi 9) - (srfi 11) - (bytestructures guile bytevectors) - (bytestructures guile utils) - (bytestructures guile base) - (bytestructures guile bitfields)) -(include-from-path "bytestructures/body/align.scm") -(include-from-path "bytestructures/body/struct.scm") -(include-from-path "bytestructures/r7/struct.exports.sld") -(define-module (bytestructures guile union)) -(import - (srfi 9) - (srfi 11) - (bytestructures guile bytevectors) - (bytestructures guile utils) - (bytestructures guile base)) -(include-from-path "bytestructures/body/align.scm") -(include-from-path "bytestructures/body/union.scm") -(include-from-path "bytestructures/r7/union.exports.sld") -(define-module (bytestructures guile utils)) -(include-from-path "bytestructures/body/utils.scm") -(export - if-syntax-case - define-syntax-case-stubs - ) -(define-module (bytestructures guile vector)) -(import - (srfi 9) - (bytestructures guile bytevectors) - (bytestructures guile utils) - (bytestructures guile base)) -(include-from-path "bytestructures/body/vector.scm") -(include-from-path "bytestructures/r7/vector.exports.sld") -;;; Compatibility shim for R6RS systems, because R6RS and R7RS have different -;;; semantics for some procedures of the same name. We use R7RS semantics -;;; everywhere, so implement them in terms of R6RS. -(library (bytestructures r6 bytevectors) - (export - endianness native-endianness bytevector? - make-bytevector bytevector-length bytevector=? bytevector-fill! - (rename (r7rs-bytevector-copy! bytevector-copy!)) - (rename (r7rs-bytevector-copy bytevector-copy)) - - bytevector-u8-ref bytevector-s8-ref - bytevector-u8-set! bytevector-s8-set! bytevector->u8-list - u8-list->bytevector - bytevector-uint-ref bytevector-uint-set! - bytevector-sint-ref bytevector-sint-set! - bytevector->sint-list bytevector->uint-list - uint-list->bytevector sint-list->bytevector - - bytevector-u16-ref bytevector-s16-ref - bytevector-u16-set! bytevector-s16-set! - bytevector-u16-native-ref bytevector-s16-native-ref - bytevector-u16-native-set! bytevector-s16-native-set! - - bytevector-u32-ref bytevector-s32-ref - bytevector-u32-set! bytevector-s32-set! - bytevector-u32-native-ref bytevector-s32-native-ref - bytevector-u32-native-set! bytevector-s32-native-set! - - bytevector-u64-ref bytevector-s64-ref - bytevector-u64-set! bytevector-s64-set! - bytevector-u64-native-ref bytevector-s64-native-ref - bytevector-u64-native-set! bytevector-s64-native-set! - - bytevector-ieee-single-ref - bytevector-ieee-single-set! - bytevector-ieee-single-native-ref - bytevector-ieee-single-native-set! - - bytevector-ieee-double-ref - bytevector-ieee-double-set! - bytevector-ieee-double-native-ref - bytevector-ieee-double-native-set! - - (rename (r7rs-string->utf8 string->utf8)) - (rename (r7rs-utf8->string utf8->string)) - string->utf16 string->utf32 - utf16->string utf32->string - ) - (import - (rnrs base) - (rnrs control) - (rnrs bytevectors)) - (define r7rs-bytevector-copy! - (case-lambda - ((to at from) - (bytevector-copy! from 0 to at (bytevector-length from))) - ((to at from start) - (bytevector-copy! from start to at (- (bytevector-length from) start))) - ((to at from start end) - (bytevector-copy! from start to at (- end start))))) - (define r7rs-bytevector-copy - (case-lambda - ((bytevector) - (bytevector-copy bytevector)) - ((bytevector start) - (r7rs-bytevector-copy bytevector start (bytevector-length bytevector))) - ((bytevector start end) - (let* ((size (- end start)) - (bytevector* (make-bytevector size))) - (bytevector-copy! bytevector start bytevector* 0 size) - bytevector*)))) - (define r7rs-string->utf8 - (case-lambda - ((string) - (string->utf8 string)) - ((string start) - (string->utf8 (substring string start (string-length string)))) - ((string start end) - (string->utf8 (substring string start end))))) - (define r7rs-utf8->string - (case-lambda - ((bytevector) - (utf8->string bytevector)) - ((bytevector start) - (utf8->string (r7rs-bytevector-copy bytevector start))) - ((bytevector start end) - (utf8->string (r7rs-bytevector-copy bytevector start end)))))) -(export - make-bytestructure-descriptor - bytestructure-descriptor? - bytestructure-descriptor-size - bytestructure-descriptor-size/syntax - bytestructure-descriptor-alignment - bytestructure-descriptor-unwrapper - bytestructure-descriptor-getter - bytestructure-descriptor-setter - bytestructure-descriptor-metadata - make-bytestructure - bytestructure? - bytestructure-bytevector - bytestructure-offset - bytestructure-descriptor - bytestructure-size - bytestructure - bytestructure-unwrap - bytestructure-unwrap* - bytestructure-ref - bytestructure-ref* - bytestructure-set! - bytestructure-set!* - bytestructure-ref/dynamic - bytestructure-set!/dynamic - bytestructure-unwrap/syntax - bytestructure-ref/syntax - bytestructure-set!/syntax - define-bytestructure-accessors - ) -(define-library (bytestructures r7 base) - (import - (scheme base) - (scheme case-lambda) - (bytestructures r7 utils)) - (cond-expand - ((library (rnrs syntax-case)) - (import (rnrs syntax-case))) - (else)) - (include-library-declarations "base.exports.sld") - (include "body/base.scm")) -(export - bitfield-descriptor - bitfield-metadata? - bitfield-metadata-int-descriptor - bitfield-metadata-width - ) -(define-library (bytestructures r7 bitfields) - (import - (scheme base) - (srfi 60) - (bytestructures r7 utils) - (bytestructures r7 base) - (bytestructures r7 numeric-metadata)) - (include-library-declarations "bitfields.exports.sld") - (include "body/bitfields.scm")) -(define-library (bytestructures r7 bytevectors) - (cond-expand - ((library (rnrs bytevectors)) - (import (except (rnrs bytevectors) - bytevector? - make-bytevector - bytevector-length - bytevector-u8-ref - bytevector-u8-set! - bytevector-copy - bytevector-copy! - string->utf8 - utf8->string))) - (else - (import (except (r6rs bytevectors) - bytevector? - make-bytevector - bytevector-length - bytevector-u8-ref - bytevector-u8-set! - bytevector-copy - bytevector-copy! - string->utf8 - utf8->string)))) - (export - endianness - native-endianness - - bytevector=? - bytevector-fill! - - bytevector-s8-ref - bytevector-s8-set! - bytevector->u8-list u8-list->bytevector - - bytevector-uint-ref bytevector-sint-ref - bytevector-uint-set! bytevector-sint-set! - bytevector->uint-list bytevector->sint-list - uint-list->bytevector sint-list->bytevector - - bytevector-u16-ref bytevector-s16-ref - bytevector-u16-native-ref bytevector-s16-native-ref - bytevector-u16-set! bytevector-s16-set! - bytevector-u16-native-set! bytevector-s16-native-set! - - bytevector-u32-ref bytevector-s32-ref - bytevector-u32-native-ref bytevector-s32-native-ref - bytevector-u32-set! bytevector-s32-set! - bytevector-u32-native-set! bytevector-s32-native-set! - - bytevector-u64-ref bytevector-s64-ref - bytevector-u64-native-ref bytevector-s64-native-ref - bytevector-u64-set! bytevector-s64-set! - bytevector-u64-native-set! bytevector-s64-native-set! - - bytevector-ieee-single-native-ref - bytevector-ieee-single-ref - bytevector-ieee-double-native-ref - bytevector-ieee-double-ref - bytevector-ieee-single-native-set! - bytevector-ieee-single-set! - bytevector-ieee-double-native-set! - bytevector-ieee-double-set! - - string->utf16 string->utf32 - utf16->string utf32->string - )) -(export - bytevector-ieee-single-le-ref bytevector-ieee-single-be-ref - bytevector-ieee-single-le-set! bytevector-ieee-single-be-set! - bytevector-ieee-double-le-ref bytevector-ieee-double-be-ref - bytevector-ieee-double-le-set! bytevector-ieee-double-be-set! - bytevector-s16le-ref bytevector-s16be-ref - bytevector-s16le-set! bytevector-s16be-set! - bytevector-u16le-ref bytevector-u16be-ref - bytevector-u16le-set! bytevector-u16be-set! - bytevector-s32le-ref bytevector-s32be-ref - bytevector-s32le-set! bytevector-s32be-set! - bytevector-u32le-ref bytevector-u32be-ref - bytevector-u32le-set! bytevector-u32be-set! - bytevector-s64le-ref bytevector-s64be-ref - bytevector-s64le-set! bytevector-s64be-set! - bytevector-u64le-ref bytevector-u64be-ref - bytevector-u64le-set! bytevector-u64be-set! - ) -(define-library (bytestructures r7 explicit-endianness) - (import - (scheme base) - (bytestructures r7 utils) - (bytestructures r7 bytevectors)) - (include-library-declarations "explicit-endianness.exports.sld") - (include "body/explicit-endianness.scm")) -(define-library (bytestructures r7 numeric-all) - (import - (scheme base) - (scheme complex) - (scheme eval) - (bytestructures r7 utils) - (bytestructures r7 base) - (bytestructures r7 bytevectors) - (bytestructures r7 explicit-endianness)) - (include-library-declarations "numeric.exports.sld") - (include-library-declarations "numeric-metadata.exports.sld") - (include "body/numeric.scm")) -(export - signed-integer-native-descriptors - signed-integer-le-descriptors - signed-integer-be-descriptors - signed-integer-descriptors - unsigned-integer-native-descriptors - unsigned-integer-le-descriptors - unsigned-integer-be-descriptors - unsigned-integer-descriptors - float-native-descriptors - float-le-descriptors - float-be-descriptors - complex-native-descriptors - complex-le-descriptors - complex-be-descriptors - integer-descriptors - float-descriptors - complex-descriptors - numeric-descriptors - ) -(define-library (bytestructures r7 numeric-metadata) - (import (bytestructures r7 numeric-all)) - (include-library-declarations "numeric-metadata.exports.sld")) -(export - int8 int16 int32 int64 - uint8 uint16 uint32 uint64 - int16le int32le int64le - uint16le uint32le uint64le - int16be int32be int64be - uint16be uint32be uint64be - float32 float64 - float32le float64le - float32be float64be - - short unsigned-short - int unsigned-int - long unsigned-long - long-long unsigned-long-long - intptr_t uintptr_t - size_t ssize_t ptrdiff_t - float double - - complex64 complex128 - complex64le complex128le - complex64be complex128be - ) -(define-library (bytestructures r7 numeric) - (import (bytestructures r7 numeric-all)) - (include-library-declarations "numeric.exports.sld")) -(export bs:string) -(cond-expand - (r6rs - (export bytevector->string string->bytevector - ascii utf8 utf16le utf16be utf32le utf32be - bytevector-zero!)) - (else)) -(define-library (bytestructures r7 string) - (import - (scheme base) - (bytestructures r7 bytevectors) - (bytestructures r7 utils) - (bytestructures r7 base)) - (cond-expand - ((library (rnrs syntax-case)) - (import (rnrs syntax-case))) - (else)) - (include-library-declarations "string.exports.sld") - (include "body/string.scm")) -(export - bs:struct - struct-metadata? - struct-metadata-field-alist - ) -(define-library (bytestructures r7 struct) - (import - (scheme base) - (scheme case-lambda) - (srfi 1) - (srfi 28) - (bytestructures r7 utils) - (bytestructures r7 base) - (bytestructures r7 bitfields)) - (include-library-declarations "struct.exports.sld") - (include "body/align.scm") - (include "body/struct.scm")) -(export - bs:union - union-metadata? - union-metadata-field-alist - ) -(define-library (bytestructures r7 union) - (import - (scheme base) - (bytestructures r7 utils) - (bytestructures r7 base)) - (include-library-declarations "union.exports.sld") - (include "body/align.scm") - (include "body/union.scm")) -(define-library (bytestructures r7 utils) - (import (scheme base)) - (cond-expand - ((library (rnrs syntax-case)) - (import (rnrs syntax-case))) - (else)) - (export - define-syntax-rule - if-syntax-case - define-syntax-case-stubs - quasisyntax - unsyntax - unsyntax-splicing - syntax->datum - datum->syntax - ) - (include "body/utils.scm")) -(export - bs:vector - vector-metadata? - vector-metadata-length - vector-metadata-element-descriptor - ) -(define-library (bytestructures r7 vector) - (import - (scheme base) - (bytestructures r7 utils) - (bytestructures r7 base)) - (include-library-declarations "vector.exports.sld") - (include "body/vector.scm")) -(define-module (bytestructures guile)) - -;;; Note: cstring-pointer import/export hack: Guile 2.0.x has a problem when a -;;; module has the same name as an identifier defined in it, and the identifier -;;; is imported and re-exported. To work around it, we import `cstring-pointer' -;;; with a rename to `_cstring-pointer', define `cstring-pointer' explicitly in -;;; this module, and export that. - -(import - (bytestructures guile base) - (bytestructures guile vector) - (bytestructures guile struct) - (bytestructures guile union) - (bytestructures guile pointer) - (bytestructures guile numeric) - (bytestructures guile string) - (rename (bytestructures guile cstring-pointer) - (cstring-pointer _cstring-pointer))) -(re-export - make-bytestructure-descriptor - bytestructure-descriptor? - bytestructure-descriptor-size - bytestructure-descriptor-size/syntax - bytestructure-descriptor-alignment - bytestructure-descriptor-unwrapper - bytestructure-descriptor-getter - bytestructure-descriptor-setter - bytestructure-descriptor-metadata - make-bytestructure - bytestructure? - bytestructure-bytevector - bytestructure-offset - bytestructure-descriptor - bytestructure-size - bytestructure - bytestructure-unwrap - bytestructure-unwrap* - bytestructure-ref - bytestructure-ref* - bytestructure-set! - bytestructure-set!* - bytestructure-ref/dynamic - bytestructure-set!/dynamic - bytestructure-unwrap/syntax - bytestructure-ref/syntax - bytestructure-set!/syntax - define-bytestructure-accessors - - bs:vector - vector-metadata? vector-metadata-length vector-metadata-element-descriptor - - bs:struct - struct-metadata? struct-metadata-field-alist - - bs:union - union-metadata? union-metadata-field-alist - - bs:pointer - pointer-metadata? pointer-metadata-content-descriptor - - int8 int16 int32 int64 - int16le int32le int64le - int16be int32be int64be - uint8 uint16 uint32 uint64 - uint16le uint32le uint64le - uint16be uint32be uint64be - float32 float64 - float32le float64le - float32be float64be - - short unsigned-short - int unsigned-int - long unsigned-long - long-long unsigned-long-long - intptr_t uintptr_t - size_t ssize_t ptrdiff_t - float double - - complex64 complex128 - complex64le complex128le - complex64be complex128be - - bs:string - ) - -(define cstring-pointer _cstring-pointer) - -(export cstring-pointer) -(define-library (bytestructures r7) - (import - (bytestructures r7 base) - (bytestructures r7 vector) - (bytestructures r7 struct) - (bytestructures r7 union) - (bytestructures r7 numeric) - (bytestructures r7 string)) - (include-library-declarations "r7/base.exports.sld") - (include-library-declarations "r7/vector.exports.sld") - (include-library-declarations "r7/struct.exports.sld") - (include-library-declarations "r7/union.exports.sld") - (include-library-declarations "r7/numeric.exports.sld") - (include-library-declarations "r7/string.exports.sld")) -;;; Warning: nasal demons. -;;; -;;; Will output differences between GCC's behavior and our behavior, but not in -;;; a very nice format. Zero output is good. The C code and Scheme procedure -;;; we generate are fairly straightforward so read the code to understand. - -(define-module (bytestructures bitfield-tests)) - -(export run-bitfield-tests) - -(use-modules (srfi srfi-1) - (srfi srfi-9) - (ice-9 rdelim) - (bytestructures r6 bytevectors) - (bytestructures guile)) - -(define-record-type - (make-struct name fields) - struct? - (name struct-name) - (fields struct-fields)) - -(define-record-type - (make-field name int-size bit-size signed? value) - struct? - (name field-name) - (int-size field-int-size) - (bit-size field-bit-size) - (signed? field-signed?) - (value field-value)) - -(define *keep-files* (make-parameter #f)) - -(define (run-bitfield-tests count random-seed-string keep-files) - (set! *random-state* (seed->random-state random-seed-string)) - (parameterize ((*keep-files* keep-files)) - (test-structs (generate-structs count)))) - -(define (generate-structs n) - (remove-bad-structs (map random-struct (iota n)))) - -(define (remove-bad-structs structs) - (filter (lambda (struct) - (find (lambda (field) - (not (zero? (field-bit-size field)))) - (struct-fields struct))) - structs)) - -(define (random-struct i) - (let ((field-count (+ 1 (random 50)))) - (make-struct (format #f "s~a" i) - (map random-field (iota field-count))))) - -(define (random-field i) - (let* ((name (format #f "f~a" i)) - (int-size (* 8 (expt 2 (random 4)))) - (bit-size (random (+ 1 int-size))) - (signed? (= 0 (random 2))) - (value (random (expt 2 bit-size))) - (value (if (and signed? (> value (+ -1 (expt 2 (- bit-size 1))))) - (- value (expt 2 bit-size)) - value))) - (make-field name int-size bit-size signed? value))) - -(define (test-structs structs) - (let* ((c-code (c-code-for-structs structs)) - (c-output (get-c-output c-code)) - (scm-code (scm-code-for-structs structs)) - (scm-output (get-scm-output scm-code))) - (diff-outputs c-output scm-output))) - -(define (c-code-for-structs structs) - (string-concatenate - (append - (list "#include \n" - "#include \n" - "#include \n" - "int main(){\n") - (map c-code-for-struct structs) - (list "return 0;}")))) - -(define (c-code-for-struct struct) - (let ((name (struct-name struct)) - (fields (struct-fields struct))) - (string-concatenate - (append - (list (format #f "struct ~a {\n" name)) - (map c-decl-for-field fields) - (list "};\n" - (format #f "{ struct ~a foo;\n" name) - (format #f " bzero((void*)&foo, sizeof(foo));\n")) - (map c-assignment-for-field fields) - (list (format #f " printf(\"struct ~a:\\n\");\n" name) - " uint8_t *ptr = (void*)&foo;\n" - " for (int i = 0; i < sizeof(foo); ++i) {\n" - " printf(\"%d \", *(ptr+i));\n" - " }\n" - " printf(\"\\n\");\n" - "}\n"))))) - -(define (c-decl-for-field field) - (let ((name (field-name field)) - (int-size (field-int-size field)) - (bit-size (field-bit-size field)) - (signed? (field-signed? field))) - (format #f " ~aint~a_t ~a:~a;\n" - (if signed? "" "u") - int-size - (if (zero? bit-size) "" name) - bit-size))) - -(define (c-assignment-for-field field) - (let ((name (field-name field)) - (bit-size (field-bit-size field)) - (signed? (field-signed? field)) - (value (field-value field))) - (if (zero? bit-size) - "" - (format #f " foo.~a = ~a~a;\n" name value (if signed? "" "u"))))) - -(define (get-c-output code) - (let* ((port (mkstemp! (string-copy "/tmp/bitfield-XXXXXX"))) - (file (port-filename port)) - (exe-port (mkstemp! (string-copy "/tmp/bitfield-compiled-XXXXXX"))) - (exe-file (port-filename exe-port)) - (output-port (mkstemp! (string-copy "/tmp/bitfield-output-XXXXXX"))) - (output-file (port-filename output-port))) - (close-port exe-port) - (close-port output-port) - (display code port) - (force-output port) - (unless (zero? (system* "gcc" "-x" "c" "-std=c11" file "-o" exe-file)) - (error "gcc failed")) - (unless (zero? (system (format #f "~a > ~a" exe-file output-file))) - (error "exe failed")) - (let ((out (read-string (open output-file O_RDONLY)))) - (unless (*keep-files*) - (for-each delete-file (list file exe-file output-file))) - out))) - -(define (scm-code-for-structs structs) - (lambda () - (string-concatenate - (map scm-code-for-struct structs)))) - -(define (scm-code-for-struct struct) - (let* ((name (struct-name struct)) - (fields (struct-fields struct)) - (descriptor (struct->descriptor struct)) - (values (map field-value (filter-nonzero-fields fields))) - (bs (bytestructure descriptor (list->vector values)))) - (string-concatenate - (append - (list (format #f "struct ~a:\n" name)) - (let ((bv (bytestructure-bytevector bs))) - (map (lambda (i) - (format #f "~a " (bytevector-u8-ref bv i))) - (iota (bytevector-length bv)))) - (list "\n"))))) - -(define (struct->descriptor struct) - (let ((fields (struct-fields struct))) - (bs:struct (map field->struct-descriptor-field fields)))) - -(define (field->struct-descriptor-field field) - (let ((name (field-name field)) - (int-size (field-int-size field)) - (bit-size (field-bit-size field)) - (signed? (field-signed? field))) - (list name - (module-ref (resolve-module - '(bytestructures bitfield-tests)) - (string->symbol - (format #f "~aint~a" - (if signed? "" "u") - int-size))) - bit-size))) - -(define (filter-nonzero-fields fields) - (filter (lambda (field) - (not (zero? (field-bit-size field)))) - fields)) - -(define (get-scm-output code) - (code)) - -(define (diff-outputs o1 o2) - (let* ((p1 (mkstemp! (string-copy "/tmp/bitfield-out1-XXXXXX"))) - (f1 (port-filename p1)) - (p2 (mkstemp! (string-copy "/tmp/bitfield-out2-XXXXXX"))) - (f2 (port-filename p2))) - (display o1 p1) - (display o2 p2) - (flush-all-ports) - (close-port p1) - (close-port p2) - (let ((retval (system* "diff" "-y" "--suppress-common" f1 f2))) - (unless (*keep-files*) - (for-each delete-file (list f1 f2))) - retval))) -;;; Use this in the REPL. It produces wrong results when ran as a script. - -(use-modules (system vm coverage) - (system vm vm) - (srfi srfi-11)) - -(let ((output-directory - (string-append - (getenv "HOME") "/srv/http/htdocs/lcov/scheme-bytestructures"))) - (let-values (((data . values) - (with-code-coverage (the-vm) - (lambda () - (load "run-tests.guile.scm"))))) - (let* ((port (mkstemp! (string-copy "/tmp/bytestructures-coverage-XXXXXX"))) - (file (port-filename port))) - (coverage-data->lcov data port) - (close port) - (when (not (zero? (system* "genhtml" file "-o" output-directory))) - (error "genhtml failed")) - (delete-file file)))) -;;; run-tests.body.scm --- Bytestructures test suite. - -;; Copyright © 2015, 2021 Taylan Kammer - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;; Commentary: - -;; A relatively simple SRFI-64 test suite. - - -;;; Code: - -(define-syntax-rule (test-= name expected expr) - (test-approximate name expected expr 0)) - -(define-syntax-rule (maybe-skip-syntax . ) - (if-syntax-case - (begin . ) - (begin))) - -(test-begin "bytestructures") - -(test-group "numeric" - (define-syntax test-numeric-descriptors - (syntax-rules () - ((_ ...) - (let () - (define (destructure-numeric-descriptor-entry descriptor-entry proc) - (define descriptor (list-ref descriptor-entry 0)) - (define name (list-ref descriptor-entry 1)) - (define getter (list-ref descriptor-entry 2)) - (define setter (list-ref descriptor-entry 3)) - (define size (bytestructure-descriptor-size descriptor)) - (define float? (assq descriptor float-descriptors)) - (define signed? (or float? (assq descriptor signed-integer-descriptors))) - (proc descriptor name getter setter size float? signed?)) - (define (get-min/max float? signed? size) - (cond - (float? (inexact (expt 2 (case size ((4) 24) ((8) 53))))) - (signed? (- (expt 256 (- size 1)))) - (else (- (expt 256 size) 1)))) - (destructure-numeric-descriptor-entry - (assq numeric-descriptors) - (lambda (descriptor name getter setter size float? signed?) - (test-group (symbol->string name) - (let ((test-value-1 (if float? 1.0 1)) - (test-value-2 (if float? 2.0 1))) - (test-group "procedural" - (define min/max (get-min/max float? signed? size)) - (define bs (bytestructure descriptor)) - (test-eqv "size" size (bytevector-length - (bytestructure-bytevector bs))) - (test-= "ref" test-value-1 - (begin - (setter (bytestructure-bytevector bs) 0 test-value-1) - (bytestructure-ref bs))) - (test-= "set" test-value-2 - (begin - (bytestructure-set! bs test-value-2) - (getter (bytestructure-bytevector bs) 0))) - (test-= "min/max" min/max - (begin - (bytestructure-set! bs min/max) - (bytestructure-ref bs)))) - (maybe-skip-syntax - (test-group "syntactic" - (define min/max (get-min/max float? signed? size)) - ;; Must insert the top-level reference here. - (define-bytestructure-accessors - bs-unwrapper bs-getter bs-setter) - (define bv (make-bytevector size)) - (test-= "ref" test-value-1 - (begin - (setter bv 0 test-value-1) - (bs-getter bv))) - (test-= "set" test-value-2 - (begin - (bs-setter bv test-value-2) - (getter bv 0))) - (test-= "min/max" min/max - (begin - (bs-setter bv min/max) - (bs-getter bv))))))))) - ...)))) - (test-numeric-descriptors - float32 float32le float32be - float64 float64le float64be - int8 int16 int32 int64 - int16le int32le int64le - int16be int32be int64be - uint8 uint16 uint32 uint64 - uint16le uint32le uint64le - uint16be uint32be uint64be)) - -(test-group "vector" - (test-assert "create" (bs:vector 3 uint16)) - (test-group "procedural" - (define bs (bytestructure (bs:vector 3 uint16))) - (bytevector-u16-native-set! (bytestructure-bytevector bs) 2 321) - (test-eqv "ref" 321 (bytestructure-ref bs 1)) - (test-eqv "set" 456 (begin (bytestructure-set! bs 1 456) - (bytestructure-ref bs 1))) - (test-eqv "init" 321 - (let ((bs (bytestructure (bs:vector 3 uint16) '#(321 123 321)))) - (bytestructure-ref bs 2)))) - (maybe-skip-syntax - (test-group "syntactic" - (define-bytestructure-accessors (bs:vector 3 uint16) - unwrapper getter setter) - (define bv (make-bytevector 6)) - (bytevector-u16-native-set! bv 2 321) - (test-eqv "ref" 321 (getter bv 1)) - (test-eqv "set" 456 (begin (setter bv 1 456) - (getter bv 1)))))) - -(test-group "struct" - (test-group "aligned" - (test-assert "create" (bs:struct `((x ,uint8) (y ,uint16)))) - (test-group "procedural" - (define bs (bytestructure (bs:struct `((x ,uint8) (y ,uint16))))) - (bytevector-u16-native-set! (bytestructure-bytevector bs) 2 321) - (test-eqv "ref" 321 (bytestructure-ref bs 'y)) - (test-eqv "set" 456 (begin (bytestructure-set! bs 'y 456) - (bytestructure-ref bs 'y))) - (test-eqv "init" 321 - (let ((bs (bytestructure (bs:struct `((x ,uint8) (y ,uint16))) - '#(123 321)))) - (bytestructure-ref bs 'y)))) - (maybe-skip-syntax - (test-group "syntactic" - (define-bytestructure-accessors (bs:struct `((x ,uint8) (y ,uint16))) - unwrapper getter setter) - (define bv (make-bytevector 4)) - (bytevector-u16-native-set! bv 2 321) - (test-eqv "ref" 321 (getter bv y)) - (test-eqv "set" 456 (begin (setter bv y 456) - (getter bv y)))))) - (test-group "packed" - (test-assert "create" (bs:struct #t `((x ,uint8) (y ,uint16)))) - (test-group "procedural" - (define bs (bytestructure (bs:struct #t `((x ,uint8) (y ,uint16))))) - ;; u16-native-set! may error on non-aligned access. - (guard (err (else (test-skip 3))) - (bytevector-u16-native-set! (bytestructure-bytevector bs) 1 321)) - (test-eqv "ref" 321 (bytestructure-ref bs 'y)) - (test-eqv "set" 456 (begin (bytestructure-set! bs 'y 456) - (bytestructure-ref bs 'y))) - (test-eqv "init" 321 - (let ((bs (bytestructure (bs:struct #t `((x ,uint8) (y ,uint16))) - '#(123 321)))) - (bytestructure-ref bs 'y)))) - (maybe-skip-syntax - (test-group "syntactic" - (define-bytestructure-accessors (bs:struct #t `((x ,uint8) (y ,uint16))) - unwrapper getter setter) - (define bv (make-bytevector 4)) - ;; u16-native-set! may error on non-aligned access. - (guard (err (else (test-skip 2))) - (bytevector-u16-native-set! bv 1 321)) - (test-eqv "ref" 321 (getter bv y)) - (test-eqv "set" 456 (begin (setter bv y 456) - (getter bv y)))))) - - (test-group "anonymous-union" - (test-assert "create" - (bs:struct - `((x ,uint8) - (union - ((a ,uint16) - (b ,uint32)))))) - ;; Don't use 64-bit ints; their alignment differs between platforms. - (test-group "aligned" - (define bs - (bytestructure - (bs:struct - `((union - ((x ,uint8) - (y ,uint16))) - (union - ((a ,uint16) - (b ,uint32))))))) - (test-eqv "size" 8 (bytevector-length (bytestructure-bytevector bs))) - (bytevector-u16-native-set! (bytestructure-bytevector bs) 4 321) - (test-eqv "ref1" 321 (bytestructure-ref bs 'a)) - (bytevector-u32-native-set! (bytestructure-bytevector bs) 4 456) - (test-eqv "ref2" 456 (bytestructure-ref bs 'b)) - (test-eqv "set1" 789 (begin (bytestructure-set! bs 'a 789) - (bytestructure-ref bs 'a))) - (test-eqv "set2" 987 (begin (bytestructure-set! bs 'b 987) - (bytestructure-ref bs 'b)))) - (test-group "packed" - (define bs - (bytestructure - (bs:struct - #t - `((union - ((x ,uint8) - (y ,uint16))) - (union - ((a ,uint16) - (b ,uint32))))))) - (test-eqv "size" 6 (bytevector-length (bytestructure-bytevector bs))) - (bytevector-u16-native-set! (bytestructure-bytevector bs) 2 321) - (test-eqv "ref1" 321 (bytestructure-ref bs 'a)) - (bytevector-u32-native-set! (bytestructure-bytevector bs) 2 456) - (test-eqv "ref2" 456 (bytestructure-ref bs 'b)) - (test-eqv "set1" 789 (begin (bytestructure-set! bs 'a 789) - (bytestructure-ref bs 'a))) - (test-eqv "set2" 987 (begin (bytestructure-set! bs 'b 987) - (bytestructure-ref bs 'b)))))) - -(test-group "union" - (test-assert "create" (bs:union `((x ,uint8) (y ,uint16)))) - (test-group "procedural" - (define bs (bytestructure (bs:union `((x ,uint8) (y ,uint16))))) - (bytevector-u16-native-set! (bytestructure-bytevector bs) 0 321) - (test-eqv "ref" 321 (bytestructure-ref bs 'y)) - (test-eqv "set" 456 (begin (bytestructure-set! bs 'y 456) - (bytestructure-ref bs 'y)))) - (maybe-skip-syntax - (test-group "syntactic" - (define-bytestructure-accessors (bs:union `((x ,uint8) (y ,uint16))) - unwrapper getter setter) - (define bv (make-bytevector 2)) - (bytevector-u16-native-set! bv 0 321) - (test-eqv "ref" 321 (getter bv y)) - (test-eqv "set" 456 (begin (setter bv y 456) - (getter bv y)))))) - -(test-group "string" - (test-group "ascii" - (test-assert "create" (bs:string 4 'ascii)) - (test-group "procedural" - (define bsd (bs:string 4 'ascii)) - (define bs (make-bytestructure (string->utf8 "1234") 0 bsd)) - (test-equal "ref" "1234" (bytestructure-ref bs)) - (test-equal "set" "4321" (begin - (bytestructure-set! bs "4321") - (bytestructure-ref bs))) - (test-error "too-long" #t (bytestructure-set! bs "12345")) - (test-error "too-short" #t (bytestructure-set! bs "123")) - (set! bs (make-bytestructure (string->utf8 "äåãø") 0 bsd)) - (test-error "decoding-error" #t (bytestructure-ref bs)) - (test-error "encoding-error" #t (bytestructure-set! bs "øãåä"))) - (test-group "syntactic" - (define-bytestructure-accessors (bs:string 4 'ascii) - unwrapper getter setter) - (define bv (string->utf8 "1234")) - (test-equal "ref" "1234" (getter bv)) - (test-equal "set" "4321" (begin - (setter bv "4321") - (getter bv))) - (test-error "too-long" #t (setter bv "12345")) - (test-error "too-short" #t (setter bv "123")) - (set! bv (string->utf8 "äåãø")) - (test-error "ref-error" #t (getter bv)) - (test-error "set-error" #t (setter bv "øãåä")))) - (test-group "utf8" - (test-assert "create" (bs:string 4 'utf8)) - (test-group "procedural" - (define bsd (bs:string 4 'utf8)) - (define bs (make-bytestructure (string->utf8 "1234") 0 bsd)) - (test-equal "ref" "1234" (bytestructure-ref bs)) - (test-equal "set" "4321" (begin - (bytestructure-set! bs "4321") - (bytestructure-ref bs))) - (test-error "too-long" #t (bytestructure-set! bs "äåãø")) - (test-equal (string-append "123" (string #\nul)) - (begin - (bytestructure-set! bs "123") - (bytestructure-ref bs)))) - (test-group "syntactic" - (define-bytestructure-accessors (bs:string 4 'utf8) - unwrapper getter setter) - (define bv (string->utf8 "1234")) - (test-equal "ref" "1234" (getter bv)) - (test-equal "set" "4321" (begin - (setter bv "4321") - (getter bv))) - (test-error "too-long" #t (setter bv "äåãø")) - (test-equal (string-append "123" (string #\nul)) - (begin - (setter bv "123") - (getter bv))))) - (let () - (define-syntax-rule - (test-string-encodings - ( utf>) - ...) - (begin - (test-group - (test-assert "create" (bs:string ')) - (test-group "procedural" - (define bs (make-bytestructure (utf> "1234" ') - 0 - (bs:string '))) - (test-equal "ref" "1234" (bytestructure-ref bs)) - (test-equal "set" "4321" (begin - (bytestructure-set! bs "4321") - (bytestructure-ref bs))) - (test-error "too-long" #t (bytestructure-set! bs "12345")) - (if - (test-error "too-short" #t (bytestructure-set! bs "123")) - (test-equal (string-append "123" (string #\nul)) - (begin - (bytestructure-set! bs "123") - (bytestructure-ref bs))))) - (test-group "syntactic" - (define-bytestructure-accessors (bs:string ') - unwrapper getter setter) - (define bv (utf> "1234" ')) - (test-equal "ref" "1234" (getter bv)) - (test-equal "set" "4321" (begin - (setter bv "4321") - (getter bv))) - (test-error "too-long" #t (setter bv "12345")) - (if - (test-error "too-short" #t (setter bv "123")) - (test-equal (string-append "123" (string #\nul)) - (begin - (setter bv "123") - (getter bv)))))) - ...)) - (test-string-encodings - ("utf16le" utf16le little 8 #f string->utf16) - ("utf16be" utf16be big 8 #f string->utf16) - ("utf32le" utf32le little 16 #t string->utf32) - ("utf32be" utf32be big 16 #t string->utf32)))) - -(cond-expand - (guile - (let () - - (define (protect-from-gc-upto-here obj) - (with-output-to-file *null-device* - (lambda () - (display (eq? #f obj))))) - - (define pointer-size (ffi-sizeof '*)) - (define bytevector-address-set! - (case pointer-size - ((1) bytevector-u8-set!) - ((2) bytevector-u16-native-set!) - ((4) bytevector-u32-native-set!) - ((8) bytevector-u64-native-set!))) - - (test-group "pointer" - (test-assert "create" (bs:pointer uint16)) - (test-group "procedural" - (define bs (bytestructure (bs:pointer uint16))) - (define bv1 (make-bytevector 2)) - (define bv2 (make-bytevector 4)) - (define address1 (ffi-pointer-address (ffi-bytevector->pointer bv1))) - (define address2 (ffi-pointer-address (ffi-bytevector->pointer bv2))) - (bytevector-address-set! (bytestructure-bytevector bs) 0 address1) - (bytevector-u16-native-set! bv1 0 321) - (test-eqv "ref1" 321 (bytestructure-ref bs '*)) - (test-eqv "set1" 456 (begin (bytestructure-set! bs '* 456) - (bytestructure-ref bs '*))) - (test-eqv "ref2" address1 (bytestructure-ref bs)) - (test-eqv "set2" address2 (begin (bytestructure-set! bs address2) - (bytestructure-ref bs))) - (bytevector-address-set! (bytestructure-bytevector bs) 0 address2) - (bytevector-u16-native-set! bv2 2 456) - (test-eqv "ref3" 456 (bytestructure-ref bs 1)) - (test-eqv "set3" 789 (begin (bytestructure-set! bs 1 789) - (bytestructure-ref bs 1))) - (protect-from-gc-upto-here bv1) - (protect-from-gc-upto-here bv2)) - (test-group "syntactic" - (define-bytestructure-accessors (bs:pointer uint16) - unwrapper getter setter) - (define bv (make-bytevector pointer-size)) - (define bv1 (make-bytevector 2)) - (define bv2 (make-bytevector 4)) - (define address1 (ffi-pointer-address (ffi-bytevector->pointer bv1))) - (define address2 (ffi-pointer-address (ffi-bytevector->pointer bv2))) - (bytevector-address-set! bv 0 address1) - (bytevector-u16-native-set! bv1 0 321) - (test-eqv "ref" 321 (getter bv *)) - (test-eqv "set" 456 (begin (setter bv * 456) - (getter bv *))) - (test-eqv "ref2" address1 (getter bv)) - (test-eqv "set2" address1 (begin (setter bv address1) - (getter bv))) - (bytevector-address-set! bv 0 address2) - (bytevector-u16-native-set! bv2 2 456) - (test-eqv "ref3" 456 (getter bv 1)) - (test-eqv "set3" 789 (begin (setter bv 1 789) - (getter bv 1))) - (protect-from-gc-upto-here bv1) - (protect-from-gc-upto-here bv2))) - - (test-group "cstring-pointer" - (let* ((cstr1-ptr (ffi-string->pointer "abc")) - (cstr2-ptr (ffi-string->pointer "cba")) - (cstr1-addr (ffi-pointer-address cstr1-ptr)) - (cstr2-addr (ffi-pointer-address cstr2-ptr))) - (test-group "procedural" - (define bs (bytestructure cstring-pointer)) - (bytevector-address-set! (bytestructure-bytevector bs) 0 cstr1-addr) - (test-equal "ref" "abc" (bytestructure-ref bs)) - (test-equal "set" "cba" (begin (bytestructure-set! bs cstr2-addr) - (bytestructure-ref bs)))) - (test-group "syntactic" - (define-bytestructure-accessors cstring-pointer - unwrapper getter setter) - (define bv (make-bytevector pointer-size)) - (bytevector-address-set! bv 0 cstr1-addr) - (test-equal "ref" "abc" (getter bv)) - (test-equal "set" "cba" (begin (setter bv cstr2-addr) - (getter bv)))))))) - - (else - )) - -;; Do this before test-end since it removes the auto-inserted test runner. -(define success - (let ((runner (test-runner-current))) - (and (zero? (test-runner-xpass-count runner)) - (zero? (test-runner-fail-count runner))))) - -(test-end "bytestructures") - -(exit (if success 0 1)) - -;; Local Variables: -;; eval: (put (quote test-group) (quote scheme-indent-function) 1) -;; eval: (put (quote test-=) (quote scheme-indent-function) 2) -;; End: - -(use-modules - (srfi srfi-11) - (srfi srfi-64) - ((rnrs exceptions) #\select (guard)) - ((system foreign) #\prefix ffi-) - (bytestructures r6 bytevectors) - (bytestructures guile utils) - (bytestructures guile) - (bytestructures guile numeric-metadata)) - -(define inexact exact->inexact) - -(include-from-path "run-tests.body.scm") -(import - (scheme base) - (srfi 64) - (bytestructures r7 utils) - (bytestructures r7) - (bytestructures r7 numeric-metadata) - (bytestructures r7 bytevectors) - (bytestructures r7 explicit-endianness)) - -(include "run-tests.body.scm") -;;; commonmark.scm --- An implementation of CommonMark markdown - -;; Copyright (C) 2014 Taylan Ulrich Bayirli/Kammer - -;; Author: Taylan Ulrich Bayirli/Kammer -;; Keywords: - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;; Commentary: - -;; - -;;; Code: - -(define (parse port) - (let* ((lines (preprocess port)) - (blocks (parse-blocks lines))) - blocks)) - -(define (preprocess port) - (do ((line (read-line port) (read-line port)) - (lines '() (cons (preprocess-line line) lines))) - ((eof-object? line) (reverse lines)))) - -(define (preprocess-line line) - (do ((chars (string->list line) (cdr chars)) - (processed-chars '() (let ((char (car chars))) - (if (char=? char #\tab) - (append (make-list 4 #\space) - processed-chars) - (cons char processed-chars))))) - ((null? chars) (apply string (reverse processed-chars))))) - -(define (parse-blocks lines) - (do ((lines lines (cdr lines)) - (blocks '() (let ((blocks* (add-line blocks (car lines)))) - (if blocks* - blocks* - (begin (close-block! (car blocks)) - blocks)))))) - ((null? lines) (reverse blocks))) - -;;; BLOCKS is in reverse here. -(define (add-line blocks line) - (if (null? blocks) - (cons (new-block line) blocks) - (let ((last-block (car blocks))) - (cond - ((and (open-text-block? last-block) - (plain-text-line? line)) - (add-line-to-text-block last-block line)) - ((and (open-container-block? last-block) - ())))))) - -;;; commonmark.scm ends here -(export - - ) -(define-library (commonmark r7rs) - (import (scheme base)) - (include-library-declarations "r7rs-exports.scm") - (include "commonmark.scm")) -;;; generic-ref-set --- Generic accessor and modifier operators. - -;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer - -;; Permission is hereby granted, free of charge, to any person obtaining -;; a copy of this software and associated documentation files (the -;; "Software"), to deal in the Software without restriction, including -;; without limitation the rights to use, copy, modify, merge, publish, -;; distribute, sublicense, and/or sell copies of the Software, and to -;; permit persons to whom the Software is furnished to do so, subject to -;; the following conditions: - -;; The above copyright notice and this permission notice shall be -;; included in all copies or substantial portions of the Software. - -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE -;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION -;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION -;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -;;; Helpers - -(define-syntax push! - (syntax-rules () - ((_ ) - (set! (cons ))))) - -(define (alist->hashtable alist) - (let ((table (make-eqv-hashtable 100))) - (for-each (lambda (entry) - (hashtable-set! table (car entry) (cdr entry))) - alist) - table)) - -;;; Main - -(define ref - (case-lambda - ((object field) - (let ((getter (lookup-getter object)) - (sparse? (sparse-type? object))) - (if sparse? - (let* ((not-found (cons #f #f)) - (result (getter object field not-found))) - (if (eqv? result not-found) - (error "Object has no entry for field." object field) - result)) - (getter object field)))) - ((object field default) - (let ((getter (lookup-getter object))) - (getter object field default))))) - -(define-syntax set! - (syntax-rules () - ((set! ) - (%set! )) - ((set! ) - (let* ((object ) - (setter (lookup-setter object))) - (setter object ))))) - -(set! (setter ref) (lambda (object field value) (set! object field value))) - -(define (lookup-getter object) - (or (hashtable-ref getter-table (type-of object) #f) - (error "No generic getter for object's type." object))) - -(define (lookup-setter object) - (or (hashtable-ref setter-table (type-of object) #f) - (error "No generic setter for object's type." object))) - -(define (sparse-type? object) - (memv (type-of object) sparse-types)) - -(define (type-of object) - (find (lambda (pred) (pred object)) type-list)) - -(define getter-table - (alist->hashtable - (list (cons bytevector? bytevector-u8-ref) - (cons hashtable? hashtable-ref) - (cons pair? list-ref) - (cons string? string-ref) - (cons vector? vector-ref)))) - -(define setter-table - (alist->hashtable - (list (cons bytevector? bytevector-u8-set!) - (cons hashtable? hashtable-set!) - (cons pair? list-set!) - (cons string? string-set!) - (cons vector? vector-set!)))) - -(define sparse-types - (list hashtable?)) - -(define type-list - (list boolean? bytevector? char? eof-object? hashtable? null? number? pair? - port? procedure? string? symbol? vector?)) - -(define-syntax define-record-type - (syntax-rules () - ((_ ...) - (begin - (%define-record-type ...) - (push! type-list ) - (register-record-getter ...) - (register-record-setter ...))))) - -(define-syntax register-record-getter - (syntax-rules () - ((_ ( . ) ...) - (let ((getters (alist->hashtable (list (cons ' ) ...)))) - (define (getter record field) - (let ((getter (or (ref getters field #f) - (error "No such field of record." record field)))) - (getter record field))) - (set! getter-table getter))))) - -(define-syntax register-record-setter - (syntax-rules () - ((_ . ) - (%register-record-setter () . )))) - -(define-syntax %register-record-setter - (syntax-rules () - ((_ ( ) . ) - (%register-record-setter . )) - ((_ ( ) . ) - (%register-record-setter (( ) . ) . )) - ((_ (( ) ...) ) - (let ((setters (alist->hashtable (list (cons ' ) ...)))) - (define (setter record field value) - (let ((setter (or (ref setters field #f) - (error "No such assignable field of record." - record field)))) - (setter record value))) - (set! setter-table setter))))) - -;;; generic-ref-set.body.scm ends here -(define-library (generic-ref-set) - (export - ref set! define-record-type (rename ref $bracket-apply$)) - (import - (rename (except (scheme base) set!) - (define-record-type %define-record-type)) - (scheme case-lambda) - (r6rs hashtables) - (srfi 1) - (rename (srfi 17) (set! %set!))) - (include "generic-ref-set.body.scm")) -(define-module (ie-reader cre)) - -(use-modules - (bytestructures guile)) - -(define cre-header - (bs:struct - `((signature ,(bs:string 4 'ascii)) - (version ,(bs:string 4 'ascii)) - (long-name )))) -;; One advantage of dlists is that they allow you to write more -;; efficient programs, while keeping the lucidity of the less -;; efficient version. Take the naïve version of 'reverse' - -(define (reverse l) - (if (null? l) - '() - (append (reverse (cdr l)) - (list (car l))))) - -;; The definition is obviously correct, however it isn't very -;; efficient. For a given step, the cost of the non-trivial case is -;; dependant on the size of the list we have gotten from the recursive -;; call. That is, it takes time proportional to the square of its -;; input list. -;; Of course, no self respecting functional programmer would write -;; reverse in this manner, as the trick of using an accumulating -;; parameter is so well established. Instead we would write - -(define (reverse l) - (define (reverse-helper from to) - (if (null? from) - to - (reverse-helper (cdr from) - (cons (car from) to)))) - (reverse-helper l '())) - -;; By introducing this additional parameter, we have reclaimed a more -;; reasonable complexity of constant time at each recursive call, -;; giving us linear complexity overall. -;; This is a big improvement, and with a little practice, it becomes -;; easy to convince yourself of the correctness of code written in -;; this manner. - -;; However, why should you have to practice? Why can't there be a -;; definition as obviously correct as the former, with the efficiency -;; of the latter? -;; Turns out, it is possible to do this, by using a different -;; representation for lists. - -(define (reverse* l) - (if (null? l) - (dlist) - (dlist-append (reverse* (cdr l)) - (dlist (car l))))) - -(define (reverse l) - (dlist->list (reverse* l))) - -;; Difference lists, or representing lists as functions, gives us a -;; constant time version of append, thus reducing the complexity of -;; reverse* to O(n), and the definition differs from the original, -;; only in the names we use for the append and list procedures. The -;; final result of this function, however, is a dlist rather than a -;; list, so we must convert back. This also has linear complexity, so -;; the overall complexity is still linear. - -;; How does this work? Well, let's replace dlist and dlist-append with -;; their definitions -(define (reverse* l) - (if (null? l) - (lambda (x) (append '() x)) - (compose (reverse* (cdr l)) - (lambda (x) (append (list (car l)) x))))) - -(define (reverse l) - ((reverse* l) '())) - -;; Now, we replace compose with its definition -(define (reverse* l) - (if (null? l) - (lambda (x) (append '() x)) - (lambda (x) - ((reverse* (cdr l)) - ((lambda (x) (append (list (car l)) x)) x))))) - -(define (reverse l) - ((reverse* l) '())) - -;; With a few simplifications: substituting x for its definition, -;; x for (append '() x), and (cons x y) for (append (list x) y) -(define (reverse* l) - (if (null? l) - (lambda (x) x) - (lambda (x) - ((reverse* (cdr l)) - (cons (car l) x))))) - -(define (reverse l) - ((reverse* l) '())) - -;; Now, if we uncurry reverse* -(define (reverse* l x) - (if (null? l) - x - (reverse* (cdr l) (cons (car l) x)))) - -(define (reverse l) - (reverse* l '())) - -;; Then, it turns out the dlist version is the traditional O(n) -;; implementation in disguise. - -;; As an exercise, you can try doing the same thing for the flatten -;; function -(define (flatten xs) - (cond ((null? xs) '()) - ((pair? xs) - (append (flatten (car xs)) - (flatten (cdr xs)))) - (else (list xs)))) -;;; Functional Breadth First Search -(import (rnrs) - (pfds queues)) - -;; This is the traditional solution using Queues, for a more -;; interesting solution, see "The Under-Appreciated Unfold" by Jeremy -;; Gibbons and Geraint Jones. - -;; We'll need a tree type, we'll use #f for an empty child. -(define-record-type tree - (fields value left right)) - -;; A small section of the Stern-Brocot Tree -;; https://en.wikipedia.org/wiki/Stern%E2%80%93Brocot_tree -(define stern-brocot - (make-tree 1 - (make-tree 1/2 - (make-tree 1/3 - (make-tree 1/4 #f #f) - (make-tree 2/5 #f #f)) - (make-tree 2/3 - (make-tree 3/5 #f #f) - (make-tree 3/4 #f #f))) - (make-tree 2 - (make-tree 3/2 - (make-tree 4/3 #f #f) - (make-tree 5/3 #f #f)) - (make-tree 3 - (make-tree 5/2 #f #f) - (make-tree 4 #f #f))))) - -;; We'll search it breadth-first for the first fraction expressed in -;; fifths. -(define (fifth? f) - (= 5 (denominator f))) - -;; The queue search -(define (bfs p? tree) - (define (step queue) - (if (queue-empty? queue) - #f - (let-values ([(head queue*) (dequeue queue)]) - (cond ((not head) ; empty-tree, skip - (step queue*)) - ((p? (tree-value head)) (tree-value head)) - (else - (step (enqueue (enqueue queue* (tree-left head)) - (tree-right head)))))))) - - (step (enqueue (make-queue) tree))) - -(equal? 2/5 (bfs fifth? stern-brocot)) -(define-library (pfds assert) - (export assert assertion-violation) - (import (scheme base)) - (begin - ())) -;;; bbtrees.sls --- Bounded Balance trees - -;; Copyright (C) 2012 Ian Price -;; Copyright (C) 2015 Taylan Ulrich Bayırlı/Kammer - -;; Author: Ian Price - -;; This program is free software, you can redistribute it and/or -;; modify it under the terms of the new-style BSD license. - -;; You should have received a copy of the BSD license along with this -;; program. If not, see . - -;; Documentation: -;; -;; Note: For all procedures which take a key as an argument, the key -;; must be comparable with the ordering procedure of the bbtree. -;; -;; make-bbtree : (any -> any -> boolean) -> bbtree -;; returns an empty bbtree. bbtrees derived from this one will use the -;; procedure argument for ordering keys. -;; -;; bbtree? : any -> bool -;; returns #t if the argument is a bbtree, #f otherwise -;; -;; bbtree-size : bbtree -> non-negative integer -;; returns the number of elements in a bbtree -;; -;; bbtree-ref : bbtree any [any] -> any -;; returns the value associated with the key in the bbtree. If the -;; value is not in the tree, then, if the optional third argument is -;; passed, it is returned, otherwise an &assertion-violation condition -;; is raised. -;; -;; bbtree-set : bbtree any any -> bbtree -;; returns a new bbtree with the key associated with the value. If the -;; key is already in the bbtree, its associated value is replaced with -;; the new value in the returned bbtree. -;; -;; bbtree-update : bbtree any (any -> any) any -> bbtree -;; returns a new bbtree with the value associated with the key updated -;; according to the update procedure. If the key was not already in -;; the bbtree, the update procedure is called on the default value, -;; and the association is added to the bbtree. -;; -;; bbtree-delete : bbtree any -> bbtree -;; returns a new bbtree with the key and its associated value -;; removed. If the key is not in the bbtree, the returned bbtree is a -;; copy of the original -;; -;; bbtree-contains? : bbtree any -> boolean -;; returns #t if there is association for key in the bbtree, false -;; otherwise -;; -;; bbtree-traverse : (any any (any -> any) (any -> any) any) any bbtree -> any -;; A general tree traversal procedure. Returns the value of applying -;; the traverser procedure to the current node's key, value, a -;; procedure to traverse the left subtree, a procedure to traverse the -;; right subtree, and a base value. The subtree traversal procedures -;; both take a base argument, and call bbtree-traverse recursively on -;; the appropriate subtree. It is mostly useful for implementing -;; other, more specific tree traversal procedures. For example, -;; (define (l-to-r-pre-order cons base bbtree) -;; (bbtree-traverse (lambda (key value left right base) -;; (right (left (cons key value base)))) -;; base -;; bbtree)) -;; implements a left-to-right pre-order traversal variant of bbtree-fold -;; -;; bbtree-fold : (any any any -> any) any bbtree -> any -;; returns the value obtained by the iterating the combine procedure -;; over each node in the tree. The combine procedure takes three -;; arguments, the key and value of the current node, and an -;; accumulator value, and its return value is used as the accumulator -;; value for the next node. The initial accumulator value is provided -;; by the base argument. bbtree-fold performs an left-to-right -;; in-order traversal or "minimum key to maximum key". -;; -;; bbtree-fold-right : (any any any -> any) any bbtree -> any -;; like bbtree-fold, but it performs a right-to-left in-order -;; traversal instead (i.e. maximum to minimum). -;; -;; bbtree-map : (any -> any) bbtree -> bbtree -;; returns the tree obtained by updating the value of each node with -;; the result of applying the procedure to its value. -;; -;; bbtree->alist : bbtree -> Listof(Pairs) -;; returns the key value associations of the bbtree as a list of -;; pairs. The list returned is in sorted order according to the -;; ordering procedure of the bbtree. A consequence of this is that one -;; could write a sort procedure for lists of pairs as -;; (define (alist-sort alist <) -;; (bbtree->alist (alist->bbtree alist <))) -;; -;; alist->bbtree : Listof(Pairs) -> (any any -> boolean) -> bbtree -;; returns the bbtree containing each of the key value pairs in the -;; alist, using the < argument as the ordering procedure. -;; -;; bbtree-keys : bbtree -> Listof(any) -;; returns a list containing all the keys of the bbtree. The keys are -;; sorted according to the bbtree's ordering procedure. -;; -;; bbtree-union : bbtree bbtree -> bbtree -;; returns a bbtree containing the union of the associations in -;; bbtree1 and bbtree2. Where the same key occurs in both, the value -;; in bbtree1 is preferred. -;; -;; bbtree-difference : bbtree bbtree -> bbtree -;; returns a bbtree containing the all the associations in bbtree1, -;; which do not occur in bbtree2. -;; -;; bbtree-intersection : bbtree bbtree -> bbtree -;; returns a bbtree containing all the associations which appear in -;; both bbtree1 and bbtree2. The value in bbtree1 are preferred over -;; those in bbtree2. -;; -;; bbtree-index bbtree any -> non-negative integer -;; returns the index of the key in the bbtree. Index is an integer -;; between 0 and size - 1, with the a key having a lower index than -;; another if first-key < second-key, according to the bbtree ordering -;; procedure. -;; -;; bbtree-ref/index bbtree non-negative-integer -> any any -;; returns the key and value of the association in the bbtree at the -;; given index. -;; -;; bbtree-ordering-procedure : bbtree -> (any any -> bool) -;; returns the ordering procedure used internally to order the -;; bbtree. -(define-library (pfds bbtrees) -(export make-bbtree - bbtree? - bbtree-size - bbtree-ref - bbtree-set - bbtree-update - bbtree-delete - bbtree-contains? - bbtree-ordering-procedure - bbtree-traverse - bbtree-fold - bbtree-fold-right - bbtree-map - bbtree->alist - alist->bbtree - bbtree-keys - bbtree-union - bbtree-difference - bbtree-intersection - bbtree-index - bbtree-ref/index - ) - -(import (except (scheme base) min member)) - -(begin - -(define weight 4) - -;;; bbtree is the wrapper that you interact with from outside the -;;; module, so there is no need to deal with empty and node record types -(define-record-type (bbtree %make-bbtree bbtree?) - (fields tree ordering-procedure)) - -(define (update-tree bbtree new-tree) - (%make-bbtree new-tree (bbtree-ordering-procedure bbtree))) - -;;; inner representation of trees -;;; all non exposed methods can assume a valid tree -(define-record-type empty) - -(define-record-type node - (fields key value length left right)) - -;;; smart constructor for nodes, automatically fills in size field -(define (node* key value left right) - (make-node key value (+ 1 (size left) (size right)) left right)) - -(define (size tree) - (if (empty? tree) - 0 - (node-length tree))) - -;; looks key up in the tree, and applies proc to the value if it finds -;; it, and calls failure otherwise -(define (lookup tree key proc failure <) - (define (search tree) - (cond ((empty? tree) (failure)) - ((< (node-key tree) key) - (search (node-right tree))) - ((< key (node-key tree)) - (search (node-left tree))) - (else (proc tree)))) - (search tree)) - -;; returns the key and value of the minimum element in the tree -(define (min tree) - (cond ((empty? tree) - (assertion-violation 'min "Can't take the minimum value of an empty tree")) - ((empty? (node-left tree)) - (values (node-key tree) - (node-value tree))) - (else - (min (node-left tree))))) - -;;; rotations -(define (rotate-left key value left right) - (let ((r-key (node-key right)) - (r-value (node-value right)) - (r-left (node-left right)) - (r-right (node-right right))) - (node* r-key - r-value - (node* key value left r-left) - r-right))) - -(define (rotate-right key value left right) - (let ((l-key (node-key left)) - (l-value (node-value left)) - (l-left (node-left left)) - (l-right (node-right left))) - (node* l-key - l-value - l-left - (node* key value l-right right)))) - -(define (rotate-left/double key value left right) - (let ((r-key (node-key right)) - (r-value (node-value right)) - (r-left (node-left right)) - (r-right (node-right right))) - (let ((rl-key (node-key r-left)) - (rl-value (node-value r-left)) - (rl-left (node-left r-left)) - (rl-right (node-right r-left))) - (node* rl-key - rl-value - (node* key value left rl-left) - (node* r-key r-value rl-right r-right))))) - -(define (rotate-right/double key value left right) - (let ((l-key (node-key left)) - (l-value (node-value left)) - (l-left (node-left left)) - (l-right (node-right left))) - (let ((lr-key (node-key l-right)) - (lr-value (node-value l-right)) - (lr-left (node-left l-right)) - (lr-right (node-right l-right))) - (node* lr-key - lr-value - (node* l-key l-value l-left lr-left) - (node* key value lr-right right))))) - -;;; smart constructor for after adding/removing a node -(define (T key value left right) - (let ((l-size (size left)) - (r-size (size right))) - (cond ((< (+ l-size r-size) 2) - (node* key value left right)) - ((> r-size (* weight l-size)) - (let ((r-left (node-left right)) - (r-right (node-right right))) - (if (< (size r-left) (size r-right)) - (rotate-left key value left right) - (rotate-left/double key value left right)))) - ((> l-size (* weight r-size)) - (let ((l-left (node-left left)) - (l-right (node-right left))) - (if (< (size l-right) (size l-left)) - (rotate-right key value left right) - (rotate-right/double key value left right)))) - (else - (node* key value left right))))) - -(define (update tree key proc default <) - (define (add-to tree) - (if (empty? tree) - (make-node key (proc default) 1 (make-empty) (make-empty)) - (let ((k (node-key tree)) - (v (node-value tree)) - (l (node-left tree)) - (r (node-right tree))) - (cond ((< key k) - (T k v (add-to l) r)) - ((< k key) - (T k v l (add-to r))) - (else - (node* key (proc v) l r)))))) - (add-to tree)) - -(define (add tree key value <) - (define (replace _) value) - (update tree key replace #f <)) - -(define (delete tree key <) - (define (delete-from tree) - (if (empty? tree) - tree - (let ((k (node-key tree)) - (v (node-value tree)) - (l (node-left tree)) - (r (node-right tree))) - (cond ((< key k) - (T k v (delete-from l) r)) - ((< k key) - (T k v l (delete-from r))) - (else - (delete* l r)))))) - (delete-from tree)) - -(define (delete* left right) - (cond ((empty? left) right) - ((empty? right) left) - (else - (let-values (((k v) (min right))) - (T k v left (delete-min right)))))) - -(define (delete-min tree) - (cond ((empty? tree) - (assertion-violation 'delete-min - "Can't delete the minimum value of an empty tree")) - ((empty? (node-left tree)) - (node-right tree)) - (else - (T (node-key tree) - (node-value tree) - (delete-min (node-left tree)) - (node-right tree))))) - -(define (concat3 key value left right lt) - (cond ((empty? left) - (add right key value lt)) - ((empty? right) - (add left key value lt)) - ((< (* weight (size left)) (size right)) - (T (node-key right) - (node-value right) - (concat3 key value left (node-left right) lt) - (node-right right))) - ((< (* weight (size right)) (size left)) - (T (node-key left) - (node-value left) - (node-left left) - (concat3 key value (node-right left) right lt))) - (else - (node* key value left right)))) - -(define (split-lt tree key <) - (cond ((empty? tree) tree) - ((< key (node-key tree)) - (split-lt (node-left tree) key <)) - ((< (node-key tree) key) - (concat3 (node-key tree) - (node-value tree) - (node-left tree) - (split-lt (node-right tree) key <) - <)) - (else (node-left tree)))) - -(define (split-gt tree key <) - (cond ((empty? tree) tree) - ((< key (node-key tree)) - (concat3 (node-key tree) - (node-value tree) - (split-gt (node-left tree) key <) - (node-right tree) - <)) - ((< (node-key tree) key) - (split-gt (node-right tree) key <)) - (else (node-right tree)))) - -(define (difference tree1 tree2 <) - (cond ((empty? tree1) tree1) - ((empty? tree2) tree1) - (else - (let ((l* (split-lt tree1 (node-key tree2) <)) - (r* (split-gt tree1 (node-key tree2) <))) - (concat (difference l* (node-left tree2) <) - (difference r* (node-right tree2) <)))))) - -(define (concat left right) - (cond ((empty? left) right) - ((empty? right) left) - ((< (* weight (size left)) (size right)) - (T (node-key right) - (node-value right) - (concat left (node-left right)) - (node-right right))) - ((< (* weight (size right)) (size left)) - (T (node-key left) - (node-value left) - (node-left left) - (concat (node-right left) right))) - (else - (let-values (((k v) (min right))) - (T k v left (delete-min right)))))) - -(define (member key tree <) - (define (yes x) #t) - (define (no) #f) - (lookup tree key yes no <)) - -(define (intersection t1 t2 <) - (cond ((empty? t1) t1) - ((empty? t2) t2) - (else - (let ((l* (split-lt t2 (node-key t1) <)) - (r* (split-gt t2 (node-key t1) <))) - (if (member (node-key t1) t2 <) - (concat3 (node-key t1) - (node-value t1) - (intersection (node-left t1) l* <) - (intersection (node-right t1) r* <) - <) - (concat (intersection (node-left t1) l* <) - (intersection (node-right t1) r* <))))))) - -;;; hedge union - -;; ensures that tree is either empty, or root lies in range low--high -(define (trim low high tree <) - (cond ((empty? tree) tree) - ((< low (node-key tree)) - (if (< (node-key tree) high) - tree - (trim low high (node-left tree) <))) - (else - (trim low high (node-right tree) <)))) - -(define (uni-bd tree1 tree2 low high <) - (cond ((empty? tree2) tree1) - ((empty? tree1) - (concat3 (node-key tree2) - (node-value tree2) - (split-gt (node-left tree2) low <) - (split-lt (node-right tree2) high <) - <)) - (else - (let ((key (node-key tree1))) - (concat3 key - (node-value tree1) - (uni-bd (node-left tree1) (trim low key tree2 <) low key <) - (uni-bd (node-right tree1) (trim key high tree2 <) key high <) - <))))) - -;; specialisation of trim for high=+infinity -(define (trim-low low tree <) - (cond ((empty? tree) tree) - ((< low (node-key tree)) tree) - (else - (trim-low low (node-right tree) <)))) - -;; trim for low=-infinity -(define (trim-high high tree <) - (cond ((empty? tree) tree) - ((< (node-key tree) high) tree) - (else - (trim-high high (node-left tree) <)))) - -;; uni-bd for low=-infinity -(define (uni-high tree1 tree2 high <) - (cond ((empty? tree2) tree1) - ((empty? tree1) - (concat3 (node-key tree2) - (node-value tree2) - (node-left tree2) - (split-lt (node-right tree2) high <) - <)) - (else - (let ((key (node-key tree1))) - (concat3 key - (node-value tree1) - (uni-high (node-left tree1) (trim-high key tree2 <) key <) - (uni-bd (node-right tree1) (trim key high tree2 <) key high <) - <))))) - -;; uni-bd for high=+infinity -(define (uni-low tree1 tree2 low <) - (cond ((empty? tree2) tree1) - ((empty? tree1) - (concat3 (node-key tree2) - (node-value tree2) - (split-gt (node-left tree2) low <) - (node-right tree2) - <)) - (else - (let ((key (node-key tree1))) - (concat3 key - (node-value tree1) - (uni-bd (node-left tree1) (trim low key tree2 <) low key <) - (uni-low (node-right tree1) (trim-low key tree2 <) key <) - <))))) - -(define (hedge-union tree1 tree2 <) - (cond ((empty? tree2) tree1) - ((empty? tree1) tree2) - (else - (let ((key (node-key tree1))) - (concat3 key - (node-value tree1) - (uni-high (node-left tree1) (trim-high key tree2 <) key <) - (uni-low (node-right tree1) (trim-low key tree2 <) key <) - <))))) - -;;; rank and indexing - -(define (rank tree key <) - (cond ((empty? tree);; error - (assertion-violation 'rank "Key is not in the tree" key)) - ((< key (node-key tree)) - (rank (node-left tree) key <)) - ((< (node-key tree) key) - (+ (rank (node-right tree) key <) - (size (node-left tree)) - 1)) - (else - (size (node-left tree))))) - -(define (index tree idx) - (if (empty? tree) - (assertion-violation 'index "No value at index" idx) - (let ((l-size (size (node-left tree)))) - (cond ((< idx l-size) - (index (node-left tree) idx)) - ((< l-size idx) - (index (node-right tree) - (- idx l-size 1))) - (else - (values (node-key tree) - (node-value tree))))))) - -;;; External procedures - -(define (make-bbtree <) - (assert (procedure? <)) - (%make-bbtree (make-empty) <)) - -(define (bbtree-size bbtree) - (assert (bbtree? bbtree)) - (size (bbtree-tree bbtree))) - -(define bbtree-ref - (let ((ref (lambda (bbtree key failure) - (assert (bbtree? bbtree)) - (lookup (bbtree-tree bbtree) - key - node-value - failure - (bbtree-ordering-procedure bbtree))))) - (case-lambda - ((bbtree key) - (define (fail) - (assertion-violation 'bbtree-ref "Key is not in the tree" key)) - (ref bbtree key fail)) - ((bbtree key ret) - (ref bbtree key (lambda () ret)))))) - -(define (bbtree-set bbtree key value) - (assert (bbtree? bbtree)) - (update-tree bbtree - (add (bbtree-tree bbtree) - key - value - (bbtree-ordering-procedure bbtree)))) - -(define (bbtree-update bbtree key proc default) - (assert (bbtree? bbtree)) - (update-tree bbtree - (update (bbtree-tree bbtree) - key - proc - default - (bbtree-ordering-procedure bbtree)))) - -(define (bbtree-delete bbtree key) - (assert (bbtree? bbtree)) - (update-tree bbtree - (delete (bbtree-tree bbtree) - key - (bbtree-ordering-procedure bbtree)))) - -(define (bbtree-contains? bbtree key) - (assert (bbtree? bbtree)) - (lookup (bbtree-tree bbtree) - key - (lambda (_) #t) - (lambda () #f) - (bbtree-ordering-procedure bbtree))) - -;; iterators - -(define (traverse traverser base tree) - (define (left base) - (traverse traverser base (node-left tree))) - (define (right base) - (traverse traverser base (node-right tree))) - (if (empty? tree) - base - (traverser (node-key tree) - (node-value tree) - left - right - base))) - -(define (bbtree-traverse traverser base bbtree) - (assert (bbtree? bbtree)) - (traverse traverser base (bbtree-tree bbtree))) - -(define (bbtree-fold combine base bbtree) - (assert (bbtree? bbtree)) - (traverse (lambda (k v l r n) - (r (combine k v (l n)))) - base - (bbtree-tree bbtree))) - -(define (bbtree-fold-right combine base bbtree) - (assert (bbtree? bbtree)) - (traverse (lambda (k v l r n) - (l (combine k v (r n)))) - base - (bbtree-tree bbtree))) - -;; I could do this more efficiently, but is it worth it? -(define (bbtree-map mapper bbtree) - (bbtree-fold (lambda (key value tree) - (bbtree-set tree key (mapper value))) - (make-bbtree (bbtree-ordering-procedure bbtree)) - bbtree)) - -(define (alist-cons a b c) - (cons (cons a b) c)) - -(define (bbtree->alist bbtree) - (bbtree-fold-right alist-cons '() bbtree)) - -(define (alist->bbtree list <) - (fold-left (lambda (tree kv-pair) - (bbtree-set tree (car kv-pair) (cdr kv-pair))) - (make-bbtree <) - list)) - -(define (bbtree-keys bbtree) - (bbtree-fold-right (lambda (key value base) - (cons key base)) - '() - bbtree)) - -(define (bbtree-union bbtree1 bbtree2) - (update-tree bbtree1 - (hedge-union (bbtree-tree bbtree1) - (bbtree-tree bbtree2) - (bbtree-ordering-procedure bbtree1)))) - -(define (bbtree-difference bbtree1 bbtree2) - (update-tree bbtree1 - (difference (bbtree-tree bbtree1) - (bbtree-tree bbtree2) - (bbtree-ordering-procedure bbtree1)))) - -(define (bbtree-intersection bbtree1 bbtree2) - (update-tree bbtree1 - (intersection (bbtree-tree bbtree1) - (bbtree-tree bbtree2) - (bbtree-ordering-procedure bbtree1)))) - -(define (bbtree-index bbtree key) - ;; maybe this should return #f instead of throwing an exception? - (assert (bbtree? bbtree)) - (rank (bbtree-tree bbtree) - key - (bbtree-ordering-procedure bbtree))) - -(define (bbtree-ref/index bbtree idx) - (assert (bbtree? bbtree)) - (let ((tree (bbtree-tree bbtree))) - (unless (and (integer? idx) - (<= 0 idx (- (size tree) 1))) - (assertion-violation 'bbtree-ref/index - "Not a valid index into the bbtree" - idx)) - (index tree idx))) - -)) - -;;; deques.sls --- Purely functional deques - -;; Copyright (C) 2011,2012 Ian Price - -;; Author: Ian Price - -;; This program is free software, you can redistribute it and/or -;; modify it under the terms of the new-style BSD license. - -;; You should have received a copy of the BSD license along with this -;; program. If not, see . - -;; Documentation: -;; -;; make-deque : () -> deque -;; returns a deque containing to items -;; -;; deque? : any -> boolean -;; tests if an object is a deque -;; -;; deque-length : deque -> non-negative integer -;; returns the number of items in the deque -;; -;; deque-empty? : deque -> boolean -;; returns true if there are no items in the deque, false otherwise -;; -;; enqueue-front : deque any -> deque -;; returns a new deque with the inserted item at the front -;; -;; enqueue-rear : deque any -> deque -;; returns a new deque with the inserted item at the rear -;; -;; dequeue-front : deque -> any queue -;; returns two values, the item at the front of the deque, and a new -;; deque containing all the other items -;; raises a &deque-empty condition if the deque is empty -;; -;; dequeue-rear : deque -> any queue -;; returns two values, the item at the rear of the deque, and a new -;; deque containing all the other items -;; raises a &deque-empty condition if the deque is empty -;; -;; deque-empty-condition? : object -> boolean -;; tests if an object is a &deque-empty condition -;; -;; deque->list : deque -> listof(any) -;; returns a list containing all the elements of the deque. The order -;; of the elements in the list is the same as the order they would be -;; dequeued from the front of the deque. -;; -;; list->deque : listof(any) -> deque -;; returns a deque containing all of the elements in the list. The -;; order of the elements in the deque is the same as the order of the -;; elements in the list. -;; -(library (pfds deques) -(export make-deque - deque? - deque-length - deque-empty? - enqueue-front - enqueue-rear - dequeue-front - dequeue-rear - deque-empty-condition? - deque->list - list->deque - ) -(import (except (rnrs) cons*) - (pfds deques private condition) - (pfds private lazy-lists)) - -(define c 2) - -(define (rot1 n l r) - (if (>= n c) - (cons* (head l) - (rot1 (- n c) (tail l) (drop c r))) - (rot2 l (drop n r) '()))) - -(define (rot2 l r a) - (if (empty? l) - (append* (rev r) a) - (cons* (head l) - (rot2 (tail l) - (drop c r) - (append* (rev (take c r)) a))))) - -(define-record-type (deque %make-deque deque?) - (fields - (immutable length) - (immutable lenL) - (immutable lenR) - (immutable l) - (immutable r) - (immutable l^) - (immutable r^))) - -(define (make-deque) - (%make-deque 0 0 0 '() '() '() '())) - -(define (deque-empty? deque) - (zero? (deque-length deque))) - -(define (enqueue-front deque item) - (let ((len (deque-length deque)) - (l (deque-l deque)) - (r (deque-r deque)) - (lenL (deque-lenL deque)) - (lenR (deque-lenR deque)) - (l^ (deque-l^ deque)) - (r^ (deque-r^ deque))) - (makedq (+ 1 len) (+ 1 lenL) lenR (cons* item l) r (tail l^) (tail r^)))) - -(define (enqueue-rear deque item) - (let ((len (deque-length deque)) - (l (deque-l deque)) - (r (deque-r deque)) - (lenL (deque-lenL deque)) - (lenR (deque-lenR deque)) - (l^ (deque-l^ deque)) - (r^ (deque-r^ deque))) - (makedq (+ 1 len) lenL (+ 1 lenR) l (cons* item r) (tail l^) (tail r^)))) - -(define (dequeue-front deque) - (when (deque-empty? deque) - (raise (condition - (make-deque-empty-condition) - (make-who-condition 'dequeue-front) - (make-message-condition "There are no elements to remove") - (make-irritants-condition (list deque))))) - (let ((len (deque-length deque)) - (lenL (deque-lenL deque)) - (lenR (deque-lenR deque)) - (l (deque-l deque)) - (r (deque-r deque)) - (l^ (deque-l^ deque)) - (r^ (deque-r^ deque))) - (if (empty? l) - (values (head r) (make-deque)) - (values (head l) - (makedq (- len 1) - (- lenL 1) - lenR - (tail l) - r - (tail (tail l^)) - (tail (tail r^))))))) - -(define (dequeue-rear deque) - (when (deque-empty? deque) - (raise (condition - (make-deque-empty-condition) - (make-who-condition 'dequeue-rear) - (make-message-condition "There are no elements to remove") - (make-irritants-condition (list deque))))) - (let ((len (deque-length deque)) - (lenL (deque-lenL deque)) - (lenR (deque-lenR deque)) - (l (deque-l deque)) - (r (deque-r deque)) - (l^ (deque-l^ deque)) - (r^ (deque-r^ deque))) - (if (empty? r) - (values (head l) (make-deque)) - (values (head r) - (makedq (- len 1) - lenL - (- lenR 1) - l - (tail r) - (tail (tail l^)) - (tail (tail r^))))))) - - - -(define (makedq len lenL lenR l r l^ r^) - (cond ((> lenL (+ 1 (* c lenR))) - (let* ((n (floor (/ (+ lenL lenR) 2))) - (l* (take n l)) - (r* (rot1 n r l))) - (%make-deque len n (- len n) l* r* l* r*))) - ((> lenR (+ 1 (* c lenL))) - (let* ((n (floor (/ (+ lenL lenR) 2))) - (l* (rot1 n l r)) - (r* (take n r))) - (%make-deque len (- len n) n l* r* l* r*))) - (else - (%make-deque len lenL lenR l r l^ r^)))) - -(define (list->deque l) - (fold-left enqueue-rear (make-deque) l)) - -(define (deque->list deq) - (define (recur deq l) - (if (deque-empty? deq) - l - (let-values ([(last deq*) (dequeue-rear deq)]) - (recur deq* (cons last l))))) - (recur deq '())) - -) - -;;; dlists.sls --- Difference Lists - -;; Copyright (C) 2012 Ian Price - -;; Author: Ian Price - -;; This program is free software, you can redistribute it and/or -;; modify it under the terms of the new-style BSD license. - -;; You should have received a copy of the BSD license along with this -;; program. If not, see . - -;;; Commentary: -;; -;; Repeatedly appending to a list is a common, if inefficient pattern -;; in functional programs. Usually the trick we use is to build up the -;; list in reverse, and then to reverse it as the last action of a -;; function. -;; -;; Dlists are a representation of lists as functions that provide for -;; constant time append to either the front or end of a dlist that may -;; be used instead. - -;;; Documentation: -;; -;; dlist : any ... -> dlist -;; returns a dlist containing all its arguments. -;; -;; dlist? : any -> boolean -;; returns #t if its argument is a dlist, #f otherwise. -;; -;; dlist-cons : any dlist -> dlist -;; returns a new dlist created by prepending the element to the head -;; of the dlist argument. -;; -;; dlist-snoc : dlist any -> dlist -;; returns a new dlist created by appending the element to the tail of -;; the dlist argument. -;; -;; dlist-append : dlist dlist -> dlist -;; returns a new dlist consisting of all the elements of the first -;; dlist, followed by all the items of the second dlist. -;; -;; dlist->list : dlist -> listof(any) -;; returns a list consisting of all the elements of the dlist. -;; -;; list->dlist : listof(any) -> dlist -;; returns a dlist consisting of all the elements of the list. -(library (pfds dlists) -(export (rename (%dlist dlist)) - dlist? - dlist-cons - dlist-snoc - dlist-append - dlist->list - list->dlist - ) -(import (rnrs)) - -(define-record-type dlist - (fields - (immutable proc undl))) - -(define (%dlist . args) - (list->dlist args)) - -(define (compose f g) - (lambda (x) - (f (g x)))) - -(define (singleton x) - (list->dlist (list x))) - -(define (dlist-append dl1 dl2) - (make-dlist (compose (undl dl1) (undl dl2)))) - -(define (dlist-cons element dlist) - (dlist-append (singleton element) dlist)) - -(define (dlist-snoc dlist element) - (dlist-append dlist (singleton element))) - -(define (dlist->list dlist) - ((undl dlist) '())) - -(define (list->dlist list) - (make-dlist - (lambda (rest) - (append list rest)))) - -) - -;;; fingertrees.sls --- A Simple General-Purpose Data Structure - -;; Copyright (C) 2012 Ian Price - -;; Author: Ian Price - -;; This program is free software, you can redistribute it and/or -;; modify it under the terms of the new-style BSD license. - -;; You should have received a copy of the BSD license along with this -;; program. If not, see . - -;;; Commentary: -;; -;; Fingertrees are a generalised form of deque, that you can parameterise -;; to compute a value, called the "measure" of a fingertree. This measure -;; will be updated incrementally as you add and remove elements from the -;; fingertree. Among other things, this allows fingertrees to be used -;; where you otherwise might have written a custom data structure. -;; -;; To compute the measure, fingertrees require pieces of information: a -;; converter, a combiner, and an identity. -;; -;; The converter is a procedure of one argument, that maps values in the -;; fingertree to other values which are used for computing the measure. -;; -;; The combiner is a procedure of two arguments, and combines these into -;; one value representing them both. A combiner must be associative -;; i.e. (combine A (combine B C)) must be equivalent to (combine (combine -;; A B) C) for all values A, B and C. -;; -;; An identity is a value that represents the measure of an empty -;; fingertree. It must obey the rule that (combine X identity), (combine -;; identity X) and X are always the same. -;; -;; To make things more concrete, a simple use of a fingertree is as a -;; deque that keeps a running total. In this case, the converter can -;; simply be the function (lambda (x) x) if it is a deque of integers, -;; the combiner would be +, and the identity 0. -;; -;; (define l '(3 1 4 1 5 9)) -;; -;; (define ft (list->fingertree l 0 + (lambda (x) x))) -;; -;; (fingertree-measure ft) -;; ; => 23 -;; (fingertree-measure (fingertree-snoc ft 2)) -;; ; => 25 -;; (let-values (((head tail) (fingertree-uncons ft))) -;; (fingertree-measure tail)) -;; ; => 20 -;; -;; Mathematically speaking, the _return type_ of the converter, the -;; combiner and the identity element are expected to form a -;; monoid. -;; -;; Below, I use the slightly incorrect terminology of referring to the -;; combiner, the converter, and the identity, together as a -;; monoid. Mathematicians, please forgive me. Programmers please forgive -;; me even more. If you can provide a better name (from a programmers, -;; not a mathematicians, point of view) that works in most circumstances, -;; I will be happy to use it. -;; -;; (FWIW the Haskell Data.Fingertree package uses odd name of Measured -;; (which are expected to be instances of Monoid)) -;; -;; fingertree? : any -> bool -;; returns #t if argument is a fingertree, #f otherwise. -;; -;; fingertree-empty? : fingertree -> bool -;; returns #t if there are no items in the fingertree, #f otherwise. -;; -;; make-fingertree : id combine measure -> fingertree -;; returns a new fingertree, parameterised by the given monoid. -;; -;; fingertree-cons : any fingertree -> fingertree -;; returns the new fingertree created by adding the element to the front -;; of the argument fingertree. -;; -;; fingertree-snoc : fingertree any -> fingertree -;; returns the new fingertree created by adding the element to the end of -;; the fingertree. -;; -;; fingertree-uncons : fingertree -> any + fingertree -;; returns two values: the element at the front of the fingertree, and a -;; new fingertree containing all but the front element. If the fingertree -;; is empty, a &fingertree-empty condition is raised. -;; -;; fingertree-unsnoc : fingertree -> fingertree + any -;; returns two values: a new fingertree containing all but the rear -;; element of the argument fingertree, and the rear element itself. If -;; the fingertree is empty, a &fingertree-empty-condition is raised. -;; -;; fingertree-append : fingertree fingertree -> fingertree -;; returns a new fingertree which contains all of the elements of the -;; first fingertree argument, followed by all the elements of the -;; second. The argument fingertrees are assumed to be parameterised by -;; the same monoid. -;; -;; list->fingertree : (list->fingertree l id append convert) -;; returns a fingertree containing all of the elements of the argument -;; list, in the same order. -;; -;; fingertree->list : fingertree -> Listof(Any) -;; returns a list of all the elements in the fingertree, in the order -;; they would be unconsed. -;; -;; fingertree-measure : fingertree -> any -;; returns the measure of the fingertree, as defined by the fingertree's -;; monoid. -;; -;; fingertree-split : (any -> bool) fingertree -> fingertree + fingertree -;; returns two values: the first is the largest prefix of the fingertree for -;; which applying the predicate to it's accumulated measure returns -;; #f. The second values is a fingertree containing all those elements -;; not in the first fingertree. -;; -;; fingertree-split3: (any -> bool) fingertree -> fingertree + value + fingertree -;; similar to fingertree-split, however, instead of returning the -;; remainder as the second argument, it returns the head of the remainder -;; as the second argument, and tail of the remainder as the third -;; argument. -;; TODO: what error should I give if the remainder was empty? -;; -;; fingertree-fold : (any -> any -> any) any fingertree -;; returns the value obtained by iterating the combiner procedure over -;; the fingertree in left-to-right order. This procedure takes two -;; arguments, the current value from the fingertree, and an accumulator, -;; and it's return value is used as the accumulator for the next -;; iteration. The initial value for the accumulator is given by the base -;; argument. -;; -;; fingertree-fold-right : (any -> any -> any) any fingertree -;; similar to fingertree-fold, but iterates in right-to-left order. -;; -;; fingertree-reverse : fingertree -> fingertree -;; returns a new fingertree in which the elements are in the opposite -;; order from the argument fingertree. -;; -;; fingertree-empty-condition? : condition -> bool -;; returns #t if the argument is a &fingertree-empty condition, #f otherwise. -;; -(library (pfds fingertrees) -(export fingertree? - fingertree-empty? - make-fingertree - fingertree-cons - fingertree-snoc - fingertree-uncons - fingertree-unsnoc - fingertree-append - list->fingertree - fingertree->list - fingertree-measure - fingertree-split - fingertree-split3 - fingertree-fold - fingertree-fold-right - fingertree-reverse - fingertree-empty-condition? - ) -(import (rnrs)) - -;;; List helpers - -(define (snoc l val) - (append l (list val))) - -(define (take l n) - (if (or (null? l) (zero? n)) - '() - (cons (car l) - (take (cdr l) (- n 1))))) - -(define (last list) - (if (null? (cdr list)) - (car list) - (last (cdr list)))) - -(define (but-last list) - (if (null? (cdr list)) - '() - (cons (car list) - (but-last (cdr list))))) - -(define (map-reverse f l) - (fold-left (lambda (o n) (cons (f n) o)) '() l)) - -;;; Node type - -(define-record-type node2 - (protocol - (lambda (new) - (lambda (monoid a b) - (define app (mappend monoid)) - (new (app (measure-nodetree a monoid) - (measure-nodetree b monoid)) - a - b)))) - (fields measure a b)) - -(define-record-type node3 - (protocol - (lambda (new) - (lambda (monoid a b c) - (define app (mappend monoid)) - (new (app (app (measure-nodetree a monoid) - (measure-nodetree b monoid)) - (measure-nodetree c monoid)) - a - b - c)))) - (fields measure a b c)) - -(define (node-case node k2 k3) - (if (node2? node) - (k2 (node2-a node) (node2-b node)) - (k3 (node3-a node) (node3-b node) (node3-c node)))) - -(define (node-fold-right f base node) - (node-case node - (lambda (a b) - (f a (f b base))) - (lambda (a b c) - (f a (f b (f c base)))))) - -(define (node->list node) - (node-fold-right cons '() node)) - -(define (nodetree-fold-right f base nodetree) - (define (foldr node base) - (cond ((node2? node) - (foldr (node2-a node) - (foldr (node2-b node) base))) - ((node3? node) - (foldr (node3-a node) - (foldr (node3-b node) - (foldr (node3-c node) base)))) - (else (f node base)))) - (foldr nodetree base)) - -(define (nodetree-fold-left f base nodetree) - (define (foldl node base) - (cond ((node2? node) - (foldl (node2-b node) - (foldl (node2-a node) base))) - ((node3? node) - (foldl (node3-c node) - (foldl (node3-b node) - (foldl (node3-a node) base)))) - (else (f node base)))) - (foldl nodetree base)) - -;;; Tree type - -(define-record-type empty) - -(define-record-type single - (fields value)) - -(define-record-type rib - (protocol - (lambda (new) - (lambda (monoid left middle right) - (define app (mappend monoid)) - (new (app (app (measure-digit left monoid) - (measure-ftree middle monoid)) - (measure-digit right monoid)) - left - middle - right) - ))) - ;; left and right expected to be lists of length 0 < l < 5 - (fields measure left middle right)) - -(define (ftree-case ftree empty-k single-k rib-k) - (cond ((empty? ftree) (empty-k)) - ((single? ftree) - (single-k (single-value ftree))) - (else - (rib-k (rib-left ftree) - (rib-middle ftree) - (rib-right ftree))))) - -(define (digits-fold-right f b d) - (fold-right (lambda (ntree base) - (nodetree-fold-right f base ntree)) - b - d)) - -(define (digits-fold-left f b d) - (fold-left (lambda (base ntree) - (nodetree-fold-left f base ntree)) - b - d)) - -(define (ftree-fold-right proc base ftree) - (ftree-case ftree - (lambda () base) - (lambda (x) (nodetree-fold-right proc base x)) - (lambda (l x r) - (define base* (digits-fold-right proc base r)) - (define base** (ftree-fold-right proc base* x)) - (digits-fold-right proc base** l)))) - -(define (ftree-fold-left proc base ftree) - (ftree-case ftree - (lambda () base) - (lambda (x) (nodetree-fold-left proc base x)) - (lambda (l x r) - (define base* (digits-fold-left proc base l)) - (define base** (ftree-fold-left proc base* x)) - (digits-fold-left proc base** r)))) - -(define (insert-front ftree val monoid) - (ftree-case ftree - (lambda () - (make-single val)) - (lambda (a) - (make-rib monoid (list val) (make-empty) (list a))) - (lambda (l m r) - (if (= (length l) 4) - (make-rib monoid - (list val (car l)) - (insert-front m (apply make-node3 monoid (cdr l)) monoid) - r) - (make-rib monoid (cons val l) m r))))) - -(define (view-front ftree empty-k cons-k monoid) - (ftree-case ftree - empty-k - (lambda (a) - (cons-k a (make-empty))) - (lambda (l r m) - (cons-k (car l) - (rib-l (cdr l) r m monoid))))) - -(define (list->tree l monoid) - (fold-right (lambda (val tree) - (insert-front tree val monoid)) - (make-empty) - l)) - -(define (rib-l l m r monoid) - (if (null? l) - (view-front m - (lambda () - (list->tree r monoid)) - (lambda (x xs) - (make-rib monoid - (node->list x) - xs - r)) - monoid) - (make-rib monoid l m r))) - -(define (remove-front ftree monoid) - (view-front ftree - (lambda () - (error 'remove-front "can't remove from an empty tree")) - values - monoid)) - -(define (insert-rear ftree val monoid) - (ftree-case ftree - (lambda () - (make-single val)) - (lambda (a) - (make-rib monoid (list a) (make-empty) (list val))) - (lambda (l m r) - ;; TODO: should r be maintained in reverse order, rather than - ;; normal? - ;; yes! it will make concatenation slightly slower, but will - ;; speed up inserts and removals - (if (= (length r) 4) - (make-rib monoid - l - (insert-rear m (apply make-node3 monoid (take r 3)) monoid) - (list (list-ref r 3) val)) - (make-rib monoid l m (snoc r val)))))) - -(define (remove-rear ftree monoid) - (view-rear ftree - (lambda () - (error 'remove-rear "can't remove from an empty tree")) - values - monoid)) - -(define (view-rear ftree empty-k snoc-k monoid) - (ftree-case ftree - empty-k - (lambda (a) - (snoc-k (make-empty) a)) - (lambda (l r m) - (snoc-k (rib-r l r (but-last m) monoid) - (last m))))) - -(define (rib-r l m r monoid) - (if (null? r) - (view-rear m - (lambda () - (list->tree l monoid)) - (lambda (m* r*) - (make-rib monoid l m* (node->list r*))) - monoid) - (make-rib monoid l m r))) - -(define (insert-front/list tree l monoid) - (fold-right (lambda (val tree) - (insert-front tree val monoid)) - tree - l)) - -(define (insert-rear/list tree l monoid) - (fold-left (lambda (tree val) - (insert-rear tree val monoid)) - tree - l)) - -(define (app3 ftree1 ts ftree2 monoid) - (cond ((empty? ftree1) - (insert-front/list ftree2 ts monoid)) - ((empty? ftree2) - (insert-rear/list ftree1 ts monoid)) - ((single? ftree1) - (insert-front (insert-front/list ftree2 ts monoid) - (single-value ftree1) - monoid)) - ((single? ftree2) - (insert-rear (insert-rear/list ftree1 ts monoid) - (single-value ftree2) - monoid)) - (else - (let ((l1 (rib-left ftree1)) - (m1 (rib-middle ftree1)) - (r1 (rib-right ftree1)) - (l2 (rib-left ftree2)) - (m2 (rib-middle ftree2)) - (r2 (rib-right ftree2))) - (make-rib monoid - l1 - (app3 m1 - (nodes (append r1 ts l2) monoid) - m2 - monoid) - r2))))) - -(define (nodes lst monoid) - ;; *sigh* - (let ((a (car lst)) - (b (cadr lst))) - (cond ((null? (cddr lst)) - (list (make-node2 monoid a b))) - ((null? (cdddr lst)) - (list (make-node3 monoid a b (caddr lst)))) - ((null? (cddddr lst)) - (list (make-node2 monoid a b) - (make-node2 monoid (caddr lst) (cadddr lst)))) - (else - (cons (make-node3 monoid a b (caddr lst)) - (nodes (cdddr lst) monoid)))))) - -(define (reverse-tree tree monoid) - (ftree-case tree - (lambda () (make-empty)) - (lambda (x) (make-single (reverse-nodetree x monoid))) - (lambda (l x r) - (make-rib monoid - (reverse-digit r monoid) - (reverse-tree x monoid) - (reverse-digit l monoid))))) - -(define (reverse-digit l monoid) - (map-reverse (lambda (a) (reverse-nodetree a monoid)) l)) - -(define (reverse-nodetree l monoid) - (cond ((node2? l) - (make-node2 monoid - (reverse-nodetree (node2-b l) monoid) - (reverse-nodetree (node2-a l) monoid))) - ((node3? l) - (make-node3 monoid - (reverse-nodetree (node3-c l) monoid) - (reverse-nodetree (node3-b l) monoid) - (reverse-nodetree (node3-a l) monoid))) - (else l))) - -;; generalising fingertrees with monoids - -;; I think I'm going to need a "configuration" type and pass it around -;; in order to generalize over arbitrary monoids -;; call the type iMeasured or something - -(define-record-type monoid* - ;; a monoid, but augmented with a procedure to convert objects into the - ;; monoid type - (fields (immutable empty mempty) - (immutable append mappend) - (immutable convert mconvert))) - -(define (measure-digit obj monoid) - (fold-left (lambda (i a) - ((mappend monoid) i (measure-nodetree a monoid))) - (mempty monoid) - obj)) - -(define (measure-ftree obj monoid) - (cond ((empty? obj) - (mempty monoid)) - ((single? obj) - (measure-nodetree (single-value obj) monoid)) - (else - (rib-measure obj)))) - -(define (measure-nodetree obj monoid) - (cond ((node2? obj) (node2-measure obj)) - ((node3? obj) (node3-measure obj)) - (else ((mconvert monoid) obj)))) - -(define (split proc tree monoid) - (if (empty? tree) - (values (make-empty) (make-empty)) - (if (proc (measure-ftree tree monoid)) - (let-values (((l x r) (split-tree proc (mempty monoid) tree monoid))) - (values l (insert-front r x monoid))) - (values tree (make-empty))))) - -(define (split-tree proc i tree monoid) - (ftree-case tree - (lambda () - (error 'split-tree "shouldn't happen?")) - (lambda (a) - (values (make-empty) a (make-empty))) - (lambda (l m r) - (define app (mappend monoid)) - (define vpr (app i (measure-digit l monoid))) - (define vm (app vpr (measure-ftree m monoid))) - (cond ((proc vpr) - (let-values (((l* x* r*) (split-digit proc i l monoid))) - (values (list->tree l* monoid) - x* - (rib-l r* m r monoid)))) - ((proc vm) - (let*-values (((ml xs mr) (split-tree proc vpr m monoid)) - ((l* x* r*) - (split-digit proc - (app vpr (measure-ftree ml monoid)) - (node->list xs) - monoid))) - (values (rib-r l ml l* monoid) - x* - (rib-l r* mr r monoid)))) - (else - (let-values (((l* x* r*) (split-digit proc vm r monoid))) - (values (rib-r l m l* monoid) - x* - (list->tree r* monoid)))))))) - -(define (split-digit proc i xs monoid) - (if (null? (cdr xs)) - (values '() (car xs) '()) - (let ((i* ((mappend monoid) i (measure-nodetree (car xs) monoid)))) - (if (proc i*) - (values '() (car xs) (cdr xs)) - (let-values (((l x r) - (split-digit proc i* (cdr xs) monoid))) - (values (cons (car xs) l) x r)))))) - -;; exported interface -(define-condition-type &fingertree-empty - &assertion - make-fingertree-empty-condition - fingertree-empty-condition?) - -(define-record-type (fingertree %make-fingertree fingertree?) - (fields tree monoid)) - -(define (%wrap fingertree tree) - (%make-fingertree tree - (fingertree-monoid fingertree))) - -(define (make-fingertree id append convert) - (%make-fingertree (make-empty) - (make-monoid* id append convert))) - -(define (fingertree-cons a fingertree) - ;; TODO: should it obey normal cons interface, or have fingertree - ;; first? - (%wrap fingertree - (insert-front (fingertree-tree fingertree) - a - (fingertree-monoid fingertree)))) - -(define (fingertree-snoc fingertree a) - (%wrap fingertree - (insert-rear (fingertree-tree fingertree) - a - (fingertree-monoid fingertree)))) - -(define (fingertree-uncons fingertree) - (call-with-values - (lambda () - (define t (fingertree-tree fingertree)) - (when (empty? t) - (raise - (condition - (make-fingertree-empty-condition) - (make-who-condition 'fingertree-uncons) - (make-message-condition "There are no elements to uncons") - (make-irritants-condition (list fingertree))))) - (remove-front t (fingertree-monoid fingertree))) - (lambda (val rest) - (values val - (%wrap fingertree rest))))) - -(define (fingertree-unsnoc fingertree) - (call-with-values - (lambda () - (define t (fingertree-tree fingertree)) - (when (empty? t) - (raise - (condition - (make-fingertree-empty-condition) - (make-who-condition 'fingertree-unsnoc) - (make-message-condition "There are no elements to unsnoc") - (make-irritants-condition (list fingertree))))) - (remove-rear t (fingertree-monoid fingertree))) - (lambda (rest val) - (values (%wrap fingertree rest) val)))) - -(define (fingertree-empty? fingertree) - (empty? (fingertree-tree fingertree))) - -(define (fingertree-append fingertree1 fingertree2) - (%wrap fingertree1 - (app3 (fingertree-tree fingertree1) - '() - (fingertree-tree fingertree2) - (fingertree-monoid fingertree1)))) - -;; TODO: fix this -(define (list->fingertree l id append convert) - (define monoid (make-monoid* id append convert)) - (%make-fingertree (list->tree l monoid) monoid)) - -(define (fingertree->list t) - (fingertree-fold-right cons '() t)) - -(define (fingertree-measure fingertree) - (measure-ftree (fingertree-tree fingertree) - (fingertree-monoid fingertree))) - - -(define (fingertree-split p fingertree) - (call-with-values - (lambda () - (split p - (fingertree-tree fingertree) - (fingertree-monoid fingertree))) - (lambda (a b) - (values (%wrap fingertree a) - (%wrap fingertree b))))) - -(define (fingertree-split3 p fingertree) - (call-with-values - (lambda () - (define monoid (fingertree-monoid fingertree)) - (split-tree p - (mempty monoid) - (fingertree-tree fingertree) - monoid)) - (lambda (a b c) - (values (%wrap fingertree a) - b - (%wrap fingertree c))))) - -(define (fingertree-fold f b fingertree) - (ftree-fold-left f b (fingertree-tree fingertree))) - -(define (fingertree-fold-right f b fingertree) - (ftree-fold-right f b (fingertree-tree fingertree))) - -(define (fingertree-reverse fingertree) - (%wrap fingertree - (reverse-tree (fingertree-tree fingertree) - (fingertree-monoid fingertree)))) - -) - -;;; hamts.sls --- Hash Array Mapped Tries - -;; Copyright (C) 2014 Ian Price - -;; Author: Ian Price - -;; This program is free software, you can redistribute it and/or -;; modify it under the terms of the new-style BSD license. - -;; You should have received a copy of the BSD license along with this -;; program. If not, see . - -;; Documentation: -;; -;; Note: For all procedures which take a key as an argument, the key -;; must be hashable with the hamt hash function, and comparable with -;; the hamt equivalence predicate. -;; -;; make-hamt : (any -> non-negative integer) (any -> any -> boolean) -> hamt -;; returns a new empty hamt using the given hash and equivalence functions. -;; -;; hamt? : any -> boolean -;; returns #t if argument is a hamt, #f otherwise. -;; -;; hamt-size : hamt -> non-negative integer -;; returns the number of associations in the hamt. -;; -;; hamt-ref : hamt any [any] -> any -;; returns the value associated with the key in the hamt. If there is -;; no value associated with the key, it returns the default value if -;; provided, or raises an &assertion-violation if it isn't. -;; -;; hamt-contains? : hamt any -> boolean -;; returns #t if there is an association for the key in the hamt, #f -;; otherwise. -;; -;; hamt-set : hamt any any -> hamt -;; returns a new hamt with the key associated to the value. If the key -;; is already associated with a value, it is replaced. -;; -;; hamt-update : hamt any (any -> any) any -> hamt -;; returns a new hamt with the valued associated with the key updated -;; by the update procedure. If the hamt does not already have a value -;; associated with the key, then it applies the update procedure to -;; the default value, and associates the key with that. -;; -;; hamt-delete : hamt any -> hamt -;; returns a hamt with the key and its associated value removed. If -;; the key is not in the hamt, a copy of the original hamt is -;; returned. -;; -;; hamt-fold : (any any any -> any) any hamt -> hamt -;; returns the value obtained by iterating the combine procedure over -;; each key value pair in the hamt. The combine procedure takes three -;; arguments, the key and value of an association, and an accumulator, -;; and returns a new accumulator value. The initial value of the -;; accumulator is provided by the base argument. The order in which -;; the hamt is traversed is not guaranteed. -;; -;; hamt-map : (any -> any) hamt -> hamt -;; returns the hamt obtained by applying the update procedure to each -;; of the values in the hamt. -;; -;; hamt->alist : hamt -> Listof(Pairs) -;; returns the key/value associations of the hamt as a list of pairs. -;; The order of the list is not guaranteed. -;; -;; alist->hamt : Listof(Pairs) (any -> non-negative integer) (any -> any -> boolean) -> hamt -;; returns the hamt containing the associations specified by the pairs -;; in the alist. If the same key appears in the alist multiple times, -;; its leftmost value is the one that is used. -;; -;; hamt-equivalence-predicate : hamt -> (any -> any -> boolean) -;; returns the procedure used internally by the hamt to compare keys. -;; -;; hamt-hash-function : hamt -> (any -> non-negative integer) -;; returns the hash procedure used internally by the hamt. -;; -(library (pfds hamts) -(export make-hamt - hamt? - hamt-size - hamt-ref - hamt-set - hamt-update - hamt-delete - hamt-contains? - hamt-equivalence-predicate - hamt-hash-function - hamt-fold - hamt-map - hamt->alist - alist->hamt - ) -(import (rnrs) - (pfds private vectors) - (pfds private alists) - (pfds private bitwise)) - -;;; Helpers - -(define cardinality 32) ; 64 - -(define (mask key level) - (bitwise-arithmetic-shift-right (bitwise-and key (- (expt 2 5) 1)) level)) - -(define (level-up level) - (+ level 5)) - -(define (ctpop key index) - (bitwise-bit-count (bitwise-arithmetic-shift-right key (+ 1 index)))) - -;;; Node types - -(define-record-type (subtrie %make-subtrie subtrie?) - (fields size bitmap vector)) - -(define (make-subtrie bitmap vector) - (define vecsize - (vector-fold (lambda (val accum) - (+ (size val) accum)) - 0 - vector)) - (%make-subtrie vecsize bitmap vector)) - -(define-record-type leaf - (fields key value)) - -(define-record-type (collision %make-collision collision?) - (fields size hash alist)) - -(define (make-collision hash alist) - (%make-collision (length alist) hash alist)) - -;;; Main - -(define (lookup vector key default hash eqv?) - (define (handle-subtrie node level) - (define bitmap (subtrie-bitmap node)) - (define vector (subtrie-vector node)) - (define index (mask h level)) - (if (not (bitwise-bit-set? bitmap index)) - default - (let ((node (vector-ref vector (ctpop bitmap index)))) - (cond ((leaf? node) - (handle-leaf node)) - ((collision? node) - (handle-collision node)) - (else - (handle-subtrie node (level-up level))))))) - - (define (handle-leaf node) - (if (eqv? key (leaf-key node)) - (leaf-value node) - default)) - - (define (handle-collision node) - (alist-ref (collision-alist node) key default eqv?)) - - (define h (hash key)) - (define node (vector-ref vector (mask h 0))) - - (cond ((not node) default) - ((leaf? node) (handle-leaf node)) - ((collision? node) (handle-collision node)) - (else - (handle-subtrie node (level-up 0))))) - -(define (insert hvector key update base hash eqv?) - (define (handle-subtrie subtrie level) - (define bitmap (subtrie-bitmap subtrie)) - (define vector (subtrie-vector subtrie)) - (define index (mask h level)) - (define (fixup node) - (make-subtrie bitmap (vector-set vector index node))) - (if (not (bitwise-bit-set? bitmap index)) - (make-subtrie (bitwise-bit-set bitmap index) - (vector-insert vector - (ctpop bitmap index) - (make-leaf key (update base)))) - (let ((node (vector-ref vector (ctpop bitmap index)))) - (cond ((leaf? node) - (fixup (handle-leaf node level))) - ((collision? node) - (fixup (handle-collision node level))) - (else - (fixup (handle-subtrie node (level-up level)))))))) - - (define (handle-leaf node level) - (define lkey (leaf-key node)) - (define khash (bitwise-arithmetic-shift-right h level)) - (define lhash (bitwise-arithmetic-shift-right (hash lkey) level)) - (cond ((eqv? key lkey) - (make-leaf key (update (leaf-value node)))) - ((equal? khash lhash) - (make-collision lhash - (list (cons lkey (leaf-value node)) - (cons key (update base))))) - (else - (handle-subtrie (wrap-subtrie node lhash) (level-up level))))) - - (define (handle-collision node level) - (define khash (bitwise-arithmetic-shift-right h level)) - (define chash (bitwise-arithmetic-shift-right (collision-hash node) level)) - (if (equal? khash chash) - (make-collision (collision-hash node) - (alist-update (collision-alist node) key update base eqv?)) - ;; TODO: there may be a better (more efficient) way to do this - ;; but simple is better for now (see also handle-leaf) - (handle-subtrie (wrap-subtrie node chash) (level-up level)))) - - (define (wrap-subtrie node chash) - (make-subtrie (bitwise-bit-set 0 (mask chash 0)) (vector node))) - - (define h (hash key)) - (define idx (mask h 0)) - (define node (vector-ref hvector idx)) - (define initial-level (level-up 0)) - - (cond ((not node) - (vector-set hvector idx (make-leaf key (update base)))) - ((leaf? node) - (vector-set hvector idx (handle-leaf node initial-level))) - ((collision? node) - (vector-set hvector idx (handle-collision node initial-level))) - (else - (vector-set hvector idx (handle-subtrie node initial-level))))) - -(define (delete vector key hash eqv?) - (define (handle-subtrie subtrie level) - (define bitmap (subtrie-bitmap subtrie)) - (define vector (subtrie-vector subtrie)) - (define index (mask h level)) - (define (fixup node) - (update bitmap vector index node)) - (if (not (bitwise-bit-set? bitmap index)) - subtrie - (let ((node (vector-ref vector (ctpop bitmap index)))) - (cond ((leaf? node) - (fixup (handle-leaf node))) - ((collision? node) - (fixup (handle-collision node))) - (else - (fixup (handle-subtrie node (level-up level)))))))) - - (define (update bitmap vector index value) - (if value - (make-subtrie bitmap (vector-set vector index value)) - (let ((vector* (vector-remove vector index))) - (if (equal? '#() vector) - #f - (make-subtrie (bitwise-bit-unset bitmap index) - vector*))))) - - (define (handle-leaf node) - (if (eqv? key (leaf-key node)) - #f - node)) - - (define (handle-collision node) - (let ((al (alist-delete (collision-alist node) key eqv?))) - (cond ((null? (cdr al)) - (make-leaf (car (car al)) (cdr (car al)))) - (else - (make-collision (collision-hash node) al))))) - - (define h (hash key)) - (define idx (mask h 0)) - (define node (vector-ref vector idx)) - - (cond ((not node) vector) - ((leaf? node) - (vector-set vector idx (handle-leaf node))) - ((collision? node) - (vector-set vector idx (handle-collision node))) - (else - (vector-set vector idx (handle-subtrie node (level-up 0)))))) - -(define (vec-map mapper vector) - (define (handle-subtrie trie) - (make-subtrie (subtrie-bitmap trie) - (vector-map dispatch (subtrie-vector vector)))) - - (define (handle-leaf leaf) - (make-leaf (leaf-key leaf) - (mapper (leaf-value leaf)))) - - (define (handle-collision collision) - (make-collision (collision-hash collision) - (map (lambda (pair) - (cons (car pair) (mapper (cdr pair)))) - (collision-alist collision)))) - - (define (dispatch val) - (cond ((leaf? val) - (handle-leaf val)) - ((collision? val) - (handle-collision val)) - (else - (handle-subtrie val)))) - - (vector-map (lambda (val) - ;; top can have #f values - (and val (dispatch val))) - vector)) - -(define (fold combine initial vector) - (define (handle-subtrie trie accum) - (vector-fold dispatch accum (subtrie-vector vector))) - - (define (handle-leaf leaf accum) - (combine (leaf-key leaf) (leaf-value leaf) accum)) - - (define (handle-collision collision accum) - (fold-right (lambda (pair acc) - (combine (car pair) (cdr pair) acc)) - accum - (collision-alist collision))) - - (define (dispatch val accum) - (cond ((leaf? val) - (handle-leaf val accum)) - ((collision? val) - (handle-collision val accum)) - (else - (handle-subtrie val accum)))) - - (vector-fold (lambda (val accum) - ;; top level can have false values - (if (not val) accum (dispatch val accum))) - initial - vector)) - -(define (size node) - (cond ((not node) 0) - ((leaf? node) 1) - ((collision? node) (collision-size node)) - (else (subtrie-size node)))) - -;;; Exported Interface - -(define-record-type (hamt %make-hamt hamt?) - (fields size root hash-function equivalence-predicate)) - -(define (wrap-root root hamt) - (define vecsize - (vector-fold (lambda (val accum) - (+ (size val) accum)) - 0 - root)) - (%make-hamt vecsize - root - (hamt-hash-function hamt) - (hamt-equivalence-predicate hamt))) - -(define (make-hamt hash eqv?) - (%make-hamt 0 (make-vector cardinality #f) hash eqv?)) - -(define hamt-ref - (case-lambda - ((hamt key) - (define token (cons #f #f)) - (define return-val (hamt-ref hamt key token)) - (when (eqv? token return-val) - (assertion-violation 'hamt-ref "Key is not in the hamt" key)) - return-val) - ((hamt key default) - ;; assert hamt? - (lookup (hamt-root hamt) - key - default - (hamt-hash-function hamt) - (hamt-equivalence-predicate hamt))))) - -(define (hamt-set hamt key value) - (define root - (insert (hamt-root hamt) - key - (lambda (old) value) - 'dummy - (hamt-hash-function hamt) - (hamt-equivalence-predicate hamt))) - (wrap-root root hamt)) - -(define (hamt-update hamt key proc default) - (define root - (insert (hamt-root hamt) - key - proc - default - (hamt-hash-function hamt) - (hamt-equivalence-predicate hamt))) - (wrap-root root hamt)) - -(define (hamt-delete hamt key) - (define root - (delete (hamt-root hamt) - key - (hamt-hash-function hamt) - (hamt-equivalence-predicate hamt))) - (wrap-root root hamt)) - -(define (hamt-contains? hamt key) - (define token (cons #f #f)) - (if (eqv? token (hamt-ref hamt key token)) - #f - #t)) - -(define (hamt-map mapper hamt) - (%make-hamt (hamt-size hamt) - (vec-map mapper (hamt-root hamt)) - (hamt-hash-function hamt) - (hamt-equivalence-predicate hamt))) - -(define (hamt-fold combine initial hamt) - (fold combine initial (hamt-root hamt))) - -(define (hamt->alist hamt) - (hamt-fold (lambda (key value accumulator) - (cons (cons key value) accumulator)) - '() - hamt)) - -(define (alist->hamt alist hash eqv?) - (fold-right (lambda (kv-pair hamt) - (hamt-set hamt (car kv-pair) (cdr kv-pair))) - (make-hamt hash eqv?) - alist)) - -) - -;; Copyright (C) 2012 Ian Price - -;; Author: Ian Price - -;; This program is free software, you can redistribute it and/or -;; modify it under the terms of the new-style BSD license. - -;; You should have received a copy of the BSD license along with this -;; program. If not, see . - -;; Documentation: -;; -;; make-heap : (any any -> bool) -> heap -;; returns a new empty heap which uses the ordering procedure. -;; -;; heap : (any any -> bool) any ... -> heap -;; return a new heap, ordered by the procedure argument, that contains -;; all the other arguments as elements. -;; -;; heap? : any -> bool -;; returns #t if the argument is a heap, #f otherwise. -;; -;; heap-size : heap -> non-negative integer -;; returns the number of elements in the heap. -;; -;; heap-empty? : heap -> bool -;; returns #t if the heap contains no elements, #f otherwise. -;; -;; heap-min : heap -> any -;; returns the minimum element in the heap, according the heap's -;; ordering procedure. If there are no elements, a -;; &heap-empty-condition is raised. -;; -;; heap-delete-min : heap -> heap -;; returns a new heap containing all the elements of the heap -;; argument, except for the minimum argument, as determined by the -;; heap's ordering procedure. If there are no elements, a -;; &heap-empty-condition is raised. -;; -;; heap-pop : any + heap -;; returns two values: the the minimum value, and a heap obtained by -;; removing the minimum value from the original heap. If the heap is -;; empty, a &heap-empty-condition is raised. -;; -;; heap-insert : heap any -> heap -;; returns the new heap obtained by adding the element to those in the -;; argument heap. -;; -;; heap->list : heap -> Listof(any) -;; returns the heap containing all the elements of the heap. The -;; elements of the list are ordered according to the heap's ordering -;; procedure. -;; -;; list->heap : Listof(any) (any any -> boolean) -> heap -;; returns the heap containing all the elements of the list, and using -;; the procedure argument to order the elements. -;; -;; heap-merge : heap heap -> heap -;; returns the heap containing all the elements of the argument -;; heaps. The argument heaps are assumed to be using the same ordering -;; procedure. -;; -;; heap-sort : (any any -> bool) list -> list -;; returns a new list that is a permutation of the argument list, such -;; that all the elements are ordered by the given procedure. -;; -;; heap-ordering-procedure : heap -> (any any -> boolean) -;; returns the ordering procedure used internally by the heap. -;; -;; heap-empty-condition? : any -> bool -;; returns #t if argument is a &heap-empty condition, #f otherwise. -;; -(library (pfds heaps) -(export make-heap - (rename (%heap heap)) - heap? - heap-size - heap-empty? - heap-min - heap-delete-min - heap-insert - heap-pop - heap->list - list->heap - heap-merge - heap-sort - (rename (heap-ordering-predicate heap-ordering-procedure)) - heap-empty-condition? - ) -(import (rnrs)) - -(define-record-type (node %make-node node?) - (fields size height value left right)) - -(define-record-type leaf) - -(define (height x) - (if (leaf? x) - 0 - (node-height x))) - -(define (size x) - (if (leaf? x) - 0 - (node-size x))) - -(define (make-node v l r) - (define sl (height l)) - (define sr (height r)) - (define m (+ 1 (min sl sr))) - (define sz (+ 1 (size l) (size r))) - (if (< sl sr) - (%make-node sz m v r l) - (%make-node sz m v l r))) - -(define (singleton v) - (%make-node 1 0 v (make-leaf) (make-leaf))) - -(define (insert tree value prioheap vals <)) - -(define (heap-size heap) - (size (heap-tree heap))) - -(define (heap-empty? heap) - (leaf? (heap-tree heap))) - -(define (heap-min heap) - (when (heap-empty? heap) - (raise (condition - (make-heap-empty-condition) - (make-who-condition 'heap-min) - (make-message-condition "There is no minimum element.") - (make-irritants-condition (list heap))))) - (node-value (heap-tree heap))) - -(define (heap-delete-min heap) - (when (heap-empty? heap) - (raise (condition - (make-heap-empty-condition) - (make-who-condition 'heap-delete-min) - (make-message-condition "There is no minimum element.") - (make-irritants-condition (list heap))))) - (let ((< (heap-ordering-predicate heap))) - (%make-heap (delete-min (heap-tree heap) <) <))) - -(define (heap-pop heap) - (when (heap-empty? heap) - (raise (condition - (make-heap-empty-condition) - (make-who-condition 'heap-pop) - (make-message-condition "There is no minimum element.") - (make-irritants-condition (list heap))))) - (let* ((tree (heap-tree heap)) - (top (node-value tree)) - (< (heap-ordering-predicate heap)) - (rest (delete-min tree <))) - (values top - (%make-heap rest <)))) - -(define (heap-insert heap value) - (assert (heap? heap)) - (let ((< (heap-ordering-predicate heap))) - (%make-heap (insert (heap-tree heap) value <) <))) - -(define (heap->list heap) - (assert (heap? heap)) - (let ((< (heap-ordering-predicate heap))) - (let loop ((tree (heap-tree heap)) (list '())) - (if (leaf? tree) - (reverse list) - (loop (delete-min tree <) - (cons (node-value tree) list)))))) - -(define (list->heap list <) - (%make-heap - (fold-left (lambda (h item) - (insert h item <)) - (make-leaf) - list) - <)) - -(define (heap-merge heap1 heap2) - (define < (heap-ordering-predicate heap1)) - (%make-heap - (merge-trees (heap-tree heap1) - (heap-tree heap2) - <) - <)) - -(define (heap-sort < list) - (heap->list (list->heap list <))) - -(define-condition-type &heap-empty - &assertion - make-heap-empty-condition - heap-empty-condition?) -) -(package (pfds (0 3)) - (depends (wak-trc-testing)) - (synopsis "Purely Functional Data Structures") - (description - "A library of data structures for functional programmers." - "It contains implementations of:" - "- queues" - "- deques" - "- bbtrees" - "- sets" - "- dlists" - "- priority search queues" - "- heaps" - "- hamts" - "- finger trees" - "- sequences") - (homepage "http://github.com/ijp/pfds") - (documentation - "README.org" - "LICENSE") - (libraries - (sls -> "pfds") - ("queues" -> ("pdfs" "queues")) - ("deques" -> ("pdfs" "deques")) - ("private" -> ("pfds" "private")))) - -;;; psqs.sls --- Priority Search Queues - -;; Copyright (C) 2012 Ian Price - -;; Author: Ian Price - -;; This program is free software, you can redistribute it and/or -;; modify it under the terms of the new-style BSD license. - -;; You should have received a copy of the BSD license along with this -;; program. If not, see . - -;;;; Documentation -;; -;; Priority search queues are a combination of two common abstract -;; data types: finite maps, and priority queues. As such, it provides -;; for access, insertion, removal and update on arbitrary keys, as -;; well as for easy removal of the element with the lowest priority. -;; -;; Note: where a procedure takes a key or priority these are expected -;; to be compatible with the relevant ordering procedures on the psq. -;; -;;;; Basic operations -;; -;; make-psq : < < -> psq -;; takes a two ordering procedures, one for keys, and another for -;; priorities, and returns an empty priority search queue -;; -;; psq? : obj -> boolean -;; returns #t if the object is a priority search queue, #f otherwise. -;; -;; psq-empty? : psq -> boolean -;; returns #t if the priority search queue contains no elements, #f -;; otherwise. -;; -;; psq-size : psq -> non-negative integer -;; returns the number of associations in the priority search queue -;; -;;;; Finite map operations -;; -;; psq-ref : psq key -> priority -;; returns the priority of a key if it is in the priority search -;; queue. If the key is not in the priority queue an -;; assertion-violation is raised. -;; -;; psq-set : psq key priority -> psq -;; returns the priority search queue obtained from inserting a key -;; with a given priority. If the key is already in the priority search -;; queue, it updates the priority to the new value. -;; -;; psq-update : psq key (priority -> priority) priority -> psq -;; returns the priority search queue obtained by modifying the -;; priority of key, by the given function. If the key is not in the -;; priority search queue, it is inserted with the priority obtained by -;; calling the function on the default value. -;; -;; psq-delete : psq key -> psq -;; returns the priority search queue obtained by removing the -;; key-priority association from the priority search queue. If the key -;; is not in the queue, then the returned search queue will be the -;; same as the original. -;; -;; psq-contains? : psq key -> boolean -;; returns #t if there is an association for the given key in the -;; priority search queue, #f otherwise. -;; -;;;; Priority queue operations -;; -;; psq-min : psq -> key -;; -;; returns the key of the minimum association in the priority search -;; queue. If the queue is empty, an assertion violation is raised. -;; -;; psq-delete-min : psq -> psq -;; returns the priority search queue obtained by removing the minimum -;; association in the priority search queue. If the queue is empty, an -;; assertion violation is raised. -;; -;; psq-pop : psq -> key + psq -;; returns two values: the minimum key and the priority search queue -;; obtained by removing the minimum association from the original -;; queue. If the queue is empty, an assertion violation is raised. -;; -;;;; Ranged query functions -;; -;; psq-at-most : psq priority -> ListOf(key . priority) -;; returns an alist containing all the associations in the priority -;; search queue with priority less than or equal to a given value. The -;; alist returned is ordered by key according to the predicate for the -;; psq. -;; -;; psq-at-most-range : psq priority key key -> ListOf(key . priority) -;; Similar to psq-at-most, but it also takes an upper and lower bound, -;; for the keys it will return. These bounds are inclusive. -;; -(library (pfds psqs) -(export make-psq - psq? - psq-empty? - psq-size - ;; map operations - psq-ref - psq-set - psq-update - psq-delete - psq-contains? - ;; priority queue operations - psq-min - psq-delete-min - psq-pop - ;; ranged query operations - psq-at-most - psq-at-most-range - ) -(import (except (rnrs) min)) - -;;; record types - -(define-record-type void) - -(define-record-type winner - (fields key priority loser-tree maximum-key)) - -(define-record-type start) - -(define-record-type (loser %make-loser loser?) - (fields size key priority left split-key right)) - -(define (make-loser key priority left split-key right) - (%make-loser (+ (size left) (size right) 1) - key - priority - left - split-key - right)) - -;;; functions -(define (maximum-key psq) - (winner-maximum-key psq)) - -(define max-key maximum-key) - -(define empty (make-void)) - -(define (singleton key priority) - (make-winner key priority (make-start) key)) - -(define (play-match psq1 psq2 key r-size (* weight l-size)) - (balance-left key priority left split-key right key l-size (* weight r-size)) - (balance-right key priority left split-key right key - -;; Author: Ian Price - -;; This program is free software, you can redistribute it and/or -;; modify it under the terms of the new-style BSD license. - -;; You should have received a copy of the BSD license along with this -;; program. If not, see . - -;;; Commentary: -;; -;; A scheme translation of "Simple and Efficient Purely Functional -;; Queues and Deques" by Chris Okazaki -;; -;; -;;; Documentation: -;; -;; make-queue : () -> queue -;; returns a queue containing no items -;; -;; queue? : any -> boolean -;; tests if an object is a queue -;; -;; queue-length : queue -> non-negative integer -;; returns the number of items in the queue -;; -;; queue-empty? : queue -> boolean -;; returns true if there are no items in the queue, false otherwise -;; -;; enqueue : queue any -> queue -;; returns a new queue with the enqueued item at the end -;; -;; dequeue : queue -> value queue -;; returns two values, the item at the front of the queue, and a new -;; queue containing the all the other items -;; raises a &queue-empty condition if the queue is empty -;; -;; queue-empty-condition? : object -> boolean -;; tests if an object is a &queue-empty condition -;; -;; queue->list : queue -> listof(any) -;; returns a queue containing all the items in the list. The order of -;; the elements in the queue is the same as the order of the elements -;; in the list. -;; -;; list->queue : listof(any) -> queue -;; returns a list containing all the items in the queue. The order of -;; the items in the list is the same as the order in the queue. -;; For any list l, (equal? (queue->list (list->queue l)) l) is #t. -;; -(library (pfds queues) -(export make-queue - queue? - queue-length - queue-empty? - enqueue - dequeue - queue-empty-condition? - list->queue - queue->list - ) -(import (except (rnrs) cons*) - (pfds private lazy-lists) - (pfds queues private condition) - (rnrs r5rs)) - -(define (rotate l r a) - (if (empty? l) - (cons* (head r) a) - (cons* (head l) - (rotate (tail l) - (tail r) - (cons* (head r) a))))) - - -;;; Implementation - -(define-record-type (queue %make-queue queue?) - (fields - (immutable length) - (immutable l) - (immutable r) - (immutable l^))) - - -(define (make-queue) - (%make-queue 0 '() '() '())) - -(define (enqueue queue item) - (let ((len (queue-length queue)) - (l (queue-l queue)) - (r (queue-r queue)) - (l^ (queue-l^ queue))) - (makeq (+ len 1) l (cons* item r) l^))) - -(define (dequeue queue) - (when (queue-empty? queue) - ;; (error 'dequeue "Can't dequeue empty queue") - (raise (condition - (make-queue-empty-condition) - (make-who-condition 'dequeue) - (make-message-condition "There are no elements to dequeue") - (make-irritants-condition (list queue))))) - (let ((len (queue-length queue)) - (l (queue-l queue)) - (r (queue-r queue)) - (l^ (queue-l^ queue))) - (values (head l) - (makeq (- len 1) (tail l) r l^)))) - -(define (makeq length l r l^) - (if (empty? l^) - (let ((l* (rotate l r '()))) - (%make-queue length l* '() l*)) - (%make-queue length l r (tail l^)))) - -(define (queue-empty? queue) - (zero? (queue-length queue))) - -(define (list->queue list) - (fold-left enqueue (make-queue) list)) - -(define (queue->list queue) - (let loop ((rev-list '()) (queue queue)) - (if (queue-empty? queue) - (reverse rev-list) - (let-values (((val queue) (dequeue queue))) - (loop (cons val rev-list) - queue))))) - -) - -;;; sequences.sls --- Purely Functional Sequences - -;; Copyright (C) 2012 Ian Price - -;; Author: Ian Price - -;; This program is free software, you can redistribute it and/or -;; modify it under the terms of the new-style BSD license. - -;; You should have received a copy of the BSD license along with this -;; program. If not, see . - -;;; Commentary: - -;; Sequences are a general-purpose, variable-length collection, -;; similar to lists, however they support efficient addition and -;; removal from both ends, and random-access. Like other Scheme -;; collections, sequences are zero-indexed. -;; -;; make-sequence : () -> sequence -;; returns a new empty sequence -;; -;; sequence any ... -> sequence -;; returns a new sequence containing all of the argument elements, in the -;; same order. -;; -;; sequence? : any -> bool -;; returns #t if the argument is a sequence, #f otherwise. -;; -;; sequence-empty? : sequence -> bool -;; returns #t if the argument sequence contains no elements, #f otherwise. -;; -;; sequence-size : sequence -> non-negative integer -;; returns the number of elements in the sequence -;; -;; sequence-cons : any sequence -> sequence -;; return the new sequence created by adding the element to the front of -;; the sequence. -;; -;; sequence-uncons : sequence -> any sequence -;; returns two values: the first element of the sequence, and a new -;; sequence containing all but the first element. If the sequence is -;; empty, a &sequence-empty condition is raised. -;; -;; sequence-snoc : sequence any -> sequence -;; return the new sequence created by adding the element to the end of -;; the sequence. -;; -;; sequence-unsnoc : sequence -> sequence any -;; returns two values: a new sequence containing all but the last -;; element of the sequence, and the last element itself. If the -;; sequence is empty, a &sequence-empty condition is raised. -;; -;; sequence-append : sequence sequence -> sequence -;; returns a new sequence containing all the elements of the first -;; sequence, followed by all the elements of the second sequence. -;; -;; list->sequence : Listof(Any) -> sequence -;; returns a new sequence containing all the elements of the argument -;; list, in the same order. -;; -;; sequence->list : sequence -> Listof(Any) -;; returns a new list containing all the elements of the sequence, in the -;; same order. -;; -;; sequence-split-at sequence integer -> sequence + sequence -;; returns two new sequences, the first containing the first N elements -;; of the sequence, the second containing the remaining elements. If N is -;; negative, it returns the empty sequence as the first argument, and the -;; original sequence as the second argument. Similarly, if N is greater -;; than the length of the list, it returns the original sequence as the -;; first argument, and the empty sequence as the second argument. -;; -;; Consequently, (let-values (((a b) (sequence-split-at s i))) -;; (sequence-append a b)) is equivalent to s for all sequences s, and -;; integers i. -;; -;; sequence-take sequence integer -> sequence -;; returns a new sequence containing the first N elements of the -;; argument sequence. If N is negative, the empty sequence is -;; returned. If N is larger than the length of the sequence, the whole -;; sequence is returned. -;; -;; sequence-drop sequence integer -> sequence -;; returns a new sequence containing all but the first N elements of the -;; argument sequence. If N is negative, the whole sequence is -;; returned. If N is larger than the length of the sequence, the empty -;; sequence is returned. -;; -;; sequence-ref : sequence non-negative-integer -> any -;; returns the element at the specified index in the sequence. If the -;; index is outside the range 0 <= i < (sequence-size sequence), an -;; assertion violation is raised. -;; -;; sequence-set : sequence non-negative-integer any -> sequence -;; returns the new sequence obtained by replacing the element at the -;; specified index in the sequence with the given value. If the index -;; is outside the range 0 <= i < (sequence-size sequence), an -;; assertion violation is raised. -;; -;; sequence-fold (any -> any -> any) any sequence -;; returns the value obtained by iterating the combiner procedure over -;; the sequence in left-to-right order. The combiner procedure takes two -;; arguments, the value of the position in the sequence, and an -;; accumulator, and its return value is used as the value of the -;; accumulator for the next call. The initial accumulator value is given -;; by the base argument. -;; -;; sequence-fold-right (any -> any -> any) any sequence -;; Like sequence-fold, but the sequence is traversed in right-to-left -;; order, rather than left-to-right. -;; -;; sequence-reverse : sequence -> sequence -;; returns a new sequence containing all the arguments of the argument -;; list, in reverse order. -;; -;; sequence-map : (any -> any) sequence -> sequence -;; returns a new sequence obtained by applying the procedure to each -;; element of the argument sequence in turn. -;; -;; sequence-filter : (any -> bool) sequence -> sequence -;; returns a new sequence containing all the elements of the argument -;; sequence for which the predicate is true. -;; -;; sequence-empty-condition? : any -> bool -;; returns #t if an object is a &sequence-empty condition, #f otherwise. -;; -(library (pfds sequences) -(export make-sequence - sequence? - sequence-empty? - sequence-size - sequence-cons - sequence-uncons - sequence-snoc - sequence-unsnoc - sequence-append - list->sequence - sequence->list - (rename (%sequence sequence)) - sequence-split-at - sequence-take - sequence-drop - sequence-ref - sequence-set - sequence-fold - sequence-fold-right - sequence-reverse - sequence-map - sequence-filter - sequence-empty-condition? - ) - -(import (rnrs) - (pfds fingertrees)) - -;; Note: as sequences are not a subtype of fingertrees, but rather a -;; particular instantiation of them, &sequence-empty is not a subtype -;; of &fingertree-empty -(define-condition-type &sequence-empty - &assertion - make-sequence-empty-condition - sequence-empty-condition?) - -(define-record-type (sequence %make-sequence sequence?) - (fields fingertree)) - -(define (make-sequence) - (%make-sequence (make-fingertree 0 + (lambda (x) 1)))) - -(define (sequence-empty? seq) - (fingertree-empty? (sequence-fingertree seq))) - -(define (sequence-size seq) - (fingertree-measure (sequence-fingertree seq))) - -(define (sequence-cons value seq) - (%make-sequence - (fingertree-cons value (sequence-fingertree seq)))) - -(define (sequence-snoc seq value) - (%make-sequence - (fingertree-snoc (sequence-fingertree seq) value))) - -(define (sequence-uncons seq) - (call-with-values - (lambda () - (define ft (sequence-fingertree seq)) - (when (fingertree-empty? ft) - (raise - (condition - (make-sequence-empty-condition) - (make-who-condition 'sequence-uncons) - (make-message-condition "There are no elements to uncons") - (make-irritants-condition (list seq))))) - (fingertree-uncons ft)) - (lambda (head tree) - (values head (%make-sequence tree))))) - -(define (sequence-unsnoc seq) - (call-with-values - (lambda () - (define ft (sequence-fingertree seq)) - (when (fingertree-empty? ft) - (raise - (condition - (make-sequence-empty-condition) - (make-who-condition 'sequence-unsnoc) - (make-message-condition "There are no elements to unsnoc") - (make-irritants-condition (list seq))))) - (fingertree-unsnoc ft)) - (lambda (tree last) - (values (%make-sequence tree) last)))) - -(define (sequence-append seq1 seq2) - (%make-sequence - (fingertree-append (sequence-fingertree seq1) - (sequence-fingertree seq2)))) - -(define (list->sequence list) - (fold-left sequence-snoc - (make-sequence) - list)) - -(define (sequence->list seq) - (fingertree->list (sequence-fingertree seq))) - -(define (%sequence . args) - (list->sequence args)) - -(define (sequence-split-at seq i) - (let-values (((l r) - (fingertree-split (lambda (x) (< i x)) - (sequence-fingertree seq)))) - (values (%make-sequence l) - (%make-sequence r)))) - -(define (sequence-take seq i) - (let-values (((head tail) - (sequence-split-at seq i))) - head)) - -(define (sequence-drop seq i) - (let-values (((head tail) - (sequence-split-at seq i))) - tail)) - -(define (sequence-ref seq i) - (define size (sequence-size seq)) - (unless (and (<= 0 i) (< i size)) - (assertion-violation 'sequence-ref "Index out of range" i)) - (let-values (((_l x _r) - (fingertree-split3 (lambda (x) (< i x)) - (sequence-fingertree seq)))) - x)) - -(define (sequence-set seq i val) - (define size (sequence-size seq)) - (unless (and (<= 0 i) (< i size)) - (assertion-violation 'sequence-set "Index out of range" i)) - (let-values (((l x r) - (fingertree-split3 (lambda (x) (< i x)) - (sequence-fingertree seq)))) - (%make-sequence - (fingertree-append l (fingertree-cons val r))))) - -(define (sequence-fold proc base seq) - (fingertree-fold proc base (sequence-fingertree seq))) - -(define (sequence-fold-right proc base seq) - (fingertree-fold-right proc base (sequence-fingertree seq))) - -(define (sequence-reverse seq) - (%make-sequence (fingertree-reverse (sequence-fingertree seq)))) - -(define (sequence-map proc seq) - (define (combine element seq) - (sequence-cons (proc element) seq)) - (sequence-fold-right combine (make-sequence) seq)) - -(define (sequence-filter pred? seq) - (define (combine element seq) - (if (pred? element) - (sequence-cons element seq) - seq)) - (sequence-fold-right combine (make-sequence) seq)) - -) - -;;; sets.sls --- Purely Functional Sets - -;; Copyright (C) 2012 Ian Price - -;; Author: Ian Price - -;; This program is free software, you can redistribute it and/or -;; modify it under the terms of the new-style BSD license. - -;; You should have received a copy of the BSD license along with this -;; program. If not, see . - -;; Documentation: -;; -;; set? : any -> boolean -;; returns #t if the object is a set, #f otherwise -;; -;; make-set : (any any -> boolean) -> set -;; returns a new empty set ordered by the < procedure -;; -;; set-member? : set any -> boolean -;; returns true if element is in the set -;; -;; set-insert : set any -> set -;; returns a new set created by inserting element into the set argument -;; -;; set-remove : set element -> set -;; returns a new set created by removing element from the set -;; -;; set-size : set -> non-negative integer -;; returns the number of elements in the set -;; -;; set boolean -;; returns #t if set1 is a proper subset of set2, #f otherwise. That -;; is, if all elements of set1 are in set2, and there is at least one -;; element of set2 not in set1. -;; -;; set<=? : set set -> boolean -;; returns #t if set1 is a subset of set2, #f otherwise, i.e. if all -;; elements of set1 are in set2. -;; -;; set=? : set set -> boolean -;; returns #t if every element of set1 is in set2, and vice versa, #f -;; otherwise. -;; -;; set>=? : set set -> boolean -;; returns #t if set2 is a subset of set1, #f otherwise. -;; -;; set>? : set set -> boolean -;; returns #t if set2 is a proper subset of set1, #f otherwise. -;; -;; subset? : set set -> boolean -;; same as set<=? -;; -;; proper-subset? : set set -> boolean -;; same as set any) set -> set -;; returns the new set created by applying proc to each element of the set -;; -;; set-fold : (any any -> any) any set -> any -;; returns the value obtained by iterating the procedure over each -;; element of the set and an accumulator value. The value of the -;; accumulator is initially base, and the return value of proc is used -;; as the accumulator for the next iteration. -;; -;; list->set : Listof(any) (any any -> any) -> set -;; returns the set containing all the elements of the list, ordered by <. -;; -;; set->list : set -> Listof(any) -;; returns all the elements of the set as a list -;; -;; set-union : set set -> set -;; returns the union of set1 and set2, i.e. contains all elements of -;; set1 and set2. -;; -;; set-intersection : set set -> set -;; returns the intersection of set1 and set2, i.e. the set of all -;; items that are in both set1 and set2. -;; -;; set-difference : set set -> set -;; returns the difference of set1 and set2, i.e. the set of all items -;; in set1 that are not in set2. -;; -;; set-ordering-procedure : set -> (any any -> boolean) -;; returns the ordering procedure used internall by the set. -(library (pfds sets) -(export set? - make-set - set-member? - set-insert - set-remove - set-size - set=? - set>? - subset? - proper-subset? - set-map - set-fold - list->set - set->list - set-union - set-intersection - set-difference - set-ordering-procedure - ) -(import (rnrs) - (pfds bbtrees)) - -(define dummy #f) - -;;; basic sets -(define-record-type (set %make-set set?) - (fields tree)) - -(define (set-ordering-procedure set) - (bbtree-ordering-procedure (set-tree set))) - -(define (make-set <) - (%make-set (make-bbtree <))) - -;; provide a (make-equal-set) function? - -(define (set-member? set element) - (bbtree-contains? (set-tree set) element)) - -(define (set-insert set element) - (%make-set (bbtree-set (set-tree set) element dummy))) - -(define (set-remove set element) - (%make-set (bbtree-delete (set-tree set) element))) - -(define (set-size set) - (bbtree-size (set-tree set))) - -;;; set equality -(define (set<=? set1 set2) - (let ((t (set-tree set2))) - (bbtree-traverse (lambda (k _ l r b) - (and (bbtree-contains? t k) - (l #t) - (r #t))) - #t - (set-tree set1)))) - -(define (set=? set1 set2) - (set<=? set2 set1)) - -(define (set>? set1 set2) - (set=? set1 set2))) - -(define subset? set<=?) - -(define proper-subset? setset list <) - (fold-left (lambda (tree element) - (set-insert tree element)) - (make-set <) - list)) - -(define (set->list set) - (set-fold cons '() set)) - -;;; set operations -(define (set-union set1 set2) - (%make-set (bbtree-union (set-tree set1) (set-tree set2)))) - -(define (set-intersection set1 set2) - (%make-set (bbtree-intersection (set-tree set1) (set-tree set2)))) - -(define (set-difference set1 set2) - (%make-set (bbtree-difference (set-tree set1) (set-tree set2)))) - -) - -;; Copyright (C) 2011-2014 Ian Price - -;; Author: Ian Price - -;; This program is free software, you can redistribute it and/or -;; modify it under the terms of the new-style BSD license. - -;; You should have received a copy of the BSD license along with this -;; program. If not, see . - -;;; Code: -(import (rnrs) - (pfds tests queues) - (pfds tests deques) - (pfds tests bbtrees) - (pfds tests sets) - (pfds tests psqs) - (pfds tests heaps) - (pfds tests fingertrees) - (pfds tests sequences) - (pfds tests hamts) - (pfds tests utils) - (wak trc-testing)) - -;; Some schemes use lazy loading of modules, and so I can't just use -;; (run-test pfds) and rely on the side effects in the other modules -;; to add them to the pfds parent suite. -(define-syntax add-tests! - (syntax-rules () - ((add-tests! suite ...) - (begin (add-test! pfds 'suite suite) ...)))) - -(add-tests! queues deques bbtrees sets psqs - heaps fingertrees sequences hamts) - -(run-test pfds) -(define-library (r7rs-extras all) - (import (r7rs-extras higher-order)) - (include-library-declarations "higher-order.exports.sld") - (import (r7rs-extras io)) - (include-library-declarations "io.exports.sld") - (import (r7rs-extras partition)) - (include-library-declarations "partition.exports.sld") - (import (r7rs-extras arithmetic)) - (include-library-declarations "arithmetic.exports.sld") - (import (r7rs-extras pushpop)) - (include-library-declarations "pushpop.exports.sld") - ) -;;; arithmetic.body.scm --- Extra arithmetic operations - -;; Copyright © 2014 Taylan Ulrich Bayırlı/Kammer -;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer - -;; Author: Taylan Ulrich Bayırlı/Kammer -;; Keywords: extensions arithmetic number - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;; Commentary: - -;; If you're desperate for performance, you might benefit from implementing the -;; euclidean variants in terms of the floor and ceiling variants for positive -;; and negative values of `y' respectively. The floor variants are in the -;; (scheme base) library and might be more efficient in your implementation. - -;; These might also otherwise have significantly more efficient implementations. -;; Let me know. - -;;; Code: - -(define-syntax define-divisions - (syntax-rules () - ((_ div div-doc quotient quotient-doc remainder remainder-doc x y - quotient-expr) - (begin - (define (div x y) - div-doc - (let* ((q quotient-expr) - (r (- x (* y quotient-expr)))) - (values q r))) - (define (quotient x y) - quotient-doc - quotient-expr) - (define (remainder x y) - remainder-doc - (- x (* y quotient-expr))))))) - -(define-divisions - euclidean/ - "Return Q and R in X = Q*Y + R where 0 <= R < |Y|." - euclidean-quotient - "Return Q in X = Q*Y + R where 0 <= R < |Y|." - euclidean-remainder - "Return R in X = Q*Y + R where 0 <= R < |Y|." - x y - (cond ((positive? y) - (floor (/ x y))) - ((negative? y) - (ceiling (/ x y))) - ((zero? y) - (error "division by zero")) - (else +nan.0))) - -(define-divisions - ceiling/ - "Return Q and R in X = Q*Y + R where Q = ceiling(X/Y)." - ceiling-quotient - "Return Q in X = Q*Y + R where Q = ceiling(X/Y)." - ceiling-remainder - "Return R in X = Q*Y + R where Q = ceiling(X/Y)." - x y - (ceiling (/ x y))) - -(define-divisions - centered/ - "Return Q and R in X = Q*Y + R where -|Y/2| <= R < |Y/2|." - centered-quotient - "Return Q in X = Q*Y + R where -|Y/2| <= R < |Y/2|." - centered-remainder - "Return R in X = Q*Y + R where -|Y/2| <= R < |Y/2|." - x y - (cond ((positive? y) - (floor (+ 1/2 (/ x y)))) - ((negative? y) - (ceiling (+ -1/2 (/ x y)))) - ((zero? y) - (error "division by zero")) - (else +nan.0))) - -(define-divisions - round/ - "Return Q and R in X = Q*Y + R where Q = round(X/Y)." - round-quotient - "Return Q in X = Q*Y + R where Q = round(X/Y)." - round-remainder - "Return R in X = Q*Y + R where Q = round(X/Y)." - x y - (round (/ x y))) - -;;; arithmetic.body.scm ends here -(export - euclidean/ - euclidean-quotient - euclidean-remainder - ceiling/ - ceiling-quotient - ceiling-remainder - centered/ - centered-quotient - centered-remainder - round/ - round-quotient - round-remainder - ) -(define-library (r7rs-extras arithmetic) - (import (scheme base)) - (include-library-declarations "arithmetic.exports.sld") - (include "arithmetic.body.scm")) -;;; higher-order.body.scm --- Auxiliary higher-oder procedures - -;; Copyright © 2014 Taylan Ulrich Bayırlı/Kammer -;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer - -;; Author: Taylan Ulrich Bayırlı/Kammer -;; Keywords: extensions higher-order - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;; Commentary: - -;; Miscellaneous higher-oder procedures for creating constant functions, -;; negating functions, etc. - -;;; Code: - -(define (const value) - "Make a nullary procedure always returning VALUE." - (lambda () value)) - -(define (negate proc) - "Make a procedure negating the application of PROC to its arguments." - (lambda x (not (apply proc x)))) - -(define (compose proc . rest) - "Functional composition; e.g. ((compose x y) a) = (x (y a))." - (if (null? rest) - proc - (let ((rest-proc (apply compose rest))) - (lambda x - (let-values ((x (apply rest-proc x))) - (apply proc x)))))) - -(define (pipeline proc . rest) - "Reverse functional composition; e.g. ((pipeline x y) a) = (y (x a))." - (if (null? rest) - proc - (let ((rest-proc (apply pipeline rest))) - (lambda x - (let-values ((x (apply proc x))) - (apply rest-proc x)))))) - -(define (identity . x) - "Returns values given to it as-is." - (apply values x)) - -(define (and=> value proc) - "If VALUE is true, call PROC on it, else return false." - (if value (proc value) value)) - -;;; higher-order.body.scm ends here -(export - const - negate - compose - pipeline - identity - and=> - ) -(define-library (r7rs-extras higher-order) - (import (scheme base)) - (include-library-declarations "higher-order.exports.sld") - (include "higher-order.body.scm")) -;;; io.body.scm --- Input/Output extensions for R7RS - -;; Copyright © 2014 Taylan Ulrich Bayırlı/Kammer -;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer - -;; Author: Taylan Ulrich Bayırlı/Kammer -;; Keywords: extensions io i/o input output input/output - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;; Commentary: - -;; R7RS leaves out some conceivable combinations of: -;; -;; [call-]with-(input|output|error)[-(from|to)]-port -;; -;; Some of these are nontrivial and annoying to redefine every time one needs -;; them. Others are actually so trivial that their body could be inlined at any -;; place of usage, but it's nevertheless distracting having to remember which -;; ones are or aren't in the base library, so we just define them all. - -;;; Code: - -(define (call-with-input-string string proc) - "Applies PROC to an input port fed with STRING." - (call-with-port (open-input-string string) proc)) - -(define (call-with-output-string proc) - "Applies PROC to a port feeding a string which is then returned." - (let ((port (open-output-string))) - (call-with-port port proc) - (get-output-string port))) - -(define-syntax with-port - (syntax-rules () - ((with-port port-param port thunk closer) - (parameterize ((port-param port)) - (call-with-values thunk - (lambda vals - (closer port) - (apply values vals))))))) - -(define (with-input-port port thunk) - "Closes PORT after calling THUNK with it as the `current-input-port'." - (with-port current-input-port port thunk close-input-port)) - -(define (with-output-port port thunk) - "Closes PORT after calling THUNK with it as the `current-output-port'." - (with-port current-output-port port thunk close-output-port)) - -(define (with-error-port port thunk) - "Closes PORT after calling THUNK with it as the `current-error-port'." - (with-port current-error-port port thunk close-output-port)) - -(define (with-input-from-port port thunk) - "Calls THUNK with PORT as the `current-input-port'. Doesn't close PORT." - (parameterize ((current-input-port port)) - (thunk))) - -(define (with-output-to-port port thunk) - "Calls THUNK with PORT as the `current-output-port'. Doesn't close PORT." - (parameterize ((current-output-port port)) - (thunk))) - -(define (with-error-to-port port thunk) - "Calls THUNK with PORT as the `current-error-port'. Doesn't close PORT." - (parameterize ((current-error-port port)) - (thunk))) - -(define (with-error-to-file file thunk) - "Calls THUNK with `current-error-port' bound to FILE." - (with-error-port (open-output-file file) thunk)) - -(define (with-input-from-string string thunk) - "Calls THUNK with `current-input-port' bound to a port fed with STRING." - (with-input-port (open-input-string string) thunk)) - -(define (with-output-to-string thunk) - "Calls THUNK with `current-output-port' bound to a port feeding a string which -is then returned." - (let ((port (open-output-string))) - (with-output-port port thunk) - (get-output-string port))) - -(define (with-error-to-string thunk) - "Calls THUNK with `current-error-port' bound to a port feeding a string which -is then returned." - (let ((port (open-output-string))) - (with-error-port port thunk) - (get-output-string port))) - -;;; io.body.scm ends here -(export - call-with-input-string - call-with-output-string - with-input-port - with-output-port - with-error-port - with-input-from-port - with-output-to-port - with-error-to-port - with-error-to-file - with-input-from-string - with-output-to-string - with-error-to-string - ) -(define-library (r7rs-extras io) - (import (scheme base) - (scheme file)) - (include-library-declarations "io.exports.sld") - (include "io.body.scm")) -;;; partition.body.scm --- Variable-arity partition procedures - -;; Copyright © 2014 Taylan Ulrich Bayırlı/Kammer -;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer - -;; Author: Taylan Ulrich Bayırlı/Kammer -;; Keywords: extensions lists partition partitioning - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;; Commentary: - -;; `partition' proper is in SRFI-1; we define alternative versions only. - -;;; Code: - -(define (%partition exclusive? list . procs) - (if (null? procs) - list - (let ((lists (make-list (+ 1 (length procs)) '()))) - (for-each - (lambda (elt) - (let loop ((procs procs) - (lists lists) - (match? #f)) - (if (null? procs) - (when (not match?) - (set-car! lists (cons elt (car lists)))) - (if ((car procs) elt) - (begin (set-car! lists (cons elt (car lists))) - (when (not exclusive?) - (loop (cdr procs) (cdr lists) #t))) - (loop (cdr procs) (cdr lists) match?))))) - list) - (apply values (map reverse lists))))) - -(define (partition* list . procs) - "Partitions LIST via PROCS, returning PROCS + 1 many lists; the last list -containing elements that didn't match any procedure. The ordering of each list -obeys that of LIST. If there are elements matching multiple PROCS, it's -unspecified in which one of the matching lists they appear." - (apply %partition #t list procs)) - -(define (partition+ list . procs) - "This is like the `partition*' procedure, but elements matching multiple -procedures appear in every corresponding list." - (apply %partition #f list procs)) - -;;; partition.body.scm ends here -(export - partition* - partition+ - ) -(define-library (r7rs-extras partition) - (import (scheme base)) - (include-library-declarations "partition.exports.sld") - (include "partition.body.scm")) -;;; pushpop.body.scm --- push! and pop! - -;; Copyright © 2014 Taylan Ulrich Bayırlı/Kammer -;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer - -;; Author: Taylan Ulrich Bayırlı/Kammer -;; Keywords: extensions push pop - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see . - -;;; Commentary: - -;; Dead simple push! and pop!. - -;;; Code: - -(define-syntax push! - (syntax-rules () - ((push! pair value) - (set! pair (cons value pair))))) - -(define-syntax pop! - (syntax-rules () - ((pop! pair) - (let ((value (car pair))) - (set! pair (cdr pair)) - value)))) - -;;; pushpop.body.scm ends here -(export - push! - pop! - ) -(define-library (r7rs-extras pushpop) - (import (scheme base)) - (include-library-declarations "pushpop.exports.sld") - (include "pushpop.body.scm")) -;;; generic-ref-set --- Generic accessor and modifier operators. - -;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer - -;; Permission is hereby granted, free of charge, to any person obtaining -;; a copy of this software and associated documentation files (the -;; "Software"), to deal in the Software without restriction, including -;; without limitation the rights to use, copy, modify, merge, publish, -;; distribute, sublicense, and/or sell copies of the Software, and to -;; permit persons to whom the Software is furnished to do so, subject to -;; the following conditions: - -;; The above copyright notice and this permission notice shall be -;; included in all copies or substantial portions of the Software. - -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE -;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION -;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION -;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -;;; Helpers - -(define-syntax push! - (syntax-rules () - ((_ ) - (set! (cons ))))) - -(define (alist->hashtable alist) - (let ((table (make-eqv-hashtable 100))) - (for-each (lambda (entry) - (hashtable-set! table (car entry) (cdr entry))) - alist) - table)) - -(define (pair-ref pair key) - (cond - ((eqv? 'car key) - (car pair)) - ((eqv? 'cdr key) - (cdr pair)) - (else - (list-ref pair key)))) - -(define (pair-set! pair key value) - (cond - ((eqv? 'car key) - (set-car! pair value)) - ((eqv? 'cdr key) - (set-cdr! pair value)) - (else - (list-set! pair key value)))) - -;;; Record inspection support - -(cond-expand - ((or (library (srfi 99)) - (library (rnrs records inspection)) - (library (r6rs records inspection))) - (cond-expand - ((not (library (srfi 99))) - (define rtd-accessor record-accessor) - (define rtd-mutator record-mutator)) - (else)) - (define (record-ref record field) - (let* ((rtd (record-rtd record)) - (accessor (rtd-accessor rtd field))) - (accessor record))) - (define (record-set! record field value) - (let* ((rtd (record-rtd record)) - (mutator (rtd-mutator rtd field))) - (mutator record value))) - (define record-getter - (list (cons record? record-ref))) - (define record-setter - (list (cons record? record-set!))) - (define record-type - (list record?))) - (else - (define record-getter '()) - (define record-setter '()) - (define record-type '()))) - -;;; SRFI-4 support - -;;; In some implementations, SRFI-4 vectors are also bytevectors. We accomodate -;;; for those implementations by using generic bytevector-ref/set! procedures -;;; which possibly dispatch to an SRFI-4 type's getter/setter, but also -;;; inserting the SRFI-4 getters/setters into the top-level dispatch tables. - -(cond-expand - ((library (srfi 4)) - (define srfi-4-getters - (list (cons s8vector? s8vector-ref) - (cons u8vector? u8vector-ref) - (cons s16vector? s16vector-ref) - (cons u16vector? u16vector-ref) - (cons s32vector? s32vector-ref) - (cons u32vector? u32vector-ref) - (cons s64vector? s64vector-ref) - (cons u64vector? u64vector-ref))) - (define srfi-4-setters - (list (cons s8vector? s8vector-set!) - (cons u8vector? u8vector-set!) - (cons s16vector? s16vector-set!) - (cons u16vector? u16vector-set!) - (cons s32vector? s32vector-set!) - (cons u32vector? u32vector-set!) - (cons s64vector? s64vector-set!) - (cons u64vector? u64vector-set!))) - (define srfi-4-types - (list s8vector? u8vector? s16vector? u16vector? s32vector? u32vector? - s64vector? u64vector?)) - (define srfi-4-getters-table (alist->hashtable srfi-4-getters)) - (define srfi-4-setters-table (alist->hashtable srfi-4-setters)) - (define (bytevector-ref bytevector index) - (let* ((type (find (lambda (pred) (pred bytevector))) srfi-4-types) - (getter (if type - (ref srfi-4-getters-table type) - bytevector-u8-ref))) - (getter bytevector index))) - (define (bytevector-set! bytevector index value) - (let* ((type (find (lambda (pred) (pred bytevector))) srfi-4-types) - (setter (if type - (ref srfi-4-setters-table type) - bytevector-u8-set!))) - (setter bytevector index value)))) - (else - (define srfi-4-getters '()) - (define srfi-4-setters '()) - (define srfi-4-types '()) - (define bytevector-ref bytevector-u8-ref) - (define bytevector-set! bytevector-u8-set!))) - -;;; SRFI-111 boxes support - -(cond-expand - ((library (srfi 111)) - (define (box-ref box _field) - (unbox box)) - (define (box-set! box _field value) - (set-box! box value)) - (define box-getter (list (cons box? box-ref))) - (define box-setter (list (cons box? box-set!))) - (define box-type (list box?))) - (else - (define box-getter '()) - (define box-setter '()) - (define box-type '()))) - -;;; Main - -(define %ref - (case-lambda - ((object field) - (let ((getter (lookup-getter object)) - (sparse? (sparse-type? object))) - (if sparse? - (let* ((not-found (cons #f #f)) - (result (getter object field not-found))) - (if (eqv? result not-found) - (error "Object has no entry for field." object field) - result)) - (getter object field)))) - ((object field default) - (let ((getter (lookup-getter object))) - (getter object field default))))) - -(define (%ref* object field . fields) - (if (null? fields) - (%ref object field) - (apply %ref* (%ref object field) fields))) - -(define (%set! object field value) - (let ((setter (lookup-setter object))) - (setter object field value))) - -(define ref - (getter-with-setter - %ref - (lambda (object field value) - (%set! object field value)))) - -(define ref* - (getter-with-setter - %ref* - (rec (set!* object field rest0 . rest) - (if (null? rest) - (%set! object field rest0) - (apply set!* (ref object field) rest0 rest))))) - -(define ~ ref*) - -(define $bracket-apply$ ref*) - -(define (lookup-getter object) - (or (hashtable-ref getter-table (type-of object) #f) - (error "No generic getter for object's type." object))) - -(define (lookup-setter object) - (or (hashtable-ref setter-table (type-of object) #f) - (error "No generic setter for object's type." object))) - -(define (sparse-type? object) - (memv (type-of object) sparse-types)) - -(define (type-of object) - (find (lambda (pred) (pred object)) type-list)) - -(define getter-table - (alist->hashtable - (append - (list (cons bytevector? bytevector-ref) - (cons hashtable? hashtable-ref) - (cons pair? pair-ref) - (cons string? string-ref) - (cons vector? vector-ref)) - record-getter - srfi-4-getters - box-getter))) - -(define setter-table - (alist->hashtable - (append - (list (cons bytevector? bytevector-set!) - (cons hashtable? hashtable-set!) - (cons pair? pair-set!) - (cons string? string-set!) - (cons vector? vector-set!)) - record-setter - srfi-4-setters - box-setter))) - -(define sparse-types - (list hashtable?)) - -(define type-list - ;; Although the whole SRFI intrinsically neglects performance, we still use - ;; the micro-optimization of ordering this list roughly according to most - ;; likely match. - (append - (list hashtable? vector? pair? bytevector? string?) - srfi-4-types - box-type - ;; The record type must be placed last so specific record types (e.g. box) - ;; take precedence. - record-type - ;; Place those types we don't support really last. - (list boolean? char? eof-object? null? number? port? procedure? symbol?))) - -(define (register-getter-with-setter! type getter sparse?) - (push! type-list type) - (set! (~ getter-table type) getter) - (set! (~ setter-table type) (setter getter)) - (when sparse? - (push! sparse-types type))) - -(cond-expand - ((not (or (library (srfi 99)) - (library (rnrs records inspection)) - (library (r6rs records inspection)))) - (define-syntax define-record-type - (syntax-rules () - ((_ ...) - (begin - (%define-record-type ...) - ;; Throw-away definition to not disturb an internal definitions - ;; sequence. - (define __throwaway - (begin - (register-getter-with-setter! - - (getter-with-setter (record-getter ...) - (record-setter ...)) - #f) - ;; Return the implementation's preferred "unspecified" value. - (if #f #f))))))) - - (define-syntax record-getter - (syntax-rules () - ((_ ( . ) ...) - (let ((getters (alist->hashtable (list (cons ' ) ...)))) - (lambda (record field) - (let ((getter (or (ref getters field #f) - (error "No such field of record." record field)))) - (getter record))))))) - - (define-syntax record-setter - (syntax-rules () - ((_ . ) - (%record-setter () . )))) - - (define-syntax %record-setter - (syntax-rules () - ((_ ( ) . ) - (%record-setter . )) - ((_ ( ) . ) - (%record-setter (( ) . ) . )) - ((_ (( ) ...)) - (let ((setters (alist->hashtable (list (cons ' ) ...)))) - (lambda (record field value) - (let ((setter (or (ref setters field #f) - (error "No such assignable field of record." - record field)))) - (setter record value))))))))) - -;;; generic-ref-set.body.scm ends here -(define-library (srfi 123) - (export - ref ref* ~ register-getter-with-setter! - $bracket-apply$ - set! setter getter-with-setter) - (import - (except (scheme base) set! define-record-type) - (scheme case-lambda) - (r6rs hashtables) - (srfi 1) - (srfi 17) - (srfi 31)) - (cond-expand - ;; Favor SRFI-99. - ((library (srfi 99)) - (import (srfi 99))) - ;; We assume that if there's the inspection library, there's also the - ;; syntactic and procedural libraries. - ((library (rnrs records inspection)) - (import (rnrs records syntactic)) - (import (rnrs records procedural)) - (import (rnrs records inspection))) - ((library (r6rs records inspection)) - (import (r6rs records syntactic)) - (import (r6rs records procedural)) - (import (r6rs records inspection))) - (else - (import (rename (only (scheme base) define-record-type) - (define-record-type %define-record-type))) - (export define-record-type))) - (cond-expand - ((library (srfi 4)) - (import (srfi 4))) - (else)) - (cond-expand - ((library (srfi 111)) - (import (srfi 111))) - (else)) - (include "123.body.scm")) -;;; generic-ref-set --- Generic accessor and modifier operators. - -;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer - -;; Permission is hereby granted, free of charge, to any person obtaining -;; a copy of this software and associated documentation files (the -;; "Software"), to deal in the Software without restriction, including -;; without limitation the rights to use, copy, modify, merge, publish, -;; distribute, sublicense, and/or sell copies of the Software, and to -;; permit persons to whom the Software is furnished to do so, subject to -;; the following conditions: - -;; The above copyright notice and this permission notice shall be -;; included in all copies or substantial portions of the Software. - -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE -;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION -;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION -;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -(define-library (tests srfi-123) - (export run-tests) - (import (except (scheme base) define-record-type set!) - (r6rs hashtables) - (srfi 64) - (srfi 123)) - (cond-expand - ((library (srfi 99)) - (import (srfi 99))) - ((library (rnrs records inspection)) - (import (rnrs records syntactic)) - (import (rnrs records procedural))) - (import (rnrs records inspection)) - ((library (r6rs records inspection)) - (import (r6rs records syntactic)) - (import (r6rs records procedural))) - (import (r6rs records inspection)) - (else)) - (cond-expand - ((library (srfi 4)) - (import (srfi 4))) - (else - (begin - ;; Stub to silence compilers. - (define s16vector #f)))) - (cond-expand - ((library (srfi 111)) - (import (srfi 111))) - (else - (begin - ;; Stub to silence compilers. - (define box #f)))) - (begin - - (define-record-type (make-foo a b) foo? - (a foo-a set-foo-a!) - (b foo-b)) - - ;; The SRFI-99 sample implementation contains a bug where immutable fields - ;; are nevertheless mutable through the procedural API. Test whether we are - ;; on that implementation. - (cond-expand - ((library (srfi 99)) - (define using-broken-srfi99 - (guard (err (else #f)) - (rtd-mutator 'b)))) - (else - (define using-broken-srfi99 #f))) - - (define (run-tests) - (let ((runner (test-runner-create))) - (parameterize ((test-runner-current runner)) - (test-begin "SRFI-123") - - (test-begin "ref") - (test-assert "bytevector" (= 1 (ref (bytevector 0 1 2) 1))) - (test-assert "hashtable" (let ((table (make-eqv-hashtable))) - (hashtable-set! table 'foo 0) - (= 0 (ref table 'foo)))) - (test-assert "hashtable default" (let ((table (make-eqv-hashtable))) - (= 1 (ref table 0 1)))) - (test-assert "pair" (= 1 (ref (cons 0 1) 'cdr))) - (test-assert "list" (= 1 (ref (list 0 1 2) 1))) - (test-assert "string" (char=? #\b (ref "abc" 1))) - (test-assert "vector" (= 1 (ref (vector 0 1 2) 1))) - (test-assert "record" (= 1 (ref (make-foo 0 1) 'b))) - (cond-expand - ((library (srfi 4)) (values)) - (else (test-skip 1))) - (test-assert "srfi-4" (= 1 (ref (s16vector 0 1 2) 1))) - (cond-expand - ((library (srfi 111)) (values)) - (else (test-skip 1))) - (test-assert "srfi-111" (= 1 (ref (box 1) '*))) - (test-end "ref") - - (test-assert "ref*" (= 1 (ref* '(_ #(_ (0 . 1) _) _) 1 1 'cdr))) - - (test-begin "ref setter") - (test-assert "bytevector" (let ((bv (bytevector 0 1 2))) - (set! (ref bv 1) 3) - (= 3 (ref bv 1)))) - (test-assert "hashtable" (let ((ht (make-eqv-hashtable))) - (set! (ref ht 'foo) 0) - (= 0 (ref ht 'foo)))) - (test-assert "pair" (let ((p (cons 0 1))) - (set! (ref p 'cdr) 2) - (= 2 (ref p 'cdr)))) - (test-assert "list" (let ((l (list 0 1 2))) - (set! (ref l 1) 3) - (= 3 (ref l 1)))) - (test-assert "string" (let ((s (string #\a #\b #\c))) - (set! (ref s 1) #\d) - (char=? #\d (ref s 1)))) - (test-assert "vector" (let ((v (vector 0 1 2))) - (set! (ref v 1) 3) - (= 3 (ref v 1)))) - (test-assert "record" (let ((r (make-foo 0 1))) - (set! (ref r 'a) 2) - (= 2 (ref r 'a)))) - (when using-broken-srfi99 - (test-expect-fail 1)) - (test-assert "bad record assignment" - (not (guard (err (else #f)) (set! (ref (make-foo 0 1) 'b) 2) #t))) - (cond-expand - ((library (srfi 4)) (values)) - (else (test-skip 1))) - (test-assert "srfi-4" (let ((s16v (s16vector 0 1 2))) - (set! (ref s16v 1) 3) - (= 3 (ref s16v 1)))) - (cond-expand - ((library (srfi 111)) (values)) - (else (test-skip 1))) - (test-assert "srfi-111" (let ((b (box 0))) - (set! (ref b '*) 1) - (= 1 (ref b '*)))) - (test-end "ref setter") - - (test-assert "ref* setter" - (let ((obj (list '_ (vector '_ (cons 0 1) '_) '_))) - (set! (ref* obj 1 1 'cdr) 2) - (= 2 (ref* obj 1 1 'cdr)))) - - (test-end "SRFI-123") - (and (= 0 (test-runner-xpass-count runner)) - (= 0 (test-runner-fail-count runner)))))) - - )) -(import (scheme base) - (scheme eval) - (scheme process-context)) - -(if (eval '(run-tests) (environment '(tests srfi-123))) - (exit 0) - (exit 1)) -;;; Copyright 2015 William D Clinger. -;;; -;;; Permission to copy this software, in whole or in part, to use this -;;; software for any lawful purpose, and to redistribute this software -;;; is granted subject to the restriction that all copies made of this -;;; software must include this copyright and permission notice in full. -;;; -;;; I also request that you send me a copy of any improvements that you -;;; make to this software so that they may be incorporated within it to -;;; the benefit of the Scheme community. -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This R7RS code implements (rnrs hashtables) on top of SRFI 69. - -;;; Private stuff. - -;;; Although SRFI 69 is mostly written as though hash functions take -;;; just one argument, its reference implementation routinely passes -;;; a second argument to hash functions, and that arguably incorrect -;;; behavior has undoubtedly found its way into many implementations -;;; of SRFI 69. -;;; -;;; A unary hash function passed to R6RS make-hashtable is therefore -;;; unlikely to work when passed to SRFI 69 make-hash-table. We need -;;; to convert the unary hash function so it will accept a second -;;; optional argument, and we also need to arrange for the original -;;; unary hash function to be returned by hashtable-hash-function. -;;; -;;; We'd like to accomplish this while preserving interoperability -;;; between R6RS hashtables and SRFI 69 hash tables. That argues -;;; against implementing R6RS hashtables by records that encapsulate -;;; a SRFI 69 hash table, which would otherwise be the easy way to -;;; go about this. -;;; -;;; This association list implements a bidirectional mapping between -;;; one-argument hash functions of R6RS and their representations as -;;; two-argument hash functions that will work with SRFI 69. - -(define table-of-hash-functions '()) - -;;; Given a unary hash function, returns a hash function that will -;;; be acceptable to SRFI 69. - -(define (make-srfi-69-hash-function hash-function) - (lambda (x . rest) - (if (null? rest) - (hash-function x) - (modulo (hash-function x) (car rest))))) - -(define (r6rs->srfi69 hash-function) - (let ((probe (assoc hash-function table-of-hash-functions))) - (if probe - (cdr probe) - (let ((hasher (make-srfi-69-hash-function hash-function))) - (set! table-of-hash-functions - (cons (cons hash-function hasher) - table-of-hash-functions)) - hasher)))) - -(define (srfi69->r6rs hasher) - (define (loop table) - (cond ((null? table) - hasher) - ((equal? hasher (cdr (car table))) - (car (car table))) - (else - (loop (cdr table))))) - (loop table-of-hash-functions)) - -;;; SRFI 69 doesn't define a hash function that's suitable for use -;;; with the eqv? predicate, and we need one for make-eqv-hashtable. -;;; -;;; The R7RS eqv? predicate behaves the same as eq? for these types: -;;; -;;; symbols -;;; booleans -;;; empty list -;;; pairs -;;; records -;;; non-empty strings -;;; non-empty vectors -;;; non-empty bytevectors -;;; -;;; eqv? might behave differently when its arguments are: -;;; -;;; procedures that behave the same but have equal location tags -;;; numbers -;;; characters -;;; empty strings -;;; empty vectors -;;; empty bytevectors -;;; -;;; If eqv? and eq? behave differently on two arguments x and y, -;;; eqv? returns true and eq? returns false. -;;; -;;; FIXME: There is no portable way to define a good hash function -;;; that's compatible with eqv? on procedures and also runs in -;;; constant time. This one is compatible with eqv? and runs in -;;; constant time (on procedures), but isn't any good. - -;;; The main thing these numerical constants have in common is that -;;; they're positive and fit in 24 bits. - -(define hash:procedure 9445898) -(define hash:character 13048478) -(define hash:empty-string 14079236) -(define hash:empty-vector 1288342) -(define hash:empty-bytevector 11753202) -(define hash:inexact 1134643) -(define hash:infinity+ 2725891) -(define hash:infinity- 5984233) -(define hash:nan 7537847) -(define hash:complex 9999245) - -(define (hash-for-eqv x) - (cond ((procedure? x) - hash:procedure) - ((number? x) - (cond ((exact-integer? x) - x) - ((not (real? x)) - (+ hash:complex (complex-hash x))) - ((exact? x) - (+ (numerator x) (denominator x))) - (else - (+ hash:inexact (inexact-hash x))))) - ((char? x) - (+ hash:character (char->integer x))) - ((eqv? x "") - hash:empty-string) - ((eqv? x '#()) - hash:empty-vector) - ((eqv? x '#u8()) - hash:empty-bytevector) - (else - (hash-by-identity x)))) - -;;; The R6RS distinguishes mutable from immutable hashtables, -;;; so we have to keep track of that somehow. Here we remember -;;; all of the immutable hashtables within a SRFI 69 hash-table. -;;; -;;; FIXME: That means the storage occupied by an immutable -;;; hashtable won't be reclaimed if it becomes otherwise -;;; inaccessible. - -(define immutable-hashtables - (make-hash-table eqv? (r6rs->srfi69 hash-table-size))) - -(define (complain-if-immutable ht complainant) - (if (hash-table-ref/default immutable-hashtables ht #f) - (error (string-append (symbol->string complainant) - ": hashtable is immutable") - ht))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Exported procedures. -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; The R6RS make-eq-hashtable procedure is normally called with -;;; no arguments, but an optional argument specifies the initial -;;; capacity of the table. That optional argument, if present, -;;; will be ignored by this implementation because it has no -;;; counterpart in SRFI 69. - -(define (make-eq-hashtable . rest) - (make-hash-table eq? hash-by-identity)) - -(define (make-eqv-hashtable . rest) - (make-hash-table eqv? (r6rs->srfi69 hash-for-eqv))) - -;;; As with make-eq-hashtable and make-eqv-hashtable, the optional -;;; initial capacity will be ignored. - -(define (make-hashtable hash-function equiv . rest) - (make-hash-table equiv (r6rs->srfi69 hash-function))) - -(define (hashtable? x) - (hash-table? x)) - -(define (hashtable-size ht) - (hash-table-size ht)) - -(define (hashtable-ref ht key default) - (hash-table-ref/default ht key default)) - -(define (hashtable-set! ht key obj) - (complain-if-immutable ht 'hashtable-set!) - (hash-table-set! ht key obj)) - -(define (hashtable-delete! ht key) - (complain-if-immutable ht 'hashtable-delete!) - (hash-table-delete! ht key)) - -(define (hashtable-contains? ht key) - (hash-table-exists? ht key)) - -(define (hashtable-update! ht key proc default) - (complain-if-immutable ht 'hashtable-update!) - (hash-table-set! ht - key - (proc (hash-table-ref/default ht key default)))) - -;;; By default, hashtable-copy returns an immutable hashtable. -;;; The copy is mutable only if a second argument is passed and -;;; that second argument is true. - -(define (hashtable-copy ht . rest) - (let ((mutable? (and (pair? rest) (car rest))) - (the-copy (hash-table-copy ht))) - (if (not mutable?) - (hash-table-set! immutable-hashtables the-copy #t)) - the-copy)) - -;;; As usual, the optional "initial" capacity is ignored. - -(define (hashtable-clear! ht . rest) - (complain-if-immutable ht 'hashtable-update!) - (hash-table-walk ht - (lambda (key value) - (hash-table-delete! ht key)))) - -(define (hashtable-keys ht) - (list->vector (hash-table-keys ht))) - -(define (hashtable-entries ht) - (let* ((keys (hashtable-keys ht)) - (vals (vector-map (lambda (key) - (hash-table-ref ht key)) - keys))) - (values keys vals))) - -(define (hashtable-equivalence-function ht) - (hash-table-equivalence-function ht)) - -(define (hashtable-hash-function ht) - (srfi69->r6rs (hash-table-hash-function ht))) - -(define (hashtable-mutable? ht) - (not (hash-table-ref/default immutable-hashtables ht #f))) - -(define (equal-hash obj) - (hash obj)) - -;;; string-hash is exported by SRFI 69. -;;; string-ci-hash is exported by SRFI 69. - -(define (r6rs:symbol-hash sym) - (hash-by-identity sym)) - -;;; Reference implementation of SRFI 69, from -;;; http://srfi.schemers.org/srfi-69/srfi-69.html - -;;; Copyright © Panu Kalliokoski (2005). All Rights Reserved. -;;; Permission is hereby granted, free of charge, to any person -;;; obtaining a copy of this software and associated documentation -;;; files (the "Software"), to deal in the Software without -;;; restriction, including without limitation the rights to use, -;;; copy, modify, merge, publish, distribute, sublicense, and/or -;;; sell copies of the Software, and to permit persons to whom -;;; the Software is furnished to do so, subject to the following -;;; conditions: -;;; -;;; The above copyright notice and this permission notice shall -;;; be included in all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY -;;; KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE -;;; WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR -;;; PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS -;;; OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR -;;; OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR -;;; OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE -;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -;;; Modification history: -;;; -;;; In May 2015, William D Clinger modified this code for use in -;;; R7RS systems, mainly so it could be used as a last resort in -;;; the (r6rs hashtables) approximation to (rnrs hashtables). -;;; -;;; string-ci-hash was changed to use R7RS string-foldcase -;;; -;;; string-hash, symbol-hash, and %string-hash were changed -;;; to eliminate a now-useless procedure call for each character -;;; -;;; whitespace was adjusted because it got messed up during -;;; conversion from HTML to Scheme code - -(define *default-bound* (- (expt 2 29) 3)) - -(define (%string-hash s bound) - (let ((hash 31) - (len (string-length s))) - (do ((index 0 (+ index 1))) - ((>= index len) (modulo hash bound)) - (set! hash (modulo (+ (* 37 hash) - (char->integer (string-ref s index))) - *default-bound*))))) - -(define (string-hash s . maybe-bound) - (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound)))) - (%string-hash s bound))) - -(define (string-ci-hash s . maybe-bound) - (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound)))) - (%string-hash (string-foldcase s) bound))) - -(define (symbol-hash s . maybe-bound) - (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound)))) - (%string-hash (symbol->string s) bound))) - -(define (hash obj . maybe-bound) - (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound)))) - (cond ((integer? obj) (modulo obj bound)) - ((string? obj) (string-hash obj bound)) - ((symbol? obj) (symbol-hash obj bound)) - ((real? obj) (modulo (+ (numerator obj) (denominator obj)) bound)) - ((number? obj) - (modulo (+ (hash (real-part obj)) (* 3 (hash (imag-part obj)))) - bound)) - ((char? obj) (modulo (char->integer obj) bound)) - ((vector? obj) (vector-hash obj bound)) - ((pair? obj) (modulo (+ (hash (car obj)) (* 3 (hash (cdr obj)))) - bound)) - ((null? obj) 0) - ((not obj) 0) - ((procedure? obj) (error "hash: procedures cannot be hashed" obj)) - (else 1)))) - -(define hash-by-identity hash) - -(define (vector-hash v bound) - (let ((hashvalue 571) - (len (vector-length v))) - (do ((index 0 (+ index 1))) - ((>= index len) (modulo hashvalue bound)) - (set! hashvalue (modulo (+ (* 257 hashvalue) (hash (vector-ref v index))) - *default-bound*))))) - -(define %make-hash-node cons) -(define %hash-node-set-value! set-cdr!) -(define %hash-node-key car) -(define %hash-node-value cdr) - -(define-record-type - (%make-hash-table size hash compare associate entries) - hash-table? - (size hash-table-size hash-table-set-size!) - (hash hash-table-hash-function) - (compare hash-table-equivalence-function) - (associate hash-table-association-function) - (entries hash-table-entries hash-table-set-entries!)) - -(define *default-table-size* 64) - -(define (appropriate-hash-function-for comparison) - (or (and (eq? comparison eq?) hash-by-identity) - (and (eq? comparison string=?) string-hash) - (and (eq? comparison string-ci=?) string-ci-hash) - hash)) - -(define (make-hash-table . args) - (let* ((comparison (if (null? args) equal? (car args))) - (hash - (if (or (null? args) (null? (cdr args))) - (appropriate-hash-function-for comparison) (cadr args))) - (size - (if (or (null? args) (null? (cdr args)) (null? (cddr args))) - *default-table-size* (caddr args))) - (association - (or (and (eq? comparison eq?) assq) - (and (eq? comparison eqv?) assv) - (and (eq? comparison equal?) assoc) - (letrec - ((associate - (lambda (val alist) - (cond ((null? alist) #f) - ((comparison val (caar alist)) (car alist)) - (else (associate val (cdr alist))))))) - associate)))) - (%make-hash-table 0 hash comparison association (make-vector size '())))) - -(define (make-hash-table-maker comp hash) - (lambda args (apply make-hash-table (cons comp (cons hash args))))) -(define make-symbol-hash-table - (make-hash-table-maker eq? symbol-hash)) -(define make-string-hash-table - (make-hash-table-maker string=? string-hash)) -(define make-string-ci-hash-table - (make-hash-table-maker string-ci=? string-ci-hash)) -(define make-integer-hash-table - (make-hash-table-maker = modulo)) - -(define (%hash-table-hash hash-table key) - ((hash-table-hash-function hash-table) - key (vector-length (hash-table-entries hash-table)))) - -(define (%hash-table-find entries associate hash key) - (associate key (vector-ref entries hash))) - -(define (%hash-table-add! entries hash key value) - (vector-set! entries hash - (cons (%make-hash-node key value) - (vector-ref entries hash)))) - -(define (%hash-table-delete! entries compare hash key) - (let ((entrylist (vector-ref entries hash))) - (cond ((null? entrylist) #f) - ((compare key (caar entrylist)) - (vector-set! entries hash (cdr entrylist)) #t) - (else - (let loop ((current (cdr entrylist)) (previous entrylist)) - (cond ((null? current) #f) - ((compare key (caar current)) - (set-cdr! previous (cdr current)) #t) - (else (loop (cdr current) current)))))))) - -(define (%hash-table-walk proc entries) - (do ((index (- (vector-length entries) 1) (- index 1))) - ((< index 0)) (for-each proc (vector-ref entries index)))) - -(define (%hash-table-maybe-resize! hash-table) - (let* ((old-entries (hash-table-entries hash-table)) - (hash-length (vector-length old-entries))) - (if (> (hash-table-size hash-table) hash-length) - (let* ((new-length (* 2 hash-length)) - (new-entries (make-vector new-length '())) - (hash (hash-table-hash-function hash-table))) - (%hash-table-walk - (lambda (node) - (%hash-table-add! new-entries - (hash (%hash-node-key node) new-length) - (%hash-node-key node) (%hash-node-value node))) - old-entries) - (hash-table-set-entries! hash-table new-entries))))) - -(define (hash-table-ref hash-table key . maybe-default) - (cond ((%hash-table-find (hash-table-entries hash-table) - (hash-table-association-function hash-table) - (%hash-table-hash hash-table key) key) - => %hash-node-value) - ((null? maybe-default) - (error "hash-table-ref: no value associated with" key)) - (else ((car maybe-default))))) - -(define (hash-table-ref/default hash-table key default) - (hash-table-ref hash-table key (lambda () default))) - -(define (hash-table-set! hash-table key value) - (let ((hash (%hash-table-hash hash-table key)) - (entries (hash-table-entries hash-table))) - (cond ((%hash-table-find entries - (hash-table-association-function hash-table) - hash key) - => (lambda (node) (%hash-node-set-value! node value))) - (else (%hash-table-add! entries hash key value) - (hash-table-set-size! hash-table - (+ 1 (hash-table-size hash-table))) - (%hash-table-maybe-resize! hash-table))))) - -(define (hash-table-update! hash-table key function . maybe-default) - (let ((hash (%hash-table-hash hash-table key)) - (entries (hash-table-entries hash-table))) - (cond ((%hash-table-find entries - (hash-table-association-function hash-table) - hash key) - => (lambda (node) - (%hash-node-set-value! - node (function (%hash-node-value node))))) - ((null? maybe-default) - (error "hash-table-update!: no value exists for key" key)) - (else (%hash-table-add! entries hash key - (function ((car maybe-default)))) - (hash-table-set-size! hash-table - (+ 1 (hash-table-size hash-table))) - (%hash-table-maybe-resize! hash-table))))) - -(define (hash-table-update!/default hash-table key function default) - (hash-table-update! hash-table key function (lambda () default))) - -(define (hash-table-delete! hash-table key) - (if (%hash-table-delete! (hash-table-entries hash-table) - (hash-table-equivalence-function hash-table) - (%hash-table-hash hash-table key) key) - (hash-table-set-size! hash-table (- (hash-table-size hash-table) 1)))) - -(define (hash-table-exists? hash-table key) - (and (%hash-table-find (hash-table-entries hash-table) - (hash-table-association-function hash-table) - (%hash-table-hash hash-table key) key) #t)) - -(define (hash-table-walk hash-table proc) - (%hash-table-walk - (lambda (node) (proc (%hash-node-key node) (%hash-node-value node))) - (hash-table-entries hash-table))) - -(define (hash-table-fold hash-table f acc) - (hash-table-walk hash-table - (lambda (key value) (set! acc (f key value acc)))) - acc) - -(define (alist->hash-table alist . args) - (let* ((comparison (if (null? args) equal? (car args))) - (hash - (if (or (null? args) (null? (cdr args))) - (appropriate-hash-function-for comparison) (cadr args))) - (size - (if (or (null? args) (null? (cdr args)) (null? (cddr args))) - (max *default-table-size* (* 2 (length alist))) (caddr args))) - (hash-table (make-hash-table comparison hash size))) - (for-each - (lambda (elem) - (hash-table-update!/default - hash-table (car elem) (lambda (x) x) (cdr elem))) - alist) - hash-table)) - -(define (hash-table->alist hash-table) - (hash-table-fold hash-table - (lambda (key val acc) (cons (cons key val) acc)) '())) - -(define (hash-table-copy hash-table) - (let ((new (make-hash-table (hash-table-equivalence-function hash-table) - (hash-table-hash-function hash-table) - (max *default-table-size* - (* 2 (hash-table-size hash-table)))))) - (hash-table-walk hash-table - (lambda (key value) (hash-table-set! new key value))) - new)) - -(define (hash-table-merge! hash-table1 hash-table2) - (hash-table-walk - hash-table2 - (lambda (key value) (hash-table-set! hash-table1 key value))) - hash-table1) - -(define (hash-table-keys hash-table) - (hash-table-fold hash-table (lambda (key val acc) (cons key acc)) '())) - -(define (hash-table-values hash-table) - (hash-table-fold hash-table (lambda (key val acc) (cons val acc)) '())) - -; eof -;; Copyright 1991, 1994, 1998 William D Clinger -;; Copyright 1998 Lars T Hansen -;; Copyright 1984 - 1993 Lightship Software, Incorporated - -;; Permission to copy this software, in whole or in part, to use this -;; software for any lawful purpose, and to redistribute this software -;; is granted subject to the following restriction: Any publication -;; or redistribution of this software, whether on its own or -;; incorporated into other software, must bear the above copyright -;; notices and the following legend: - -;; The Twobit compiler and the Larceny runtime system were -;; developed by William Clinger and Lars Hansen with the -;; assistance of Lightship Software and the College of Computer -;; Science of Northeastern University. This acknowledges that -;; Clinger et al remain the sole copyright holders to Twobit -;; and Larceny and that no rights pursuant to that status are -;; waived or conveyed. - -;; Twobit and Larceny are provided as is. The user specifically -;; acknowledges that Northeastern University, William Clinger, Lars -;; Hansen, and Lightship Software have not made any representations -;; or warranty with regard to performance of Twobit and Larceny, -;; their merchantability, or fitness for a particular purpose. Users -;; further acknowledge that they have had the opportunity to inspect -;; Twobit and Larceny and will hold harmless Northeastern University, -;; William Clinger, Lars Hansen, and Lightship Software from any cost, -;; liability, or expense arising from, or in any way related to the -;; use of this software. - -(define-library (r6rs hashtables) - - (export - - make-eq-hashtable - make-eqv-hashtable - make-hashtable - hashtable? - hashtable-size - hashtable-ref - hashtable-set! - hashtable-delete! - hashtable-contains? - hashtable-update! - hashtable-copy - hashtable-clear! - hashtable-keys - hashtable-entries - hashtable-equivalence-function - hashtable-hash-function - hashtable-mutable? - equal-hash - string-hash - string-ci-hash - (rename r6rs:symbol-hash symbol-hash) ; see explanation below - ) - - (import (scheme base) - (scheme cxr)) - - ;; Hashing on inexact and complex numbers depends on whether the - ;; (scheme inexact) and (scheme complex) libraries are available. - - (cond-expand - - ((library (rnrs hashtables))) ; nothing to do - - ((library (scheme inexact)) - (import (scheme inexact)) - (begin - (define (inexact-hash x) - (cond ((finite? x) - (hash-for-eqv (exact x))) - ((infinite? x) - (if (> x 0.0) - hash:infinity+ - hash:infinity-)) - (else - hash:nan))))) - - (else - (begin - (define (inexact-hash x) 0)))) - - (cond-expand - - ((and (library (rnrs hashtables)) - (not (library (r6rs no-rnrs)))) - ;; nothing to do - ) - - ((library (scheme complex)) - (import (scheme complex)) - (begin - (define (complex-hash z) - (+ (hash-for-eqv (real-part z)) - (hash-for-eqv (imag-part z)))))) - - (else - (begin - (define (complex-hash z) 0)))) - - ;; If the (rnrs hashtables) library is available, import it. - ;; Otherwise use SRFI 69 if it's available. - ;; If SRFI 69 isn't available, use its reference implementation. - ;; - ;; The (r6rs hashtables) library must export symbol-hash, which - ;; has no equivalent among the procedures specified by SRFI 69. - ;; The SRFI 69 reference implementation does define symbol-hash, - ;; however, which has led to the current situation in which some - ;; implementations of (srfi 69) export symbol-hash but others - ;; don't. The R7RS says it's an error to import symbol-hash - ;; more than once with different bindings, or to redefine it - ;; if it's been imported, so this (r6rs hashtables) library - ;; defines r6rs:symbol-hash and renames it to symbol-hash only - ;; when it's exported. - - (cond-expand - - ((and (library (rnrs hashtables)) - (not (library (r6rs no-rnrs)))) - (import (rnrs hashtables)) - (begin (define r6rs:symbol-hash symbol-hash))) - - ((library (srfi 69 basic-hash-tables)) - (import (srfi 69 basic-hash-tables)) - (include "hashtables.atop69.scm")) - - ((library (srfi 69)) - (import (srfi 69)) - (include "hashtables.atop69.scm")) - - ((library (srfi 69 basic-hash-tables)) - (import (srfi 69 basic-hash-tables)) - (include "hashtables.atop69.scm")) - - ((library (srfi 69)) - (import (srfi 69)) - (include "hashtables.atop69.scm")) - - ((library (scheme char)) - (import (scheme char)) - (include "hashtables.body69.scm") - (include "hashtables.atop69.scm")) - - (else - (begin (define (string-foldcase s) s) - (define (string-ci=? s1 s2) - (string=? s1 s2))) - (include "hashtables.body69.scm") - (include "hashtables.atop69.scm"))) - - ) -(define make-eq-hashtable - (case-lambda - (() (make-eq-hashtable #f #f)) - ((capacity) (make-eq-hashtable capacity #f)) - ((capacity weakness) - (when weakness - (error "No weak or ephemeral hashtables supported.")) - (if capacity - (rnrs-make-eq-hashtable capacity) - (rnrs-make-eq-hashtable))))) - -(define make-eqv-hashtable - (case-lambda - (() (make-eqv-hashtable #f #f)) - ((capacity) (make-eqv-hashtable capacity #f)) - ((capacity weakness) - (when weakness - (error "No weak or ephemeral hashtables supported.")) - (if capacity - (rnrs-make-eqv-hashtable capacity) - (rnrs-make-eqv-hashtable))))) - -(define make-hashtable - (case-lambda - ((hash equiv) (make-hashtable hash equiv #f #f)) - ((hash equiv capacity) (make-hashtable hash equiv capacity #f)) - ((hash equiv capacity weakness) - (cond - ((and (not hash) (eq? equiv eq?)) - (make-eq-hashtable capacity weakness)) - ((and (not hash) (eq? equiv eqv?)) - (make-eqv-hashtable capacity weakness)) - (else - (when weakness - (error "No weak or ephemeral hashtables supported.")) - (let ((hash (if (pair? hash) - (car hash) - hash))) - (if capacity - (rnrs-make-hashtable hash equiv capacity) - (rnrs-make-hashtable hash equiv)))))))) - -(define (alist->eq-hashtable . args) - (apply alist->hashtable #f eq? args)) - -(define (alist->eqv-hashtable . args) - (apply alist->hashtable #f eqv? args)) - -(define alist->hashtable - (case-lambda - ((hash equiv alist) - (alist->hashtable hash equiv #f #f alist)) - ((hash equiv capacity alist) - (alist->hashtable hash equiv capacity #f alist)) - ((hash equiv capacity weakness alist) - (let ((hashtable (make-hashtable hash equiv capacity weakness))) - (for-each (lambda (entry) - (hashtable-set! hashtable (car entry) (cdr entry))) - (reverse alist)) - hashtable)))) - -(define-enumeration weakness - (weak-key - weak-value - weak-key-and-value - ephemeral-key - ephemeral-value - ephemeral-key-and-value) - weakness-set) - -(define hashtable? rnrs-hashtable?) - -(define hashtable-size rnrs-hashtable-size) - -(define nil (cons #f #f)) -(define (nil? obj) (eq? obj nil)) - -(define hashtable-ref - (case-lambda - ((hashtable key) - (let ((value (rnrs-hashtable-ref hashtable key nil))) - (if (nil? value) - (error "No such key in hashtable." hashtable key) - value))) - ((hashtable key default) - (rnrs-hashtable-ref hashtable key default)))) - -(define hashtable-set! rnrs-hashtable-set!) - -(define hashtable-delete! rnrs-hashtable-delete!) - -(define hashtable-contains? rnrs-hashtable-contains?) - -(define (hashtable-lookup hashtable key) - (let ((value (rnrs-hashtable-ref hashtable key nil))) - (if (nil? value) - (values #f #f) - (values value #t)))) - -(define hashtable-update! - (case-lambda - ((hashtable key proc) (hashtable-update! hashtable key proc nil)) - ((hashtable key proc default) - (rnrs-hashtable-update! - hashtable key - (lambda (value) - (if (nil? value) - (error "No such key in hashtable." hashtable key) - (proc value))) - default)))) - -;;; XXX This could be implemented at the platform level to eliminate the second -;;; lookup for the key. -(define (hashtable-intern! hashtable key default-proc) - (let ((value (rnrs-hashtable-ref hashtable key nil))) - (if (nil? value) - (let ((value (default-proc))) - (hashtable-set! hashtable key value) - value) - value))) - -(define hashtable-copy - (case-lambda - ((hashtable) (hashtable-copy hashtable #f #f)) - ((hashtable mutable) (hashtable-copy hashtable mutable #f)) - ((hashtable mutable weakness) - (when weakness - (error "No weak or ephemeral tables supported.")) - (rnrs-hashtable-copy hashtable mutable)))) - -(define hashtable-clear! - (case-lambda - ((hashtable) (rnrs-hashtable-clear! hashtable)) - ((hashtable capacity) - (if capacity - (rnrs-hashtable-clear! hashtable capacity) - (rnrs-hashtable-clear! hashtable))))) - -(define hashtable-empty-copy - (case-lambda - ((hashtable) (hashtable-empty-copy hashtable #f)) - ((hashtable capacity) - (make-hashtable (hashtable-hash-function hashtable) - (hashtable-equivalence-function hashtable) - (if (eq? #t capacity) - (hashtable-size hashtable) - capacity) - (hashtable-weakness hashtable))))) - -(define hashtable-keys rnrs-hashtable-keys) - -(define (hashtable-values hashtable) - (let-values (((keys values) (rnrs-hashtable-entries hashtable))) - values)) - -(define hashtable-entries rnrs-hashtable-entries) - -(define (hashtable-key-list hashtable) - (hashtable-map->lset hashtable (lambda (key value) key))) - -(define (hashtable-value-list hashtable) - (hashtable-map->lset hashtable (lambda (key value) value))) - -(define (hashtable-entry-lists hashtable) - (let ((keys '()) - (vals '())) - (hashtable-walk hashtable - (lambda (key val) - (set! keys (cons key keys)) - (set! vals (cons val vals)))) - (values keys vals))) - -;;; XXX The procedures hashtable-walk, hashtable-update-all!, hashtable-prune!, -;;; and hashtable-sum should be implemented more efficiently at the platform -;;; level. In particular, they should not allocate intermediate vectors or -;;; lists to hold the keys or values that are being operated on. - -(define (hashtable-walk hashtable proc) - (let-values (((keys values) (rnrs-hashtable-entries hashtable))) - (vector-for-each proc keys values))) - -(define (hashtable-update-all! hashtable proc) - (let-values (((keys values) (hashtable-entries hashtable))) - (vector-for-each (lambda (key value) - (hashtable-set! hashtable key (proc key value))) - keys values))) - -(define (hashtable-prune! hashtable proc) - (let-values (((keys values) (hashtable-entries hashtable))) - (vector-for-each (lambda (key value) - (when (proc key value) - (hashtable-delete! hashtable key))) - keys values))) - -(define (hashtable-merge! hashtable-dest hashtable-source) - (hashtable-walk hashtable-source - (lambda (key value) - (hashtable-set! hashtable-dest key value))) - hashtable-dest) - -(define (hashtable-sum hashtable init proc) - (let-values (((keys vals) (hashtable-entry-lists hashtable))) - (fold proc init keys vals))) - -(define (hashtable-map->lset hashtable proc) - (hashtable-sum hashtable '() - (lambda (key value accumulator) - (cons (proc key value) accumulator)))) - -;;; XXX If available, let-escape-continuation might be more efficient than -;;; call/cc here. -(define (hashtable-find hashtable proc) - (call/cc - (lambda (return) - (hashtable-walk hashtable - (lambda (key value) - (when (proc key value) - (return key value #t)))) - (return #f #f #f)))) - -(define (hashtable-empty? hashtable) - (zero? (hashtable-size hashtable))) - -;;; XXX A platform-level implementation could avoid allocating the constant true -;;; function and the lookup for the key in the delete operation. -(define (hashtable-pop! hashtable) - (if (hashtable-empty? hashtable) - (error "Cannot pop from empty hashtable." hashtable) - (let-values (((key value found?) - (hashtable-find hashtable (lambda (k v) #t)))) - (hashtable-delete! hashtable key) - (values key value)))) - -(define hashtable-inc! - (case-lambda - ((hashtable key) (hashtable-inc! hashtable key 1)) - ((hashtable key number) - (hashtable-update! hashtable key (lambda (v) (+ v number)) 0)))) - -(define hashtable-dec! - (case-lambda - ((hashtable key) (hashtable-dec! hashtable key 1)) - ((hashtable key number) - (hashtable-update! hashtable key (lambda (v) (- v number)) 0)))) - -(define hashtable-equivalence-function rnrs-hashtable-equivalence-function) - -(define hashtable-hash-function rnrs-hashtable-hash-function) - -(define (hashtable-weakness hashtable) #f) - -(define hashtable-mutable? rnrs-hashtable-mutable?) - -(define *hash-salt* - (let ((seed (get-environment-variable "SRFI_126_HASH_SEED"))) - (if (or (not seed) (string=? seed "")) - (random-integer (greatest-fixnum)) - (modulo - (fold (lambda (char result) - (+ (char->integer char) result)) - 0 - (string->list seed)) - (greatest-fixnum))))) - -(define (hash-salt) *hash-salt*) - -(define equal-hash rnrs-equal-hash) - -(define string-hash rnrs-string-hash) - -(define string-ci-hash rnrs-string-ci-hash) - -(define symbol-hash rnrs-symbol-hash) - -;; Local Variables: -;; eval: (put 'hashtable-walk 'scheme-indent-function 1) -;; eval: (put 'hashtable-update-all! 'scheme-indent-function 1) -;; eval: (put 'hashtable-prune! 'scheme-indent-function 1) -;; eval: (put 'hashtable-sum 'scheme-indent-function 2) -;; eval: (put 'hashtable-map->lset 'scheme-indent-function 1) -;; eval: (put 'hashtable-find 'scheme-indent-function 1) -;; End: -(define-library (srfi 126) - (export - make-eq-hashtable make-eqv-hashtable make-hashtable - alist->eq-hashtable alist->eqv-hashtable alist->hashtable - weakness - hashtable? - hashtable-size - hashtable-ref hashtable-set! hashtable-delete! - hashtable-contains? - hashtable-lookup hashtable-update! hashtable-intern! - hashtable-copy hashtable-clear! hashtable-empty-copy - hashtable-keys hashtable-values hashtable-entries - hashtable-key-list hashtable-value-list hashtable-entry-lists - hashtable-walk hashtable-update-all! hashtable-prune! hashtable-merge! - hashtable-sum hashtable-map->lset hashtable-find - hashtable-empty? hashtable-pop! hashtable-inc! hashtable-dec! - hashtable-equivalence-function hashtable-hash-function hashtable-weakness - hashtable-mutable? - hash-salt equal-hash string-hash string-ci-hash symbol-hash) - (import - (scheme base) - (scheme case-lambda) - (scheme process-context) - (r6rs enums) - (prefix (r6rs hashtables) rnrs-) - (srfi 1) - (srfi 27)) - (begin - - ;; Smallest allowed in R6RS. - (define (greatest-fixnum) (expt 23 2)) - - ;; INCLUDE 126.body.scm -(define make-eq-hashtable - (case-lambda - (() (make-eq-hashtable #f #f)) - ((capacity) (make-eq-hashtable capacity #f)) - ((capacity weakness) - (when weakness - (error "No weak or ephemeral hashtables supported.")) - (if capacity - (rnrs-make-eq-hashtable capacity) - (rnrs-make-eq-hashtable))))) - -(define make-eqv-hashtable - (case-lambda - (() (make-eqv-hashtable #f #f)) - ((capacity) (make-eqv-hashtable capacity #f)) - ((capacity weakness) - (when weakness - (error "No weak or ephemeral hashtables supported.")) - (if capacity - (rnrs-make-eqv-hashtable capacity) - (rnrs-make-eqv-hashtable))))) - -(define make-hashtable - (case-lambda - ((hash equiv) (make-hashtable hash equiv #f #f)) - ((hash equiv capacity) (make-hashtable hash equiv capacity #f)) - ((hash equiv capacity weakness) - (cond - ((and (not hash) (eq? equiv eq?)) - (make-eq-hashtable capacity weakness)) - ((and (not hash) (eq? equiv eqv?)) - (make-eqv-hashtable capacity weakness)) - (else - (when weakness - (error "No weak or ephemeral hashtables supported.")) - (let ((hash (if (pair? hash) - (car hash) - hash))) - (if capacity - (rnrs-make-hashtable hash equiv capacity) - (rnrs-make-hashtable hash equiv)))))))) - -(define (alist->eq-hashtable . args) - (apply alist->hashtable #f eq? args)) - -(define (alist->eqv-hashtable . args) - (apply alist->hashtable #f eqv? args)) - -(define alist->hashtable - (case-lambda - ((hash equiv alist) - (alist->hashtable hash equiv #f #f alist)) - ((hash equiv capacity alist) - (alist->hashtable hash equiv capacity #f alist)) - ((hash equiv capacity weakness alist) - (let ((hashtable (make-hashtable hash equiv capacity weakness))) - (for-each (lambda (entry) - (hashtable-set! hashtable (car entry) (cdr entry))) - (reverse alist)) - hashtable)))) - -(define-enumeration weakness - (weak-key - weak-value - weak-key-and-value - ephemeral-key - ephemeral-value - ephemeral-key-and-value) - weakness-set) - -(define hashtable? rnrs-hashtable?) - -(define hashtable-size rnrs-hashtable-size) - -(define nil (cons #f #f)) -(define (nil? obj) (eq? obj nil)) - -(define hashtable-ref - (case-lambda - ((hashtable key) - (let ((value (rnrs-hashtable-ref hashtable key nil))) - (if (nil? value) - (error "No such key in hashtable." hashtable key) - value))) - ((hashtable key default) - (rnrs-hashtable-ref hashtable key default)))) - -(define hashtable-set! rnrs-hashtable-set!) - -(define hashtable-delete! rnrs-hashtable-delete!) - -(define hashtable-contains? rnrs-hashtable-contains?) - -(define (hashtable-lookup hashtable key) - (let ((value (rnrs-hashtable-ref hashtable key nil))) - (if (nil? value) - (values #f #f) - (values value #t)))) - -(define hashtable-update! - (case-lambda - ((hashtable key proc) (hashtable-update! hashtable key proc nil)) - ((hashtable key proc default) - (rnrs-hashtable-update! - hashtable key - (lambda (value) - (if (nil? value) - (error "No such key in hashtable." hashtable key) - (proc value))) - default)))) - -;;; XXX This could be implemented at the platform level to eliminate the second -;;; lookup for the key. -(define (hashtable-intern! hashtable key default-proc) - (let ((value (rnrs-hashtable-ref hashtable key nil))) - (if (nil? value) - (let ((value (default-proc))) - (hashtable-set! hashtable key value) - value) - value))) - -(define hashtable-copy - (case-lambda - ((hashtable) (hashtable-copy hashtable #f #f)) - ((hashtable mutable) (hashtable-copy hashtable mutable #f)) - ((hashtable mutable weakness) - (when weakness - (error "No weak or ephemeral tables supported.")) - (rnrs-hashtable-copy hashtable mutable)))) - -(define hashtable-clear! - (case-lambda - ((hashtable) (rnrs-hashtable-clear! hashtable)) - ((hashtable capacity) - (if capacity - (rnrs-hashtable-clear! hashtable capacity) - (rnrs-hashtable-clear! hashtable))))) - -(define hashtable-empty-copy - (case-lambda - ((hashtable) (hashtable-empty-copy hashtable #f)) - ((hashtable capacity) - (make-hashtable (hashtable-hash-function hashtable) - (hashtable-equivalence-function hashtable) - (if (eq? #t capacity) - (hashtable-size hashtable) - capacity) - (hashtable-weakness hashtable))))) - -(define hashtable-keys rnrs-hashtable-keys) - -(define (hashtable-values hashtable) - (let-values (((keys values) (rnrs-hashtable-entries hashtable))) - values)) - -(define hashtable-entries rnrs-hashtable-entries) - -(define (hashtable-key-list hashtable) - (hashtable-map->lset hashtable (lambda (key value) key))) - -(define (hashtable-value-list hashtable) - (hashtable-map->lset hashtable (lambda (key value) value))) - -(define (hashtable-entry-lists hashtable) - (let ((keys '()) - (vals '())) - (hashtable-walk hashtable - (lambda (key val) - (set! keys (cons key keys)) - (set! vals (cons val vals)))) - (values keys vals))) - -;;; XXX The procedures hashtable-walk, hashtable-update-all!, hashtable-prune!, -;;; and hashtable-sum should be implemented more efficiently at the platform -;;; level. In particular, they should not allocate intermediate vectors or -;;; lists to hold the keys or values that are being operated on. - -(define (hashtable-walk hashtable proc) - (let-values (((keys values) (rnrs-hashtable-entries hashtable))) - (vector-for-each proc keys values))) - -(define (hashtable-update-all! hashtable proc) - (let-values (((keys values) (hashtable-entries hashtable))) - (vector-for-each (lambda (key value) - (hashtable-set! hashtable key (proc key value))) - keys values))) - -(define (hashtable-prune! hashtable proc) - (let-values (((keys values) (hashtable-entries hashtable))) - (vector-for-each (lambda (key value) - (when (proc key value) - (hashtable-delete! hashtable key))) - keys values))) - -(define (hashtable-merge! hashtable-dest hashtable-source) - (hashtable-walk hashtable-source - (lambda (key value) - (hashtable-set! hashtable-dest key value))) - hashtable-dest) - -(define (hashtable-sum hashtable init proc) - (let-values (((keys vals) (hashtable-entry-lists hashtable))) - (fold proc init keys vals))) - -(define (hashtable-map->lset hashtable proc) - (hashtable-sum hashtable '() - (lambda (key value accumulator) - (cons (proc key value) accumulator)))) - -;;; XXX If available, let-escape-continuation might be more efficient than -;;; call/cc here. -(define (hashtable-find hashtable proc) - (call/cc - (lambda (return) - (hashtable-walk hashtable - (lambda (key value) - (when (proc key value) - (return key value #t)))) - (return #f #f #f)))) - -(define (hashtable-empty? hashtable) - (zero? (hashtable-size hashtable))) - -;;; XXX A platform-level implementation could avoid allocating the constant true -;;; function and the lookup for the key in the delete operation. -(define (hashtable-pop! hashtable) - (if (hashtable-empty? hashtable) - (error "Cannot pop from empty hashtable." hashtable) - (let-values (((key value found?) - (hashtable-find hashtable (lambda (k v) #t)))) - (hashtable-delete! hashtable key) - (values key value)))) - -(define hashtable-inc! - (case-lambda - ((hashtable key) (hashtable-inc! hashtable key 1)) - ((hashtable key number) - (hashtable-update! hashtable key (lambda (v) (+ v number)) 0)))) - -(define hashtable-dec! - (case-lambda - ((hashtable key) (hashtable-dec! hashtable key 1)) - ((hashtable key number) - (hashtable-update! hashtable key (lambda (v) (- v number)) 0)))) - -(define hashtable-equivalence-function rnrs-hashtable-equivalence-function) - -(define hashtable-hash-function rnrs-hashtable-hash-function) - -(define (hashtable-weakness hashtable) #f) - -(define hashtable-mutable? rnrs-hashtable-mutable?) - -(define *hash-salt* - (let ((seed (get-environment-variable "SRFI_126_HASH_SEED"))) - (if (or (not seed) (string=? seed "")) - (random-integer (greatest-fixnum)) - (modulo - (fold (lambda (char result) - (+ (char->integer char) result)) - 0 - (string->list seed)) - (greatest-fixnum))))) - -(define (hash-salt) *hash-salt*) - -(define equal-hash rnrs-equal-hash) - -(define string-hash rnrs-string-hash) - -(define string-ci-hash rnrs-string-ci-hash) - -(define symbol-hash rnrs-symbol-hash) - -;; Local Variables: -;; eval: (put 'hashtable-walk 'scheme-indent-function 1) -;; eval: (put 'hashtable-update-all! 'scheme-indent-function 1) -;; eval: (put 'hashtable-prune! 'scheme-indent-function 1) -;; eval: (put 'hashtable-sum 'scheme-indent-function 2) -;; eval: (put 'hashtable-map->lset 'scheme-indent-function 1) -;; eval: (put 'hashtable-find 'scheme-indent-function 1) -;; End: - - )) -;;; Guile implementation. - -(define-module (srfi srfi-126)) - -(use-modules - (srfi srfi-1) - (srfi srfi-9) - (srfi srfi-9 gnu) - (srfi srfi-11) - (ice-9 hash-table) - (ice-9 control) - ((rnrs hashtables) #\select - (equal-hash string-hash string-ci-hash symbol-hash))) - -(export - make-eq-hashtable make-eqv-hashtable make-hashtable - alist->eq-hashtable alist->eqv-hashtable alist->hashtable - weakness - hashtable? hashtable-size - hashtable-ref hashtable-set! hashtable-delete! hashtable-contains? - hashtable-lookup hashtable-update! hashtable-intern! - hashtable-copy hashtable-clear! hashtable-empty-copy - hashtable-keys hashtable-values hashtable-entries - hashtable-key-list hashtable-value-list hashtable-entry-lists - hashtable-walk hashtable-update-all! hashtable-prune! hashtable-merge! - hashtable-sum hashtable-map->lset hashtable-find - hashtable-empty? hashtable-pop! hashtable-inc! hashtable-dec! - hashtable-equivalence-function hashtable-hash-function - hashtable-weakness hashtable-mutable? - hash-salt - ) - -(re-export equal-hash string-hash string-ci-hash symbol-hash) - -(define-record-type - (%make-hashtable %table %hash %assoc hash equiv weakness mutable) - hashtable? - (%table %hashtable-table) - (%hash %hashtable-hash) - (%assoc %hashtable-assoc) - (hash hashtable-hash-function) - (equiv hashtable-equivalence-function) - (weakness hashtable-weakness) - (mutable hashtable-mutable? %hashtable-set-mutable!)) - -(define nil (cons #f #f)) -(define (nil? obj) (eq? obj nil)) - -(define (make-table capacity weakness) - (let ((capacity (or capacity 32))) - (case weakness - ((#f) (make-hash-table capacity)) - ((weak-key) (make-weak-key-hash-table capacity)) - ((weak-value) (make-weak-value-hash-table capacity)) - ((weak-key-and-value) (make-doubly-weak-hash-table capacity)) - (else (error "Hashtable weakness not supported." weakness))))) - -(define* (make-eq-hashtable #\optional capacity weakness) - (let ((table (make-table capacity weakness))) - (%make-hashtable table hashq assq #f eq? weakness #t))) - -(define* (make-eqv-hashtable #\optional capacity weakness) - (let ((table (make-table capacity weakness))) - (%make-hashtable table hashv assv #f eqv? weakness #t))) - -(define* (make-hashtable hash equiv #\optional capacity weakness) - (cond - ((and (not hash) (eq? equiv eq?)) - (make-eq-hashtable capacity weakness)) - ((and (not hash) (eq? equiv eqv?)) - (make-eqv-hashtable capacity weakness)) - (else - (let* ((table (make-table capacity weakness)) - (hash (if (pair? hash) - (car hash) - hash)) - (%hash (lambda (obj bound) - (modulo (hash obj) bound))) - (assoc (lambda (key alist) - (find (lambda (entry) - (equiv (car entry) key)) - alist)))) - (%make-hashtable table %hash assoc hash equiv weakness #t))))) - -(define (alist->eq-hashtable . args) - (apply alist->hashtable #f eq? args)) - -(define (alist->eqv-hashtable . args) - (apply alist->hashtable #f eqv? args)) - -(define alist->hashtable - (case-lambda - ((hash equiv alist) - (alist->hashtable hash equiv #f #f alist)) - ((hash equiv capacity alist) - (alist->hashtable hash equiv capacity #f alist)) - ((hash equiv capacity weakness alist) - (let ((ht (make-hashtable hash equiv capacity weakness))) - (for-each (lambda (entry) - (hashtable-set! ht (car entry) (cdr entry))) - (reverse alist)) - ht)))) - -(define-syntax weakness - (lambda (stx) - (syntax-case stx () - ((_ ) - (let ((sym (syntax->datum #'))) - (case sym - ((weak-key weak-value weak-key-and-value ephemeral-key - ephemeral-value ephemeral-key-and-value) - #''sym) - (else - (error "Bad weakness symbol." sym)))))))) - -(define (hashtable-size ht) - (hash-count (const #t) (%hashtable-table ht))) - -(define* (%hashtable-ref ht key default) - (hashx-ref (%hashtable-hash ht) (%hashtable-assoc ht) - (%hashtable-table ht) key default)) - -(define* (hashtable-ref ht key #\optional (default nil)) - (let ((val (%hashtable-ref ht key default))) - (if (nil? val) - (error "No association for key in hashtable." key ht) - val))) - -(define (assert-mutable ht) - (when (not (hashtable-mutable? ht)) - (error "Hashtable is immutable." ht))) - -(define (hashtable-set! ht key value) - (assert-mutable ht) - (hashx-set! (%hashtable-hash ht) (%hashtable-assoc ht) - (%hashtable-table ht) key value) - *unspecified*) - -(define (hashtable-delete! ht key) - (assert-mutable ht) - (hashx-remove! (%hashtable-hash ht) (%hashtable-assoc ht) - (%hashtable-table ht) key) - *unspecified*) - -(define (hashtable-contains? ht key) - (not (nil? (%hashtable-ref ht key nil)))) - -(define (hashtable-lookup ht key) - (let ((val (%hashtable-ref ht key nil))) - (if (nil? val) - (values #f #f) - (values val #t)))) - -(define* (hashtable-update! ht key updater #\optional (default nil)) - (assert-mutable ht) - (let ((handle (hashx-create-handle! - (%hashtable-hash ht) (%hashtable-assoc ht) - (%hashtable-table ht) key nil))) - (if (eq? nil (cdr handle)) - (if (nil? default) - (error "No association for key in hashtable." key ht) - (set-cdr! handle (updater default))) - (set-cdr! handle (updater (cdr handle)))) - (cdr handle))) - -(define (hashtable-intern! ht key default-proc) - (assert-mutable ht) - (let ((handle (hashx-create-handle! - (%hashtable-hash ht) (%hashtable-assoc ht) - (%hashtable-table ht) key nil))) - (when (nil? (cdr handle)) - (set-cdr! handle (default-proc))) - (cdr handle))) - -(define* (hashtable-copy ht #\optional mutable weakness) - (let ((copy (hashtable-empty-copy ht (hashtable-size ht) weakness))) - (hashtable-walk ht - (lambda (k v) - (hashtable-set! copy k v))) - (%hashtable-set-mutable! copy mutable) - copy)) - -(define* (hashtable-clear! ht #\optional _capacity) - (assert-mutable ht) - (hash-clear! (%hashtable-table ht)) - *unspecified*) - -(define* (hashtable-empty-copy ht #\optional capacity weakness) - (make-hashtable (hashtable-hash-function ht) - (hashtable-equivalence-function ht) - (case capacity - ((#f) #f) - ((#t) (hashtable-size ht)) - (else capacity)) - (or weakness (hashtable-weakness ht)))) - -(define (hashtable-keys ht) - (let ((keys (make-vector (hashtable-size ht)))) - (hashtable-sum ht 0 - (lambda (k v i) - (vector-set! keys i k) - (+ i 1))) - keys)) - -(define (hashtable-values ht) - (let ((vals (make-vector (hashtable-size ht)))) - (hashtable-sum ht 0 - (lambda (k v i) - (vector-set! vals i v) - (+ i 1))) - vals)) - -(define (hashtable-entries ht) - (let ((keys (make-vector (hashtable-size ht))) - (vals (make-vector (hashtable-size ht)))) - (hashtable-sum ht 0 - (lambda (k v i) - (vector-set! keys i k) - (vector-set! vals i v) - (+ i 1))) - (values keys vals))) - -(define (hashtable-key-list ht) - (hashtable-map->lset ht (lambda (k v) k))) - -(define (hashtable-value-list ht) - (hashtable-map->lset ht (lambda (k v) v))) - -(define (hashtable-entry-lists ht) - (let ((keys&vals (cons '() '()))) - (hashtable-walk ht - (lambda (k v) - (set-car! keys&vals (cons k (car keys&vals))) - (set-cdr! keys&vals (cons v (cdr keys&vals))))) - (car+cdr keys&vals))) - -(define (hashtable-walk ht proc) - (hash-for-each proc (%hashtable-table ht))) - -(define (hashtable-update-all! ht proc) - (assert-mutable ht) - (hash-for-each-handle - (lambda (handle) - (set-cdr! handle (proc (car handle) (cdr handle)))) - (%hashtable-table ht))) - -(define (hashtable-prune! ht pred) - (assert-mutable ht) - (let ((keys (hashtable-sum ht '() - (lambda (k v keys-to-delete) - (if (pred k v) - (cons k keys-to-delete) - keys-to-delete))))) - (for-each (lambda (k) - (hashtable-delete! ht k)) - keys))) - -(define (hashtable-merge! ht-dest ht-src) - (assert-mutable ht-dest) - (hashtable-walk ht-src - (lambda (k v) - (hashtable-set! ht-dest k v))) - ht-dest) - -(define (hashtable-sum ht init proc) - (hash-fold proc init (%hashtable-table ht))) - -(define (hashtable-map->lset ht proc) - (hash-map->list proc (%hashtable-table ht))) - -(define (hashtable-find ht pred) - (let/ec return - (hashtable-walk ht - (lambda (k v) - (when (pred k v) - (return k v #t)))) - (return #f #f #f))) - -(define (hashtable-empty? ht) - (zero? (hashtable-size ht))) - -(define (hashtable-pop! ht) - (assert-mutable ht) - (when (hashtable-empty? ht) - (error "Cannot pop from empty hashtable." ht)) - (let-values (((k v found?) (hashtable-find ht (const #t)))) - (hashtable-delete! ht k) - (values k v))) - -(define* (hashtable-inc! ht k #\optional (x 1)) - (assert-mutable ht) - (hashtable-update! ht k (lambda (v) (+ v x)) 0)) - -(define* (hashtable-dec! ht k #\optional (x 1)) - (assert-mutable ht) - (hashtable-update! ht k (lambda (v) (- v x)) 0)) - -(define (hash-salt) 0) - -(set-record-type-printer! - - (lambda (ht port) - (with-output-to-port port - (lambda () - (let ((equal-hash (@ (rnrs hashtables) equal-hash)) - (string-hash (@ (rnrs hashtables) string-hash)) - (string-ci-hash (@ (rnrs hashtables) string-ci-hash)) - (symbol-hash (@ (rnrs hashtables) symbol-hash)) - (hash (hashtable-hash-function ht)) - (equiv (hashtable-equivalence-function ht)) - (alist (hashtable-map->lset ht cons))) - (cond - ((and (not hash) (eq? equiv eq?)) - (display "#hasheq") - (display alist)) - ((and (not hash) (eq? equiv eqv?)) - (display "#hasheqv") - (display alist)) - (else - (display "#hash") - (cond - ((and (eq? hash (@ (rnrs hashtables) equal-hash)) (eq? equiv equal?)) - (display alist)) - ((and (eq? hash (@ (rnrs hashtables) string-hash)) (eq? equiv string=?)) - (display (cons 'string alist))) - ((and (eq? hash string-ci-hash) (eq? equiv string-ci=?)) - (display (cons 'string-ci alist))) - ((and (eq? hash symbol-hash) (eq? equiv eq?)) - (display (cons 'symbol alist))) - (else - (display (cons 'custom alist))))))))))) - -(read-hash-extend - #\h - (lambda (char port) - (with-input-from-port port - (lambda () - (let ((equal-hash (@ (rnrs hashtables) equal-hash)) - (string-hash (@ (rnrs hashtables) string-hash)) - (string-ci-hash (@ (rnrs hashtables) string-ci-hash)) - (symbol-hash (@ (rnrs hashtables) symbol-hash)) - (type (string-append "h" (symbol->string (read)))) - (alist (read))) - (cond - ((string=? type "hasheq") - (alist->eq-hashtable alist)) - ((string=? type "hasheqv") - (alist->eqv-hashtable alist)) - (else - (when (not (string=? type "hash")) - (error "Unrecognized hash type." type)) - (let* ((has-tag? (symbol? (car alist))) - (subtype (if has-tag? - (car alist) - "equal")) - (alist (if has-tag? - (cdr alist) - alist))) - (cond - ((string=? subtype "equal") - (alist->hashtable equal-hash equal? alist)) - ((string=? subtype "string") - (alist->hashtable string-hash string=? alist)) - ((string=? subtype "string-ci") - (alist->hashtable string-ci-hash string-ci=? alist)) - ((string=? subtype "symbol") - (alist->hashtable symbol-hash eq? alist)) - (else - (error "Unrecognized hash subtype." subtype))))))))))) - -;; Local Variables: -;; eval: (put 'hashtable-walk 'scheme-indent-function 1) -;; eval: (put 'hashtable-update-all! 'scheme-indent-function 1) -;; eval: (put 'hashtable-prune! 'scheme-indent-function 1) -;; eval: (put 'hashtable-sum 'scheme-indent-function 2) -;; eval: (put 'hashtable-map->lset 'scheme-indent-function 1) -;; eval: (put 'hashtable-find 'scheme-indent-function 1) -;; End: -;;; This doesn't test weakness, external representation, and quasiquote. - -(test-begin "SRFI-126") - -(test-group "constructors & inspection" - (test-group "eq" - (let ((tables (list (make-eq-hashtable) - (make-eq-hashtable 10) - (make-eq-hashtable #f #f) - (make-hashtable #f eq?) - (alist->eq-hashtable '((a . b) (c . d))) - (alist->eq-hashtable 10 '((a . b) (c . d))) - (alist->eq-hashtable #f #f '((a . b) (c . d)))))) - (do ((tables tables (cdr tables)) - (i 0 (+ i 1))) - ((null? tables)) - (let ((table (car tables)) - (label (number->string i))) - (test-assert label (hashtable? table)) - (test-eq label #f (hashtable-hash-function table)) - (test-eq label eq? (hashtable-equivalence-function table)) - (test-eq label #f (hashtable-weakness table)) - (test-assert label (hashtable-mutable? table)))))) - (test-group "eqv" - (let ((tables (list (make-eqv-hashtable) - (make-eqv-hashtable 10) - (make-eqv-hashtable #f #f) - (make-hashtable #f eqv?) - (alist->eqv-hashtable '((a . b) (c . d))) - (alist->eqv-hashtable 10 '((a . b) (c . d))) - (alist->eqv-hashtable #f #f '((a . b) (c . d)))))) - (do ((tables tables (cdr tables)) - (i 0 (+ i 1))) - ((null? tables)) - (let ((table (car tables)) - (label (number->string i))) - (test-assert label (hashtable? table)) - (test-eq label #f (hashtable-hash-function table)) - (test-eq label eqv? (hashtable-equivalence-function table)) - (test-eq label #f (hashtable-weakness table)) - (test-assert label (hashtable-mutable? table)))))) - (test-group "equal" - (let ((tables (list (make-hashtable equal-hash equal?) - (make-hashtable equal-hash equal? 10) - (make-hashtable equal-hash equal? #f #f) - (alist->hashtable equal-hash equal? - '((a . b) (c . d))) - (alist->hashtable equal-hash equal? 10 - '((a . b) (c . d))) - (alist->hashtable equal-hash equal? #f #f - '((a . b) (c . d)))))) - (do ((tables tables (cdr tables)) - (i 0 (+ i 1))) - ((null? tables)) - (let ((table (car tables)) - (label (number->string i))) - (test-assert label (hashtable? table)) - (test-eq label equal-hash (hashtable-hash-function table)) - (test-eq label equal? (hashtable-equivalence-function table)) - (test-eq label #f (hashtable-weakness table)) - (test-assert label (hashtable-mutable? table)))) - (let ((table (make-hashtable (cons equal-hash equal-hash) equal?))) - (let ((hash (hashtable-hash-function table))) - (test-assert (or (eq? equal-hash hash) - (and (eq? equal-hash (car hash)) - (eq? equal-hash (cdr hash))))))))) - (test-group "alist" - (let ((tables (list (alist->eq-hashtable '((a . b) (a . c))) - (alist->eqv-hashtable '((a . b) (a . c))) - (alist->hashtable equal-hash equal? - '((a . b) (a . c)))))) - (do ((tables tables (cdr tables)) - (i 0 (+ i 1))) - ((null? tables)) - (let ((table (car tables)) - (label (number->string i))) - (test-eq label 'b (hashtable-ref table 'a))))))) - -(test-group "procedures" - (test-group "basics" - (let ((table (make-eq-hashtable))) - (test-group "ref" - (test-error (hashtable-ref table 'a)) - (test-eq 'b (hashtable-ref table 'a 'b)) - (test-assert (not (hashtable-contains? table 'a))) - (test-eqv 0 (hashtable-size table))) - (test-group "set" - (hashtable-set! table 'a 'c) - (test-eq 'c (hashtable-ref table 'a)) - (test-eq 'c (hashtable-ref table 'a 'b)) - (test-assert (hashtable-contains? table 'a)) - (test-eqv 1 (hashtable-size table))) - (test-group "delete" - (hashtable-delete! table 'a) - (test-error (hashtable-ref table 'a)) - (test-eq 'b (hashtable-ref table 'a 'b)) - (test-assert (not (hashtable-contains? table 'a))) - (test-eqv 0 (hashtable-size table))))) - (test-group "advanced" - (let ((table (make-eq-hashtable))) - (test-group "lookup" - (let-values (((x found?) (hashtable-lookup table 'a))) - (test-assert (not found?)))) - (test-group "update" - (test-error (hashtable-update! table 'a (lambda (x) (+ x 1)))) - (hashtable-update! table 'a (lambda (x) (+ x 1)) 0) - (let-values (((x found?) (hashtable-lookup table 'a))) - (test-eqv 1 x) - (test-assert found?)) - (hashtable-update! table 'a (lambda (x) (+ x 1))) - (let-values (((x found?) (hashtable-lookup table 'a))) - (test-eqv x 2) - (test-assert found?)) - (hashtable-update! table 'a (lambda (x) (+ x 1)) 0) - (let-values (((x found?) (hashtable-lookup table 'a))) - (test-eqv x 3) - (test-assert found?))) - (test-group "intern" - (test-eqv 0 (hashtable-intern! table 'b (lambda () 0))) - (test-eqv 0 (hashtable-intern! table 'b (lambda () 1)))))) - (test-group "copy/clear" - (let ((table (alist->hashtable equal-hash equal? '((a . b))))) - (test-group "copy" - (let ((table2 (hashtable-copy table))) - (test-eq equal-hash (hashtable-hash-function table2)) - (test-eq equal? (hashtable-equivalence-function table2)) - (test-eq 'b (hashtable-ref table2 'a)) - (test-error (hashtable-set! table2 'a 'c))) - (let ((table2 (hashtable-copy table #f))) - (test-eq equal-hash (hashtable-hash-function table2)) - (test-eq equal? (hashtable-equivalence-function table2)) - (test-eq 'b (hashtable-ref table2 'a)) - (test-error (hashtable-set! table2 'a 'c))) - (let ((table2 (hashtable-copy table #t))) - (test-eq equal-hash (hashtable-hash-function table2)) - (test-eq equal? (hashtable-equivalence-function table2)) - (test-eq 'b (hashtable-ref table2 'a)) - (hashtable-set! table2 'a 'c) - (test-eq 'c (hashtable-ref table2 'a))) - (let ((table2 (hashtable-copy table #f #f))) - (test-eq equal-hash (hashtable-hash-function table2)) - (test-eq equal? (hashtable-equivalence-function table2)) - (test-eq #f (hashtable-weakness table2)))) - (test-group "clear" - (let ((table2 (hashtable-copy table #t))) - (hashtable-clear! table2) - (test-eqv 0 (hashtable-size table2))) - (let ((table2 (hashtable-copy table #t))) - (hashtable-clear! table2 10) - (test-eqv 0 (hashtable-size table2)))) - (test-group "empty-copy" - (let ((table2 (hashtable-empty-copy table))) - (test-eq equal-hash (hashtable-hash-function table2)) - (test-eq equal? (hashtable-equivalence-function table2)) - (test-eqv 0 (hashtable-size table2))) - (let ((table2 (hashtable-empty-copy table 10))) - (test-eq equal-hash (hashtable-hash-function table2)) - (test-eq equal? (hashtable-equivalence-function table2)) - (test-eqv 0 (hashtable-size table2)))))) - (test-group "keys/values" - (let ((table (alist->eq-hashtable '((a . b) (c . d))))) - (test-assert (lset= eq? '(a c) (vector->list (hashtable-keys table)))) - (test-assert (lset= eq? '(b d) (vector->list (hashtable-values table)))) - (let-values (((keys values) (hashtable-entries table))) - (test-assert (lset= eq? '(a c) (vector->list keys))) - (test-assert (lset= eq? '(b d) (vector->list values)))) - (test-assert (lset= eq? '(a c) (hashtable-key-list table))) - (test-assert (lset= eq? '(b d) (hashtable-value-list table))) - (let-values (((keys values) (hashtable-entry-lists table))) - (test-assert (lset= eq? '(a c) keys)) - (test-assert (lset= eq? '(b d) values))))) - (test-group "iteration" - (test-group "walk" - (let ((keys '()) - (values '())) - (hashtable-walk (alist->eq-hashtable '((a . b) (c . d))) - (lambda (k v) - (set! keys (cons k keys)) - (set! values (cons v values)))) - (test-assert (lset= eq? '(a c) keys)) - (test-assert (lset= eq? '(b d) values)))) - (test-group "update-all" - (let ((table (alist->eq-hashtable '((a . b) (c . d))))) - (hashtable-update-all! table - (lambda (k v) - (string->symbol (string-append (symbol->string v) "x")))) - (test-assert (lset= eq? '(a c) (hashtable-key-list table))) - (test-assert (lset= eq? '(bx dx) (hashtable-value-list table))))) - (test-group "prune" - (let ((table (alist->eq-hashtable '((a . b) (c . d))))) - (hashtable-prune! table (lambda (k v) (eq? k 'a))) - (test-assert (not (hashtable-contains? table 'a))) - (test-assert (hashtable-contains? table 'c)))) - (test-group "merge" - (let ((table (alist->eq-hashtable '((a . b) (c . d)))) - (table2 (alist->eq-hashtable '((a . x) (e . f))))) - (hashtable-merge! table table2) - (test-assert (lset= eq? '(a c e) (hashtable-key-list table))) - (test-assert (lset= eq? '(x d f) (hashtable-value-list table))))) - (test-group "sum" - (let ((table (alist->eq-hashtable '((a . b) (c . d))))) - (test-assert (lset= eq? '(a b c d) - (hashtable-sum table '() - (lambda (k v acc) - (lset-adjoin eq? acc k v))))))) - (test-group "map->lset" - (let ((table (alist->eq-hashtable '((a . b) (c . d))))) - (test-assert (lset= equal? '((a . b) (c . d)) - (hashtable-map->lset table cons))))) - (test-group "find" - (let ((table (alist->eq-hashtable '((a . b) (c . d))))) - (let-values (((k v f?) (hashtable-find table - (lambda (k v) - (eq? k 'a))))) - (test-assert (and f? (eq? k 'a) (eq? v 'b)))) - (let-values (((k v f?) (hashtable-find table (lambda (k v) #f)))) - (test-assert (not f?))))) - (test-group "misc" - (test-group "empty?" - (test-assert (hashtable-empty? (alist->eq-hashtable '()))) - (test-assert (not (hashtable-empty? (alist->eq-hashtable '((a . b))))))) - (test-group "pop!" - (test-error (hashtable-pop! (make-eq-hashtable))) - (let ((table (alist->eq-hashtable '((a . b))))) - (let-values (((k v) (hashtable-pop! table))) - (test-eq 'a k) - (test-eq 'b v) - (test-assert (hashtable-empty? table))))) - (test-group "inc!" - (let ((table (alist->eq-hashtable '((a . 0))))) - (hashtable-inc! table 'a) - (test-eqv 1 (hashtable-ref table 'a)) - (hashtable-inc! table 'a 2) - (test-eqv 3 (hashtable-ref table 'a)))) - (test-group "dec!" - (let ((table (alist->eq-hashtable '((a . 0))))) - (hashtable-dec! table 'a) - (test-eqv -1 (hashtable-ref table 'a)) - (hashtable-dec! table 'a 2) - (test-eqv -3 (hashtable-ref table 'a))))))) - -(test-group "hashing" - (test-assert (and (exact-integer? (hash-salt)))) - (test-assert (not (negative? (hash-salt)))) - (test-assert (= (equal-hash (list "foo" 'bar 42)) - (equal-hash (list "foo" 'bar 42)))) - (test-assert (= (string-hash (string-copy "foo")) - (string-hash (string-copy "foo")))) - (test-assert (= (string-ci-hash (string-copy "foo")) - (string-ci-hash (string-copy "FOO")))) - (test-assert (= (symbol-hash (string->symbol "foo")) - (symbol-hash (string->symbol "foo"))))) - -(test-end "SRFI-126") - -(display - (string-append - "\n" - "NOTE: On implementations using the (r6rs hashtables) library from Larceny,\n" - " 14 tests are expected to fail in relation to make-eq-hashtable and\n" - " make-eqv-hashtable returning hashtables whose hash functions are\n" - " exposed instead of being #f. We have no obvious way to detect this\n" - " within this portable test suite, hence no XFAIL results.\n")) - -;; Local Variables: -;; eval: (put (quote test-group) (quote scheme-indent-function) 1) -;; End: -(import - (scheme base) - (scheme write) - (srfi 1) - (srfi 64) - (srfi 126)) - -;; INCLUDE test-suite.body.scm -;;; This doesn't test weakness, external representation, and quasiquote. - -(test-begin "SRFI-126") - -(test-group "constructors & inspection" - (test-group "eq" - (let ((tables (list (make-eq-hashtable) - (make-eq-hashtable 10) - (make-eq-hashtable #f #f) - (make-hashtable #f eq?) - (alist->eq-hashtable '((a . b) (c . d))) - (alist->eq-hashtable 10 '((a . b) (c . d))) - (alist->eq-hashtable #f #f '((a . b) (c . d)))))) - (do ((tables tables (cdr tables)) - (i 0 (+ i 1))) - ((null? tables)) - (let ((table (car tables)) - (label (number->string i))) - (test-assert label (hashtable? table)) - (test-eq label #f (hashtable-hash-function table)) - (test-eq label eq? (hashtable-equivalence-function table)) - (test-eq label #f (hashtable-weakness table)) - (test-assert label (hashtable-mutable? table)))))) - (test-group "eqv" - (let ((tables (list (make-eqv-hashtable) - (make-eqv-hashtable 10) - (make-eqv-hashtable #f #f) - (make-hashtable #f eqv?) - (alist->eqv-hashtable '((a . b) (c . d))) - (alist->eqv-hashtable 10 '((a . b) (c . d))) - (alist->eqv-hashtable #f #f '((a . b) (c . d)))))) - (do ((tables tables (cdr tables)) - (i 0 (+ i 1))) - ((null? tables)) - (let ((table (car tables)) - (label (number->string i))) - (test-assert label (hashtable? table)) - (test-eq label #f (hashtable-hash-function table)) - (test-eq label eqv? (hashtable-equivalence-function table)) - (test-eq label #f (hashtable-weakness table)) - (test-assert label (hashtable-mutable? table)))))) - (test-group "equal" - (let ((tables (list (make-hashtable equal-hash equal?) - (make-hashtable equal-hash equal? 10) - (make-hashtable equal-hash equal? #f #f) - (alist->hashtable equal-hash equal? - '((a . b) (c . d))) - (alist->hashtable equal-hash equal? 10 - '((a . b) (c . d))) - (alist->hashtable equal-hash equal? #f #f - '((a . b) (c . d)))))) - (do ((tables tables (cdr tables)) - (i 0 (+ i 1))) - ((null? tables)) - (let ((table (car tables)) - (label (number->string i))) - (test-assert label (hashtable? table)) - (test-eq label equal-hash (hashtable-hash-function table)) - (test-eq label equal? (hashtable-equivalence-function table)) - (test-eq label #f (hashtable-weakness table)) - (test-assert label (hashtable-mutable? table)))) - (let ((table (make-hashtable (cons equal-hash equal-hash) equal?))) - (let ((hash (hashtable-hash-function table))) - (test-assert (or (eq? equal-hash hash) - (and (eq? equal-hash (car hash)) - (eq? equal-hash (cdr hash))))))))) - (test-group "alist" - (let ((tables (list (alist->eq-hashtable '((a . b) (a . c))) - (alist->eqv-hashtable '((a . b) (a . c))) - (alist->hashtable equal-hash equal? - '((a . b) (a . c)))))) - (do ((tables tables (cdr tables)) - (i 0 (+ i 1))) - ((null? tables)) - (let ((table (car tables)) - (label (number->string i))) - (test-eq label 'b (hashtable-ref table 'a))))))) - -(test-group "procedures" - (test-group "basics" - (let ((table (make-eq-hashtable))) - (test-group "ref" - (test-error (hashtable-ref table 'a)) - (test-eq 'b (hashtable-ref table 'a 'b)) - (test-assert (not (hashtable-contains? table 'a))) - (test-eqv 0 (hashtable-size table))) - (test-group "set" - (hashtable-set! table 'a 'c) - (test-eq 'c (hashtable-ref table 'a)) - (test-eq 'c (hashtable-ref table 'a 'b)) - (test-assert (hashtable-contains? table 'a)) - (test-eqv 1 (hashtable-size table))) - (test-group "delete" - (hashtable-delete! table 'a) - (test-error (hashtable-ref table 'a)) - (test-eq 'b (hashtable-ref table 'a 'b)) - (test-assert (not (hashtable-contains? table 'a))) - (test-eqv 0 (hashtable-size table))))) - (test-group "advanced" - (let ((table (make-eq-hashtable))) - (test-group "lookup" - (let-values (((x found?) (hashtable-lookup table 'a))) - (test-assert (not found?)))) - (test-group "update" - (test-error (hashtable-update! table 'a (lambda (x) (+ x 1)))) - (hashtable-update! table 'a (lambda (x) (+ x 1)) 0) - (let-values (((x found?) (hashtable-lookup table 'a))) - (test-eqv 1 x) - (test-assert found?)) - (hashtable-update! table 'a (lambda (x) (+ x 1))) - (let-values (((x found?) (hashtable-lookup table 'a))) - (test-eqv x 2) - (test-assert found?)) - (hashtable-update! table 'a (lambda (x) (+ x 1)) 0) - (let-values (((x found?) (hashtable-lookup table 'a))) - (test-eqv x 3) - (test-assert found?))) - (test-group "intern" - (test-eqv 0 (hashtable-intern! table 'b (lambda () 0))) - (test-eqv 0 (hashtable-intern! table 'b (lambda () 1)))))) - (test-group "copy/clear" - (let ((table (alist->hashtable equal-hash equal? '((a . b))))) - (test-group "copy" - (let ((table2 (hashtable-copy table))) - (test-eq equal-hash (hashtable-hash-function table2)) - (test-eq equal? (hashtable-equivalence-function table2)) - (test-eq 'b (hashtable-ref table2 'a)) - (test-error (hashtable-set! table2 'a 'c))) - (let ((table2 (hashtable-copy table #f))) - (test-eq equal-hash (hashtable-hash-function table2)) - (test-eq equal? (hashtable-equivalence-function table2)) - (test-eq 'b (hashtable-ref table2 'a)) - (test-error (hashtable-set! table2 'a 'c))) - (let ((table2 (hashtable-copy table #t))) - (test-eq equal-hash (hashtable-hash-function table2)) - (test-eq equal? (hashtable-equivalence-function table2)) - (test-eq 'b (hashtable-ref table2 'a)) - (hashtable-set! table2 'a 'c) - (test-eq 'c (hashtable-ref table2 'a))) - (let ((table2 (hashtable-copy table #f #f))) - (test-eq equal-hash (hashtable-hash-function table2)) - (test-eq equal? (hashtable-equivalence-function table2)) - (test-eq #f (hashtable-weakness table2)))) - (test-group "clear" - (let ((table2 (hashtable-copy table #t))) - (hashtable-clear! table2) - (test-eqv 0 (hashtable-size table2))) - (let ((table2 (hashtable-copy table #t))) - (hashtable-clear! table2 10) - (test-eqv 0 (hashtable-size table2)))) - (test-group "empty-copy" - (let ((table2 (hashtable-empty-copy table))) - (test-eq equal-hash (hashtable-hash-function table2)) - (test-eq equal? (hashtable-equivalence-function table2)) - (test-eqv 0 (hashtable-size table2))) - (let ((table2 (hashtable-empty-copy table 10))) - (test-eq equal-hash (hashtable-hash-function table2)) - (test-eq equal? (hashtable-equivalence-function table2)) - (test-eqv 0 (hashtable-size table2)))))) - (test-group "keys/values" - (let ((table (alist->eq-hashtable '((a . b) (c . d))))) - (test-assert (lset= eq? '(a c) (vector->list (hashtable-keys table)))) - (test-assert (lset= eq? '(b d) (vector->list (hashtable-values table)))) - (let-values (((keys values) (hashtable-entries table))) - (test-assert (lset= eq? '(a c) (vector->list keys))) - (test-assert (lset= eq? '(b d) (vector->list values)))) - (test-assert (lset= eq? '(a c) (hashtable-key-list table))) - (test-assert (lset= eq? '(b d) (hashtable-value-list table))) - (let-values (((keys values) (hashtable-entry-lists table))) - (test-assert (lset= eq? '(a c) keys)) - (test-assert (lset= eq? '(b d) values))))) - (test-group "iteration" - (test-group "walk" - (let ((keys '()) - (values '())) - (hashtable-walk (alist->eq-hashtable '((a . b) (c . d))) - (lambda (k v) - (set! keys (cons k keys)) - (set! values (cons v values)))) - (test-assert (lset= eq? '(a c) keys)) - (test-assert (lset= eq? '(b d) values)))) - (test-group "update-all" - (let ((table (alist->eq-hashtable '((a . b) (c . d))))) - (hashtable-update-all! table - (lambda (k v) - (string->symbol (string-append (symbol->string v) "x")))) - (test-assert (lset= eq? '(a c) (hashtable-key-list table))) - (test-assert (lset= eq? '(bx dx) (hashtable-value-list table))))) - (test-group "prune" - (let ((table (alist->eq-hashtable '((a . b) (c . d))))) - (hashtable-prune! table (lambda (k v) (eq? k 'a))) - (test-assert (not (hashtable-contains? table 'a))) - (test-assert (hashtable-contains? table 'c)))) - (test-group "merge" - (let ((table (alist->eq-hashtable '((a . b) (c . d)))) - (table2 (alist->eq-hashtable '((a . x) (e . f))))) - (hashtable-merge! table table2) - (test-assert (lset= eq? '(a c e) (hashtable-key-list table))) - (test-assert (lset= eq? '(x d f) (hashtable-value-list table))))) - (test-group "sum" - (let ((table (alist->eq-hashtable '((a . b) (c . d))))) - (test-assert (lset= eq? '(a b c d) - (hashtable-sum table '() - (lambda (k v acc) - (lset-adjoin eq? acc k v))))))) - (test-group "map->lset" - (let ((table (alist->eq-hashtable '((a . b) (c . d))))) - (test-assert (lset= equal? '((a . b) (c . d)) - (hashtable-map->lset table cons))))) - (test-group "find" - (let ((table (alist->eq-hashtable '((a . b) (c . d))))) - (let-values (((k v f?) (hashtable-find table - (lambda (k v) - (eq? k 'a))))) - (test-assert (and f? (eq? k 'a) (eq? v 'b)))) - (let-values (((k v f?) (hashtable-find table (lambda (k v) #f)))) - (test-assert (not f?))))) - (test-group "misc" - (test-group "empty?" - (test-assert (hashtable-empty? (alist->eq-hashtable '()))) - (test-assert (not (hashtable-empty? (alist->eq-hashtable '((a . b))))))) - (test-group "pop!" - (test-error (hashtable-pop! (make-eq-hashtable))) - (let ((table (alist->eq-hashtable '((a . b))))) - (let-values (((k v) (hashtable-pop! table))) - (test-eq 'a k) - (test-eq 'b v) - (test-assert (hashtable-empty? table))))) - (test-group "inc!" - (let ((table (alist->eq-hashtable '((a . 0))))) - (hashtable-inc! table 'a) - (test-eqv 1 (hashtable-ref table 'a)) - (hashtable-inc! table 'a 2) - (test-eqv 3 (hashtable-ref table 'a)))) - (test-group "dec!" - (let ((table (alist->eq-hashtable '((a . 0))))) - (hashtable-dec! table 'a) - (test-eqv -1 (hashtable-ref table 'a)) - (hashtable-dec! table 'a 2) - (test-eqv -3 (hashtable-ref table 'a))))))) - -(test-group "hashing" - (test-assert (and (exact-integer? (hash-salt)))) - (test-assert (not (negative? (hash-salt)))) - (test-assert (= (equal-hash (list "foo" 'bar 42)) - (equal-hash (list "foo" 'bar 42)))) - (test-assert (= (string-hash (string-copy "foo")) - (string-hash (string-copy "foo")))) - (test-assert (= (string-ci-hash (string-copy "foo")) - (string-ci-hash (string-copy "FOO")))) - (test-assert (= (symbol-hash (string->symbol "foo")) - (symbol-hash (string->symbol "foo"))))) - -(test-end "SRFI-126") - -(display - (string-append - "\n" - "NOTE: On implementations using the (r6rs hashtables) library from Larceny,\n" - " 14 tests are expected to fail in relation to make-eq-hashtable and\n" - " make-eqv-hashtable returning hashtables whose hash functions are\n" - " exposed instead of being #f. We have no obvious way to detect this\n" - " within this portable test suite, hence no XFAIL results.\n")) - -;; Local Variables: -;; eval: (put (quote test-group) (quote scheme-indent-function) 1) -;; End: -;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner -;; Added "full" support for Chicken, Gauche, Guile and SISC. -;; Alex Shinn, Copyright (c) 2005. -;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012. -;; Support for Guile 2 by Mark H Weaver , Copyright (c) 2014. -;; Refactored by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014, 2015. -;; -;; Permission is hereby granted, free of charge, to any person -;; obtaining a copy of this software and associated documentation -;; files (the "Software"), to deal in the Software without -;; restriction, including without limitation the rights to use, copy, -;; modify, merge, publish, distribute, sublicense, and/or sell copies -;; of the Software, and to permit persons to whom the Software is -;; furnished to do so, subject to the following conditions: -;; -;; The above copyright notice and this permission notice shall be -;; included in all copies or substantial portions of the Software. -;; -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -;; SOFTWARE. - -;;; Note: to prevent producing massive amounts of code from the macro-expand -;;; phase (which makes compile times suffer and may hit code size limits in some -;;; systems), keep macro bodies minimal by delegating work to procedures. - - -;;; Grouping - -(define (maybe-install-default-runner suite-name) - (when (not (test-runner-current)) - (let* ((log-file (string-append suite-name ".srfi64.log")) - (runner (test-runner-simple log-file))) - (%test-runner-auto-installed! runner #t) - (test-runner-current runner)))) - -(define (maybe-uninstall-default-runner) - (when (%test-runner-auto-installed? (test-runner-current)) - (test-runner-current #f))) - -(define test-begin - (case-lambda - ((name) - (test-begin name #f)) - ((name count) - (maybe-install-default-runner name) - (let ((r (test-runner-current))) - (let ((skip-list (%test-runner-skip-list r)) - (skip-save (%test-runner-skip-save r)) - (fail-list (%test-runner-fail-list r)) - (fail-save (%test-runner-fail-save r)) - (total-count (%test-runner-total-count r)) - (count-list (%test-runner-count-list r)) - (group-stack (test-runner-group-stack r))) - ((test-runner-on-group-begin r) r name count) - (%test-runner-skip-save! r (cons skip-list skip-save)) - (%test-runner-fail-save! r (cons fail-list fail-save)) - (%test-runner-count-list! r (cons (cons total-count count) - count-list)) - (test-runner-group-stack! r (cons name group-stack))))))) - -(define test-end - (case-lambda - (() - (test-end #f)) - ((name) - (let* ((r (test-runner-get)) - (groups (test-runner-group-stack r))) - (test-result-clear r) - (when (null? groups) - (error "test-end not in a group")) - (when (and name (not (equal? name (car groups)))) - ((test-runner-on-bad-end-name r) r name (car groups))) - (let* ((count-list (%test-runner-count-list r)) - (expected-count (cdar count-list)) - (saved-count (caar count-list)) - (group-count (- (%test-runner-total-count r) saved-count))) - (when (and expected-count - (not (= expected-count group-count))) - ((test-runner-on-bad-count r) r group-count expected-count)) - ((test-runner-on-group-end r) r) - (test-runner-group-stack! r (cdr (test-runner-group-stack r))) - (%test-runner-skip-list! r (car (%test-runner-skip-save r))) - (%test-runner-skip-save! r (cdr (%test-runner-skip-save r))) - (%test-runner-fail-list! r (car (%test-runner-fail-save r))) - (%test-runner-fail-save! r (cdr (%test-runner-fail-save r))) - (%test-runner-count-list! r (cdr count-list)) - (when (null? (test-runner-group-stack r)) - ((test-runner-on-final r) r) - (maybe-uninstall-default-runner))))))) - -(define-syntax test-group - (syntax-rules () - ((_ . *) - (%test-group (lambda () . *))))) - -(define (%test-group name thunk) - (begin - (maybe-install-default-runner name) - (let ((runner (test-runner-get))) - (test-result-clear runner) - (test-result-set! runner 'name name) - (unless (test-skip? runner) - (dynamic-wind - (lambda () (test-begin name)) - thunk - (lambda () (test-end name))))))) - -(define-syntax test-group-with-cleanup - (syntax-rules () - ((_ * ... ) - (test-group - (dynamic-wind (lambda () #f) - (lambda () * ...) - (lambda () )))))) - - -;;; Skipping, expected-failing, matching - -(define (test-skip . specs) - (let ((runner (test-runner-get))) - (%test-runner-skip-list! - runner (cons (apply test-match-all specs) - (%test-runner-skip-list runner))))) - -(define (test-skip? runner) - (let ((run-list (%test-runner-run-list runner)) - (skip-list (%test-runner-skip-list runner))) - (or (and run-list (not (any-pred run-list runner))) - (any-pred skip-list runner)))) - -(define (test-expect-fail . specs) - (let ((runner (test-runner-get))) - (%test-runner-fail-list! - runner (cons (apply test-match-all specs) - (%test-runner-fail-list runner))))) - -(define (test-match-any . specs) - (let ((preds (map make-pred specs))) - (lambda (runner) - (any-pred preds runner)))) - -(define (test-match-all . specs) - (let ((preds (map make-pred specs))) - (lambda (runner) - (every-pred preds runner)))) - -(define (make-pred spec) - (cond - ((procedure? spec) - spec) - ((integer? spec) - (test-match-nth 1 spec)) - ((string? spec) - (test-match-name spec)) - (else - (error "not a valid test specifier" spec)))) - -(define test-match-nth - (case-lambda - ((n) (test-match-nth n 1)) - ((n count) - (let ((i 0)) - (lambda (runner) - (set! i (+ i 1)) - (and (>= i n) (< i (+ n count)))))))) - -(define (test-match-name name) - (lambda (runner) - (equal? name (test-runner-test-name runner)))) - -;;; Beware: all predicates must be called because they might have side-effects; -;;; no early returning or and/or short-circuiting of procedure calls allowed. - -(define (any-pred preds object) - (let loop ((matched? #f) - (preds preds)) - (if (null? preds) - matched? - (let ((result ((car preds) object))) - (loop (or matched? result) - (cdr preds)))))) - -(define (every-pred preds object) - (let loop ((failed? #f) - (preds preds)) - (if (null? preds) - (not failed?) - (let ((result ((car preds) object))) - (loop (or failed? (not result)) - (cdr preds)))))) - -;;; Actual testing - -(define-syntax false-if-error - (syntax-rules () - ((_ ) - (guard (error - (else - (test-result-set! 'actual-error error) - #f)) - )))) - -(define (test-prelude source-info runner name form) - (test-result-clear runner) - (set-source-info! runner source-info) - (when name - (test-result-set! runner 'name name)) - (test-result-set! runner 'source-form form) - (let ((skip? (test-skip? runner))) - (if skip? - (test-result-set! runner 'result-kind 'skip) - (let ((fail-list (%test-runner-fail-list runner))) - (when (any-pred fail-list runner) - ;; For later inspection only. - (test-result-set! runner 'result-kind 'xfail)))) - ((test-runner-on-test-begin runner) runner) - (not skip?))) - -(define (test-postlude runner) - (let ((result-kind (test-result-kind runner))) - (case result-kind - ((pass) - (test-runner-pass-count! runner (+ 1 (test-runner-pass-count runner)))) - ((fail) - (test-runner-fail-count! runner (+ 1 (test-runner-fail-count runner)))) - ((xpass) - (test-runner-xpass-count! runner (+ 1 (test-runner-xpass-count runner)))) - ((xfail) - (test-runner-xfail-count! runner (+ 1 (test-runner-xfail-count runner)))) - ((skip) - (test-runner-skip-count! runner (+ 1 (test-runner-skip-count runner))))) - (%test-runner-total-count! runner (+ 1 (%test-runner-total-count runner))) - ((test-runner-on-test-end runner) runner))) - -(define (set-result-kind! runner pass?) - (test-result-set! runner 'result-kind - (if (eq? (test-result-kind runner) 'xfail) - (if pass? 'xpass 'xfail) - (if pass? 'pass 'fail)))) - -;;; We need to use some trickery to get the source info right. The important -;;; thing is to pass a syntax object that is a pair to `source-info', and make -;;; sure this syntax object comes from user code and not from ourselves. - -(define-syntax test-assert - (syntax-rules () - ((_ . ) - (test-assert/source-info (source-info ) . )))) - -(define-syntax test-assert/source-info - (syntax-rules () - ((_ ) - (test-assert/source-info #f )) - ((_ ) - (%test-assert ' (lambda () ))))) - -(define (%test-assert source-info name form thunk) - (let ((runner (test-runner-get))) - (when (test-prelude source-info runner name form) - (let ((val (false-if-error (thunk) runner))) - (test-result-set! runner 'actual-value val) - (set-result-kind! runner val))) - (test-postlude runner))) - -(define-syntax test-compare - (syntax-rules () - ((_ . ) - (test-compare/source-info (source-info ) . )))) - -(define-syntax test-compare/source-info - (syntax-rules () - ((_ ) - (test-compare/source-info #f )) - ((_ ) - (%test-compare ' - (lambda () ))))) - -(define (%test-compare source-info compare name expected form thunk) - (let ((runner (test-runner-get))) - (when (test-prelude source-info runner name form) - (test-result-set! runner 'expected-value expected) - (let ((pass? (false-if-error - (let ((val (thunk))) - (test-result-set! runner 'actual-value val) - (compare expected val)) - runner))) - (set-result-kind! runner pass?))) - (test-postlude runner))) - -(define-syntax test-equal - (syntax-rules () - ((_ . ) - (test-compare/source-info (source-info ) equal? . )))) - -(define-syntax test-eqv - (syntax-rules () - ((_ . ) - (test-compare/source-info (source-info ) eqv? . )))) - -(define-syntax test-eq - (syntax-rules () - ((_ . ) - (test-compare/source-info (source-info ) eq? . )))) - -(define (approx= margin) - (lambda (value expected) - (let ((rval (real-part value)) - (ival (imag-part value)) - (rexp (real-part expected)) - (iexp (imag-part expected))) - (and (>= rval (- rexp margin)) - (>= ival (- iexp margin)) - (<= rval (+ rexp margin)) - (<= ival (+ iexp margin)))))) - -(define-syntax test-approximate - (syntax-rules () - ((_ . ) - (test-approximate/source-info (source-info ) . )))) - -(define-syntax test-approximate/source-info - (syntax-rules () - ((_ ) - (test-approximate/source-info - #f )) - ((_ ) - (test-compare/source-info - (approx= ) )))) - -(define (error-matches? error type) - (cond - ((eq? type #t) - #t) - ((condition-type? type) - (and (condition? error) (condition-has-type? error type))) - ((procedure? type) - (type error)) - (else - (let ((runner (test-runner-get))) - ((%test-runner-on-bad-error-type runner) runner type error)) - #f))) - -(define-syntax test-error - (syntax-rules () - ((_ . ) - (test-error/source-info (source-info ) . )))) - -(define-syntax test-error/source-info - (syntax-rules () - ((_ ) - (test-error/source-info #f #t )) - ((_ ) - (test-error/source-info #f )) - ((_ ) - (%test-error ' - (lambda () ))))) - -(define (%test-error source-info name error-type form thunk) - (let ((runner (test-runner-get))) - (when (test-prelude source-info runner name form) - (test-result-set! runner 'expected-error error-type) - (let ((pass? (guard (error (else (test-result-set! - runner 'actual-error error) - (error-matches? error error-type))) - (let ((val (thunk))) - (test-result-set! runner 'actual-value val)) - #f))) - (set-result-kind! runner pass?))) - (test-postlude runner))) - -(define (default-module) - (cond-expand - (guile (current-module)) - (else #f))) - -(define test-read-eval-string - (case-lambda - ((string) - (test-read-eval-string string (default-module))) - ((string env) - (let* ((port (open-input-string string)) - (form (read port))) - (if (eof-object? (read-char port)) - (if env - (eval form env) - (eval form)) - (error "(not at eof)")))))) - - -;;; Test runner control flow - -(define-syntax test-with-runner - (syntax-rules () - ((_ . *) - (let ((saved-runner (test-runner-current))) - (dynamic-wind - (lambda () (test-runner-current )) - (lambda () . *) - (lambda () (test-runner-current saved-runner))))))) - -(define (test-apply first . rest) - (let ((runner (if (test-runner? first) - first - (or (test-runner-current) (test-runner-create)))) - (run-list (if (test-runner? first) - (drop-right rest 1) - (cons first (drop-right rest 1)))) - (proc (last rest))) - (test-with-runner runner - (let ((saved-run-list (%test-runner-run-list runner))) - (%test-runner-run-list! runner run-list) - (proc) - (%test-runner-run-list! runner saved-run-list))))) - - -;;; Indicate success/failure via exit status - -(define (test-exit) - (let ((runner (test-runner-current))) - (when (not runner) - (error "No test runner installed. Might have been auto-removed -by test-end if you had not installed one explicitly.")) - (if (and (zero? (test-runner-xpass-count runner)) - (zero? (test-runner-fail-count runner))) - (exit 0) - (exit 1)))) - -;;; execution.scm ends here -;; Copyright (c) 2015 Taylan Ulrich Bayırlı/Kammer -;; -;; Permission is hereby granted, free of charge, to any person -;; obtaining a copy of this software and associated documentation -;; files (the "Software"), to deal in the Software without -;; restriction, including without limitation the rights to use, copy, -;; modify, merge, publish, distribute, sublicense, and/or sell copies -;; of the Software, and to permit persons to whom the Software is -;; furnished to do so, subject to the following conditions: -;; -;; The above copyright notice and this permission notice shall be -;; included in all copies or substantial portions of the Software. -;; -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -;; SOFTWARE. - -;;; In some systems, a macro use like (source-info ...), that resides in a -;;; syntax-rules macro body, first gets inserted into the place where the -;;; syntax-rules macro was used, and then the transformer of 'source-info' is -;;; called with a syntax object that has the source location information of that -;;; position. That works fine when the user calls e.g. (test-assert ...), whose -;;; body contains (source-info ...); the user gets the source location of the -;;; (test-assert ...) call as intended, and not the source location of the real -;;; (source-info ...) call. - -;;; In other systems, *first* the (source-info ...) is processed to get its real -;;; position, which is within the body of a syntax-rules macro like test-assert, -;;; so no matter where the user calls (test-assert ...), they get source -;;; location information of where we defined test-assert with the call to -;;; (source-info ...) in its body. That's arguably more correct behavior, -;;; although in this case it makes our job a bit harder; we need to get the -;;; source location from an argument to 'source-info' instead. - -(define (canonical-syntax form arg) - (cond-expand - (kawa arg) - (guile-2 form) - (else #f))) - -(cond-expand - ((or kawa guile-2) - (define-syntax source-info - (lambda (stx) - (syntax-case stx () - ((_ ) - (let* ((stx (canonical-syntax stx (syntax ))) - (file (syntax-source-file stx)) - (line (syntax-source-line stx))) - (quasisyntax - (cons (unsyntax file) (unsyntax line))))))))) - (else - (define-syntax source-info - (syntax-rules () - ((_ ) - #f))))) - -(define (syntax-source-file stx) - (cond-expand - (kawa - (syntax-source stx)) - (guile-2 - (let ((source (syntax-source stx))) - (and source (assq-ref source 'filename)))) - (else - #f))) - -(define (syntax-source-line stx) - (cond-expand - (kawa - (syntax-line stx)) - (guile-2 - (let ((source (syntax-source stx))) - (and source (assq-ref source 'line)))) - (else - #f))) - -(define (set-source-info! runner source-info) - (when source-info - (test-result-set! runner 'source-file (car source-info)) - (test-result-set! runner 'source-line (cdr source-info)))) - -;;; source-info.body.scm ends here -;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner -;; Added "full" support for Chicken, Gauche, Guile and SISC. -;; Alex Shinn, Copyright (c) 2005. -;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012. -;; Support for Guile 2 by Mark H Weaver , Copyright (c) 2014. -;; Refactored by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014, 2015. -;; -;; Permission is hereby granted, free of charge, to any person -;; obtaining a copy of this software and associated documentation -;; files (the "Software"), to deal in the Software without -;; restriction, including without limitation the rights to use, copy, -;; modify, merge, publish, distribute, sublicense, and/or sell copies -;; of the Software, and to permit persons to whom the Software is -;; furnished to do so, subject to the following conditions: -;; -;; The above copyright notice and this permission notice shall be -;; included in all copies or substantial portions of the Software. -;; -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -;; SOFTWARE. - -;;; Helpers - -(define (string-join strings delimiter) - (if (null? strings) - "" - (let loop ((result (car strings)) - (rest (cdr strings))) - (if (null? rest) - result - (loop (string-append result delimiter (car rest)) - (cdr rest)))))) - -(define (truncate-string string length) - (define (newline->space c) (if (char=? #\newline c) #\space c)) - (let* ((string (string-map newline->space string)) - (fill "...") - (fill-len (string-length fill)) - (string-len (string-length string))) - (if (<= string-len (+ length fill-len)) - string - (let-values (((q r) (floor/ length 4))) - ;; Left part gets 3/4 plus the remainder. - (let ((left-end (+ (* q 3) r)) - (right-start (- string-len q))) - (string-append (substring string 0 left-end) - fill - (substring string right-start string-len))))))) - -(define (print runner format-string . args) - (apply format #t format-string args) - (let ((port (%test-runner-log-port runner))) - (when port - (apply format port format-string args)))) - -;;; Main - -(define test-runner-simple - (case-lambda - (() - (test-runner-simple #f)) - ((log-file) - (let ((runner (test-runner-null))) - (test-runner-reset runner) - (test-runner-on-group-begin! runner test-on-group-begin-simple) - (test-runner-on-group-end! runner test-on-group-end-simple) - (test-runner-on-final! runner test-on-final-simple) - (test-runner-on-test-begin! runner test-on-test-begin-simple) - (test-runner-on-test-end! runner test-on-test-end-simple) - (test-runner-on-bad-count! runner test-on-bad-count-simple) - (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple) - (%test-runner-on-bad-error-type! runner on-bad-error-type) - (%test-runner-log-file! runner log-file) - runner)))) - -(when (not (test-runner-factory)) - (test-runner-factory test-runner-simple)) - -(define (test-on-group-begin-simple runner name count) - (when (null? (test-runner-group-stack runner)) - (maybe-start-logging runner) - (print runner "Test suite begin: ~a~%" name))) - -(define (test-on-group-end-simple runner) - (let ((name (car (test-runner-group-stack runner)))) - (when (= 1 (length (test-runner-group-stack runner))) - (print runner "Test suite end: ~a~%" name)))) - -(define (test-on-final-simple runner) - (print runner "Passes: ~a\n" (test-runner-pass-count runner)) - (print runner "Expected failures: ~a\n" (test-runner-xfail-count runner)) - (print runner "Failures: ~a\n" (test-runner-fail-count runner)) - (print runner "Unexpected passes: ~a\n" (test-runner-xpass-count runner)) - (print runner "Skipped tests: ~a~%" (test-runner-skip-count runner)) - (maybe-finish-logging runner)) - -(define (maybe-start-logging runner) - (let ((log-file (%test-runner-log-file runner))) - (when log-file - ;; The possible race-condition here doesn't bother us. - (when (file-exists? log-file) - (delete-file log-file)) - (%test-runner-log-port! runner (open-output-file log-file)) - (print runner "Writing log file: ~a~%" log-file)))) - -(define (maybe-finish-logging runner) - (let ((log-file (%test-runner-log-file runner))) - (when log-file - (print runner "Wrote log file: ~a~%" log-file) - (close-output-port (%test-runner-log-port runner))))) - -(define (test-on-test-begin-simple runner) - (values)) - -(define (test-on-test-end-simple runner) - (let* ((result-kind (test-result-kind runner)) - (result-kind-name (case result-kind - ((pass) "PASS") ((fail) "FAIL") - ((xpass) "XPASS") ((xfail) "XFAIL") - ((skip) "SKIP"))) - (name (let ((name (test-runner-test-name runner))) - (if (string=? "" name) - (truncate-string - (format #f "~a" (test-result-ref runner 'source-form)) - 30) - name))) - (label (string-join (append (test-runner-group-path runner) - (list name)) - ": "))) - (print runner "[~a] ~a~%" result-kind-name label) - (when (memq result-kind '(fail xpass)) - (let ((nil (cons #f #f))) - (define (found? value) - (not (eq? nil value))) - (define (maybe-print value message) - (when (found? value) - (print runner message value))) - (let ((file (test-result-ref runner 'source-file "(unknown file)")) - (line (test-result-ref runner 'source-line "(unknown line)")) - (expression (test-result-ref runner 'source-form)) - (expected-value (test-result-ref runner 'expected-value nil)) - (actual-value (test-result-ref runner 'actual-value nil)) - (expected-error (test-result-ref runner 'expected-error nil)) - (actual-error (test-result-ref runner 'actual-error nil))) - (print runner "~a:~a: ~s~%" file line expression) - (maybe-print expected-value "Expected value: ~s~%") - (maybe-print expected-error "Expected error: ~a~%") - (when (or (found? expected-value) (found? expected-error)) - (maybe-print actual-value "Returned value: ~s~%")) - (maybe-print actual-error "Raised error: ~a~%") - (newline)))))) - -(define (test-on-bad-count-simple runner count expected-count) - (print runner "*** Total number of tests was ~a but should be ~a. ***~%" - count expected-count) - (print runner - "*** Discrepancy indicates testsuite error or exceptions. ***~%")) - -(define (test-on-bad-end-name-simple runner begin-name end-name) - (error (format #f "Test-end \"~a\" does not match test-begin \"~a\"." - end-name begin-name))) - -(define (on-bad-error-type runner type error) - (print runner "WARNING: unknown error type predicate: ~a~%" type) - (print runner " error was: ~a~%" error)) - -;;; test-runner-simple.scm ends here -;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner -;; Added "full" support for Chicken, Gauche, Guile and SISC. -;; Alex Shinn, Copyright (c) 2005. -;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012. -;; Support for Guile 2 by Mark H Weaver , Copyright (c) 2014. -;; Refactored by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014, 2015. -;; -;; Permission is hereby granted, free of charge, to any person -;; obtaining a copy of this software and associated documentation -;; files (the "Software"), to deal in the Software without -;; restriction, including without limitation the rights to use, copy, -;; modify, merge, publish, distribute, sublicense, and/or sell copies -;; of the Software, and to permit persons to whom the Software is -;; furnished to do so, subject to the following conditions: -;; -;; The above copyright notice and this permission notice shall be -;; included in all copies or substantial portions of the Software. -;; -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -;; SOFTWARE. - - -;;; The data type - -(define-record-type - (make-test-runner) test-runner? - - (result-alist test-result-alist test-result-alist!) - - (pass-count test-runner-pass-count test-runner-pass-count!) - (fail-count test-runner-fail-count test-runner-fail-count!) - (xpass-count test-runner-xpass-count test-runner-xpass-count!) - (xfail-count test-runner-xfail-count test-runner-xfail-count!) - (skip-count test-runner-skip-count test-runner-skip-count!) - (total-count %test-runner-total-count %test-runner-total-count!) - - ;; Stack (list) of (count-at-start . expected-count): - (count-list %test-runner-count-list %test-runner-count-list!) - - ;; Normally #f, except when in a test-apply. - (run-list %test-runner-run-list %test-runner-run-list!) - - (skip-list %test-runner-skip-list %test-runner-skip-list!) - (fail-list %test-runner-fail-list %test-runner-fail-list!) - - (skip-save %test-runner-skip-save %test-runner-skip-save!) - (fail-save %test-runner-fail-save %test-runner-fail-save!) - - (group-stack test-runner-group-stack test-runner-group-stack!) - - ;; Note: on-test-begin and on-test-end are unrelated to the test-begin and - ;; test-end forms in the execution library. They're called at the - ;; beginning/end of each individual test, whereas the test-begin and test-end - ;; forms demarcate test groups. - - (on-group-begin test-runner-on-group-begin test-runner-on-group-begin!) - (on-test-begin test-runner-on-test-begin test-runner-on-test-begin!) - (on-test-end test-runner-on-test-end test-runner-on-test-end!) - (on-group-end test-runner-on-group-end test-runner-on-group-end!) - (on-final test-runner-on-final test-runner-on-final!) - (on-bad-count test-runner-on-bad-count test-runner-on-bad-count!) - (on-bad-end-name test-runner-on-bad-end-name test-runner-on-bad-end-name!) - - (on-bad-error-type %test-runner-on-bad-error-type - %test-runner-on-bad-error-type!) - - (aux-value test-runner-aux-value test-runner-aux-value!) - - (auto-installed %test-runner-auto-installed? %test-runner-auto-installed!) - - (log-file %test-runner-log-file %test-runner-log-file!) - (log-port %test-runner-log-port %test-runner-log-port!)) - -(define (test-runner-group-path runner) - (reverse (test-runner-group-stack runner))) - -(define (test-runner-reset runner) - (test-result-alist! runner '()) - (test-runner-pass-count! runner 0) - (test-runner-fail-count! runner 0) - (test-runner-xpass-count! runner 0) - (test-runner-xfail-count! runner 0) - (test-runner-skip-count! runner 0) - (%test-runner-total-count! runner 0) - (%test-runner-count-list! runner '()) - (%test-runner-run-list! runner #f) - (%test-runner-skip-list! runner '()) - (%test-runner-fail-list! runner '()) - (%test-runner-skip-save! runner '()) - (%test-runner-fail-save! runner '()) - (test-runner-group-stack! runner '())) - -(define (test-runner-null) - (define (test-null-callback . args) #f) - (let ((runner (make-test-runner))) - (test-runner-reset runner) - (test-runner-on-group-begin! runner test-null-callback) - (test-runner-on-group-end! runner test-null-callback) - (test-runner-on-final! runner test-null-callback) - (test-runner-on-test-begin! runner test-null-callback) - (test-runner-on-test-end! runner test-null-callback) - (test-runner-on-bad-count! runner test-null-callback) - (test-runner-on-bad-end-name! runner test-null-callback) - (%test-runner-on-bad-error-type! runner test-null-callback) - (%test-runner-auto-installed! runner #f) - (%test-runner-log-file! runner #f) - (%test-runner-log-port! runner #f) - runner)) - - -;;; State - -(define test-result-ref - (case-lambda - ((runner key) - (test-result-ref runner key #f)) - ((runner key default) - (let ((entry (assq key (test-result-alist runner)))) - (if entry (cdr entry) default))))) - -(define (test-result-set! runner key value) - (let* ((alist (test-result-alist runner)) - (entry (assq key alist))) - (if entry - (set-cdr! entry value) - (test-result-alist! runner (cons (cons key value) alist))))) - -(define (test-result-remove runner key) - (test-result-alist! runner (remove (lambda (entry) - (eq? key (car entry))) - (test-result-alist runner)))) - -(define (test-result-clear runner) - (test-result-alist! runner '())) - -(define (test-runner-test-name runner) - (or (test-result-ref runner 'name) "")) - -(define test-result-kind - (case-lambda - (() (test-result-kind (test-runner-get))) - ((runner) (test-result-ref runner 'result-kind)))) - -(define test-passed? - (case-lambda - (() (test-passed? (test-runner-get))) - ((runner) (memq (test-result-kind runner) '(pass xpass))))) - - -;;; Factory and current instance - -(define test-runner-factory (make-parameter #f)) - -(define (test-runner-create) ((test-runner-factory))) - -(define test-runner-current (make-parameter #f)) - -(define (test-runner-get) - (or (test-runner-current) - (error "test-runner not initialized - test-begin missing?"))) - -;;; test-runner.scm ends here -(define-module (srfi srfi-64) - #\export - (test-begin - test-end test-assert test-eqv test-eq test-equal - test-approximate test-assert test-error test-apply test-with-runner - test-match-nth test-match-all test-match-any test-match-name - test-skip test-expect-fail test-read-eval-string - test-runner-group-path test-group test-group-with-cleanup - test-exit - test-result-ref test-result-set! test-result-clear test-result-remove - test-result-kind test-passed? - test-runner? test-runner-reset test-runner-null - test-runner-simple test-runner-current test-runner-factory test-runner-get - test-runner-create test-runner-test-name - test-runner-pass-count test-runner-pass-count! - test-runner-fail-count test-runner-fail-count! - test-runner-xpass-count test-runner-xpass-count! - test-runner-xfail-count test-runner-xfail-count! - test-runner-skip-count test-runner-skip-count! - test-runner-group-stack test-runner-group-stack! - test-runner-on-test-begin test-runner-on-test-begin! - test-runner-on-test-end test-runner-on-test-end! - test-runner-on-group-begin test-runner-on-group-begin! - test-runner-on-group-end test-runner-on-group-end! - test-runner-on-final test-runner-on-final! - test-runner-on-bad-count test-runner-on-bad-count! - test-runner-on-bad-end-name test-runner-on-bad-end-name! - test-result-alist test-result-alist! - test-runner-aux-value test-runner-aux-value! - test-on-group-begin-simple test-on-group-end-simple - test-on-bad-count-simple test-on-bad-end-name-simple - test-on-final-simple test-on-test-end-simple - test-on-final-simple)) - -(cond-expand-provide (current-module) '(srfi-64)) - -(import - (only (rnrs exceptions) guard) - (srfi srfi-1) - (srfi srfi-9) - (srfi srfi-11) - (srfi srfi-35)) -(include-from-path "srfi/srfi-64/source-info.body.scm") -(include-from-path "srfi/srfi-64/test-runner.body.scm") -(include-from-path "srfi/srfi-64/test-runner-simple.body.scm") -(include-from-path "srfi/srfi-64/execution.body.scm") -(define-library (srfi-tests aux) - (export define-tests) - (import - (scheme base) - (scheme write) - (scheme case-lambda) - (srfi 64)) - (begin - (define-syntax define-tests - (syntax-rules () - ((_ proc-name suite-name form ...) - (define proc-name - (case-lambda - (() (proc-name (test-runner-create))) - ((runner) - (parameterize ((test-runner-current runner)) - (test-begin suite-name) - form ... - (test-end suite-name) - (and (= 0 (test-runner-xpass-count runner)) - (= 0 (test-runner-fail-count runner)))))))))) - )) -;; Copyright (C) Oleg Kiselyov (1998). All Rights Reserved. - -;; Made an R7RS library by Taylan Ulrich Bayırlı/Kammer, Copyright (C) 2014. - -;; Permission is hereby granted, free of charge, to any person obtaining a copy -;; of this software and associated documentation files (the "Software"), to deal -;; in the Software without restriction, including without limitation the rights -;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;; copies of the Software, and to permit persons to whom the Software is -;; furnished to do so, subject to the following conditions: - -;; The above copyright notice and this permission notice shall be included in -;; all copies or substantial portions of the Software. - -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -;; SOFTWARE. - -(define-library (srfi-tests srfi-2) - (export run-tests) - (import - (scheme base) - (scheme eval) - (srfi 2) - (srfi 64) - (srfi-tests aux)) - (begin - - (define (test-eval form) - (eval form (environment '(scheme base) '(srfi 2)))) - - ;; We want to check whether 'form' has indeed wrong syntax. We eval it and - ;; check for any exception, which is our best approximation. - (define-syntax test-syntax-error - (syntax-rules () - ((_ form) - (test-error (test-eval 'form))))) - - (define-tests run-tests "SRFI-2" - (test-equal 1 (and-let* () 1)) - (test-equal 2 (and-let* () 1 2)) - (test-equal #t (and-let* ())) - - (test-equal #f (let ((x #f)) (and-let* (x)))) - (test-equal 1 (let ((x 1)) (and-let* (x)))) - (test-equal #f (and-let* ((x #f)))) - (test-equal 1 (and-let* ((x 1)))) - (test-equal #f (and-let* ((#f) (x 1)))) - (test-equal 1 (and-let* ((2) (x 1)))) - ;; Gauche allows let-binding a constant, thus fails to signal an error on - ;; the following two tests. - (cond-expand - (gauche (test-expect-fail 2)) - (else)) - (test-syntax-error (and-let* (#f (x 1)))) - (test-syntax-error (and-let* (2 (x 1)))) - (test-equal 2 (and-let* ((x 1) (2)))) - (test-equal #f (let ((x #f)) (and-let* (x) x))) - (test-equal "" (let ((x "")) (and-let* (x) x))) - (test-equal "" (let ((x "")) (and-let* (x)))) - (test-equal 2 (let ((x 1)) (and-let* (x) (+ x 1)))) - (test-equal #f (let ((x #f)) (and-let* (x) (+ x 1)))) - (test-equal 2 (let ((x 1)) (and-let* (((positive? x))) (+ x 1)))) - (test-equal #t (let ((x 1)) (and-let* (((positive? x)))))) - (test-equal #f (let ((x 0)) (and-let* (((positive? x))) (+ x 1)))) - (test-equal 3 - (let ((x 1)) (and-let* (((positive? x)) (x (+ x 1))) (+ x 1)))) - ;; This is marked as must-be-error in the original test suite; see - ;; comments in the implementation for our rationale for intentionally - ;; breaking off from the specification. - (test-equal 4 - (let ((x 1)) - (and-let* (((positive? x)) (x (+ x 1)) (x (+ x 1))) (+ x 1)))) - - (test-equal 2 - (let ((x 1)) (and-let* (x ((positive? x))) (+ x 1)))) - (test-equal 2 - (let ((x 1)) (and-let* (((begin x)) ((positive? x))) (+ x 1)))) - (test-equal #f - (let ((x 0)) (and-let* (x ((positive? x))) (+ x 1)))) - (test-equal #f - (let ((x #f)) (and-let* (x ((positive? x))) (+ x 1)))) - (test-equal #f - (let ((x #f)) (and-let* (((begin x)) ((positive? x))) (+ x 1)))) - - (test-equal #f - (let ((x 1)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y)))) - (test-equal #f - (let ((x 0)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y)))) - (test-equal #f - (let ((x #f)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y)))) - (test-equal 3/2 - (let ((x 3)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))))) - - )) -(define-library (srfi-tests srfi-26) - (export run-tests) - (import - (scheme base) - (srfi 26) - (srfi 64) - (srfi-tests aux)) - (begin - (define-tests run-tests "SRFI-26" - ;; cut - (test-equal '() ((cut list))) - (test-equal '() ((cut list <___>))) - (test-equal '(1) ((cut list 1))) - (test-equal '(1) ((cut list <>) 1)) - (test-equal '(1) ((cut list <___>) 1)) - (test-equal '(1 2) ((cut list 1 2))) - (test-equal '(1 2) ((cut list 1 <>) 2)) - (test-equal '(1 2) ((cut list 1 <___>) 2)) - (test-equal '(1 2 3 4) ((cut list 1 <___>) 2 3 4)) - (test-equal '(1 2 3 4) ((cut list 1 <> 3 <>) 2 4)) - (test-equal '(1 2 3 4 5 6) ((cut list 1 <> 3 <___>) 2 4 5 6)) - (test-equal '(ok) (let* ((x 'wrong) (y (cut list x))) (set! x 'ok) (y))) - (test-equal 2 (let ((a 0)) - (map (cut + (begin (set! a (+ a 1)) a) <>) - '(1 2)) - a)) - ;; cute - (test-equal '() ((cute list))) - (test-equal '() ((cute list <___>))) - (test-equal '(1) ((cute list 1))) - (test-equal '(1) ((cute list <>) 1)) - (test-equal '(1) ((cute list <___>) 1)) - (test-equal '(1 2) ((cute list 1 2))) - (test-equal '(1 2) ((cute list 1 <>) 2)) - (test-equal '(1 2) ((cute list 1 <___>) 2)) - (test-equal '(1 2 3 4) ((cute list 1 <___>) 2 3 4)) - (test-equal '(1 2 3 4) ((cute list 1 <> 3 <>) 2 4)) - (test-equal '(1 2 3 4 5 6) ((cute list 1 <> 3 <___>) 2 4 5 6)) - (test-equal 1 (let ((a 0)) - (map (cute + (begin (set! a (+ a 1)) a) <>) - '(1 2)) - a))))) -(define-library (srfi-tests srfi-31) - (export run-tests) - (import - (scheme base) - (scheme lazy) - (srfi 31) - (srfi 64) - (srfi-tests aux)) - (begin - (define-tests run-tests "SRFI-31" - (test-eqv "factorial" 3628800 - ((rec (! n) - (if (zero? n) - 1 - (* n (! (- n 1))))) - 10)) - (test-eqv "lazy stream" 'x - (car (force (cdr (force (cdr (rec xs (cons 'x (delay xs)))))))))))) - - -(define-library (srfi-tests srfi-54) - (export run-tests) - (import - (scheme base) - (scheme char) - (scheme write) - (srfi 54) - (srfi 64) - (srfi-tests aux)) - (begin - - (define-syntax value-and-output - (syntax-rules () - ((_ expr) - (let ((port (open-output-string))) - (parameterize ((current-output-port port)) - (let ((value expr)) - (list value (get-output-string port)))))))) - - (define (string-reverse string) - (list->string (reverse (string->list string)))) - - (define-tests run-tests "SRFI-54" - (test-equal "130.00 " (cat 129.995 -10 2.)) - (test-equal " 130.00" (cat 129.995 10 2.)) - (test-equal " 129.98" (cat 129.985 10 2.)) - (test-equal " 129.99" (cat 129.985001 10 2.)) - (test-equal "#e130.00" (cat 129.995 2. 'exact)) - (test-equal "129.00" (cat 129 -2.)) - (test-equal "#e129.00" (cat 129 2.)) - (test-equal "#e+0129.00" (cat 129 10 2. #\0 'sign)) - (test-equal "*#e+129.00" (cat 129 10 2. #\* 'sign)) - (test-equal "1/3" (cat 1/3)) - (test-equal " #e0.33" (cat 1/3 10 2.)) - (test-equal " 0.33" (cat 1/3 10 -2.)) - (test-equal " 1,29.99,5" (cat 129.995 10 '(#\, 2))) - (test-equal " +129,995" (cat 129995 10 '(#\,) 'sign)) - (test-equal "130" (cat (cat 129.995 0.) '(0 -1))) - ;; These produce different results on Chibi, but I don't know if that's a - ;; bug or whether the result is implementation-dependent. - ;; (test-equal "#i#o+307/2" (cat 99.5 10 'sign 'octal)) - ;; (test-equal " #o+307/2" (cat 99.5 10 'sign 'octal 'exact)) - (test-equal "#o+443" (cat #x123 'octal 'sign)) - (test-equal "#e+291.00*" (cat #x123 -10 2. 'sign #\*)) - ;; These produce different results on Larceny, but I don't know if that's - ;; a bug or whether the result is implementation-dependent. - ;; (test-equal "-1.234e+15+1.236e-15i" (cat -1.2345e+15+1.2355e-15i 3.)) - ;; (test-equal "+1.234e+15" (cat 1.2345e+15 10 3. 'sign)) - (test-equal "string " (cat "string" -10)) - (test-equal " STRING" (cat "string" 10 (list string-upcase))) - (test-equal " RING" (cat "string" 10 (list string-upcase) '(-2))) - (test-equal " STING" (cat "string" 10 `(,string-upcase) '(2 3))) - (test-equal "GNIRTS" (cat "string" `(,string-reverse ,string-upcase))) - (test-equal " a" (cat #\a 10)) - (test-equal " symbol" (cat 'symbol 10)) - (test-equal "#(#\\a \"str\" s)" (cat '#(#\a "str" s))) - (test-equal "(#\\a \"str\" s)" (cat '(#\a "str" s))) - (test-equal '("(#\\a \"str\" s)" "(#\\a \"str\" s)") - (value-and-output (cat '(#\a "str" s) #t))) - (test-equal '("(#\\a \"str\" s)" "(#\\a \"str\" s)") - (value-and-output (cat '(#\a "str" s) (current-output-port)))) - (test-equal "3s \"str\"" (cat 3 (cat 's) " " (cat "str" write))) - (test-equal '("3s \"str\"" "3s \"str\"") - (value-and-output (cat 3 #t (cat 's) " " (cat "str" write)))) - (test-equal '("3s \"str\"" "s3s \"str\"") - (value-and-output (cat 3 #t (cat 's #t) " " (cat "str" write))))) - - )) -(import - (scheme base) - (scheme process-context) - (srfi 64)) - -;;; -;;; This is a test suite written in the notation of -;;; SRFI-64, A Scheme API for test suites -;;; - -(test-begin "SRFI 64 - Meta-Test Suite") - -;;; -;;; Ironically, in order to set up the meta-test environment, -;;; we have to invoke one of the most sophisticated features: -;;; custom test runners -;;; - -;;; The `prop-runner' invokes `thunk' in the context of a new -;;; test runner, and returns the indicated properties of the -;;; last-executed test result. - -(define (prop-runner props thunk) - (let ((r (test-runner-null)) - (plist '())) - ;; - (test-runner-on-test-end! - r - (lambda (runner) - (set! plist (test-result-alist runner)))) - ;; - (test-with-runner r (thunk)) - ;; reorder the properties so they are in the order - ;; given by `props'. Note that any property listed in `props' - ;; that is not in the property alist will occur as #f - (map (lambda (k) - (assq k plist)) - props))) - -;;; `on-test-runner' creates a null test runner and then -;;; arranged for `visit' to be called with the runner -;;; whenever a test is run. The results of the calls to -;;; `visit' are returned in a list - -(define (on-test-runner thunk visit) - (let ((r (test-runner-null)) - (results '())) - ;; - (test-runner-on-test-end! - r - (lambda (runner) - (set! results (cons (visit r) results)))) - ;; - (test-with-runner r (thunk)) - (reverse results))) - -;;; -;;; The `triv-runner' invokes `thunk' -;;; and returns a list of 6 lists, the first 5 of which -;;; are a list of the names of the tests that, respectively, -;;; PASS, FAIL, XFAIL, XPASS, and SKIP. -;;; The last item is a list of counts. -;;; - -(define (triv-runner thunk) - (let ((r (test-runner-null)) - (accum-pass '()) - (accum-fail '()) - (accum-xfail '()) - (accum-xpass '()) - (accum-skip '())) - ;; - (test-runner-on-bad-count! - r - (lambda (runner count expected-count) - (error (string-append "bad count " (number->string count) - " but expected " - (number->string expected-count))))) - (test-runner-on-bad-end-name! - r - (lambda (runner begin end) - (error (string-append "bad end group name " end - " but expected " begin)))) - (test-runner-on-test-end! - r - (lambda (runner) - (let ((n (test-runner-test-name runner))) - (case (test-result-kind runner) - ((pass) (set! accum-pass (cons n accum-pass))) - ((fail) (set! accum-fail (cons n accum-fail))) - ((xpass) (set! accum-xpass (cons n accum-xpass))) - ((xfail) (set! accum-xfail (cons n accum-xfail))) - ((skip) (set! accum-skip (cons n accum-skip))))))) - ;; - (test-with-runner r (thunk)) - (list (reverse accum-pass) ; passed as expected - (reverse accum-fail) ; failed, but was expected to pass - (reverse accum-xfail) ; failed as expected - (reverse accum-xpass) ; passed, but was expected to fail - (reverse accum-skip) ; was not executed - (list (test-runner-pass-count r) - (test-runner-fail-count r) - (test-runner-xfail-count r) - (test-runner-xpass-count r) - (test-runner-skip-count r))))) - -(define (path-revealing-runner thunk) - (let ((r (test-runner-null)) - (seq '())) - ;; - (test-runner-on-test-end! - r - (lambda (runner) - (set! seq (cons (list (test-runner-group-path runner) - (test-runner-test-name runner)) - seq)))) - (test-with-runner r (thunk)) - (reverse seq))) - -;;; -;;; Now we can start testing compliance with SRFI-64 -;;; - -(test-begin "1. Simple test-cases") - -(test-begin "1.1. test-assert") - -(define (t) - (triv-runner - (lambda () - (test-assert "a" #t) - (test-assert "b" #f)))) - -(test-equal - "1.1.1. Very simple" - '(("a") ("b") () () () (1 1 0 0 0)) - (t)) - -(test-equal - "1.1.2. A test with no name" - '(("a") ("") () () () (1 1 0 0 0)) - (triv-runner (lambda () (test-assert "a" #t) (test-assert #f)))) - -(test-equal - "1.1.3. Tests can have the same name" - '(("a" "a") () () () () (2 0 0 0 0)) - (triv-runner (lambda () (test-assert "a" #t) (test-assert "a" #t)))) - -(define (choke) - (vector-ref '#(1 2) 3)) - -(test-equal - "1.1.4. One way to FAIL is to throw an error" - '(() ("a") () () () (0 1 0 0 0)) - (triv-runner (lambda () (test-assert "a" (choke))))) - -(test-end);1.1 - -(test-begin "1.2. test-eqv") - -(define (mean x y) - (/ (+ x y) 2.0)) - -(test-equal - "1.2.1. Simple numerical equivalence" - '(("c") ("a" "b") () () () (1 2 0 0 0)) - (triv-runner - (lambda () - (test-eqv "a" (mean 3 5) 4) - (test-eqv "b" (mean 3 5) 4.5) - (test-eqv "c" (mean 3 5) 4.0)))) - -(test-end);1.2 - -(test-begin "1.3. test-approximate") - -(test-equal - "1.3.1. Simple numerical approximation" - '(("a" "c") ("b") () () () (2 1 0 0 0)) - (triv-runner - (lambda () - (test-approximate "a" (mean 3 5) 4 0.001) - (test-approximate "b" (mean 3 5) 4.5 0.001) - (test-approximate "c" (mean 3 5) 4.0 0.001)))) - -(test-end);1.3 - -(test-end "1. Simple test-cases") - -;;; -;;; -;;; - -(test-begin "2. Tests for catching errors") - -(test-begin "2.1. test-error") - -(test-equal - "2.1.1. Baseline test; PASS with no optional args" - '(("") () () () () (1 0 0 0 0)) - (triv-runner - (lambda () - ;; PASS - (test-error (vector-ref '#(1 2) 9))))) - -(test-equal - "2.1.2. Baseline test; FAIL with no optional args" - '(() ("") () () () (0 1 0 0 0)) - (triv-runner - (lambda () - ;; FAIL: the expr does not raise an error and `test-error' is - ;; claiming that it will, so this test should FAIL - (test-error (vector-ref '#(1 2) 0))))) - -(test-equal - "2.1.3. PASS with a test name and error type" - '(("a") () () () () (1 0 0 0 0)) - (triv-runner - (lambda () - ;; PASS - (test-error "a" #t (vector-ref '#(1 2) 9))))) - -(test-equal - "2.1.4. FAIL with a test name and error type" - '(() ("a") () () () (0 1 0 0 0)) - (triv-runner - (lambda () - ;; FAIL - (test-error "a" #t (vector-ref '#(1 2) 0))))) - -(test-equal - "2.1.5. PASS with an error type but no name" - '(("") () () () () (1 0 0 0 0)) - (triv-runner - (lambda () - ;; PASS - (test-error #t (vector-ref '#(1 2) 9))))) - -(test-equal - "2.1.6. FAIL with an error type but no name" - '(() ("") () () () (0 1 0 0 0)) - (triv-runner - (lambda () - ;; FAIL - (test-error #t (vector-ref '#(1 2) 0))))) - -(test-end "2.1. test-error") - -(test-end "2. Tests for catching errors") - -;;; -;;; -;;; - -(test-begin "3. Test groups and paths") - -(test-equal - "3.1. test-begin with unspecific test-end" - '(("b") () () () () (1 0 0 0 0)) - (triv-runner - (lambda () - (test-begin "a") - (test-assert "b" #t) - (test-end)))) - -(test-equal - "3.2. test-begin with name-matching test-end" - '(("b") () () () () (1 0 0 0 0)) - (triv-runner - (lambda () - (test-begin "a") - (test-assert "b" #t) - (test-end "a")))) - -;;; since the error raised by `test-end' on a mismatch is not a test -;;; error, we actually expect the triv-runner itself to fail - -(test-error - "3.3. test-begin with mismatched test-end" -#t - (triv-runner - (lambda () - (test-begin "a") - (test-assert "b" #t) - (test-end "x")))) - -(test-equal - "3.4. test-begin with name and count" - '(("b" "c") () () () () (2 0 0 0 0)) - (triv-runner - (lambda () - (test-begin "a" 2) - (test-assert "b" #t) - (test-assert "c" #t) - (test-end "a")))) - -;; similarly here, a mismatched count is a lexical error -;; and not a test failure... - -(test-error - "3.5. test-begin with mismatched count" - #t - (triv-runner - (lambda () - (test-begin "a" 99) - (test-assert "b" #t) - (test-end "a")))) - -(test-equal - "3.6. introspecting on the group path" - '((() "w") - (("a" "b") "x") - (("a" "b") "y") - (("a") "z")) - ;; - ;; `path-revealing-runner' is designed to return a list - ;; of the tests executed, in order. Each entry is a list - ;; (GROUP-PATH TEST-NAME), and each GROUP-PATH is a list - ;; of test groups starting from the topmost - ;; - (path-revealing-runner - (lambda () - (test-assert "w" #t) - (test-begin "a") - (test-begin "b") - (test-assert "x" #t) - (test-assert "y" #t) - (test-end) - (test-assert "z" #t)))) - - -(test-end "3. Test groups and paths") - -;;; -;;; -;;; - -(test-begin "4. Handling set-up and cleanup") - -(test-equal "4.1. Normal exit path" - '(in 1 2 out) - (let ((ex '())) - (define (do s) - (set! ex (cons s ex))) - ;; - (triv-runner - (lambda () - (test-group-with-cleanup - "foo" - (do 'in) - (do 1) - (do 2) - (do 'out)))) - (reverse ex))) - -(test-equal "4.2. Exception exit path" - '(in 1 out) - (let ((ex '())) - (define (do s) - (set! ex (cons s ex))) - ;; - ;; the outer runner is to run the `test-error' in, to - ;; catch the exception raised in the inner runner, - ;; since we don't want to depend on any other - ;; exception-catching support - ;; - (triv-runner - (lambda () - (test-error - (triv-runner - (lambda () - (test-group-with-cleanup - "foo" - (do 'in) (test-assert #t) - (do 1) (test-assert #t) - (choke) (test-assert #t) - (do 2) (test-assert #t) - (do 'out))))))) - (reverse ex))) - -(test-end "4. Handling set-up and cleanup") - -;;; -;;; -;;; - -(test-begin "5. Test specifiers") - -(test-begin "5.1. test-match-named") - -(test-equal "5.1.1. match test names" - '(("y") () () () ("x") (1 0 0 0 1)) - (triv-runner - (lambda () - (test-skip (test-match-name "x")) - (test-assert "x" #t) - (test-assert "y" #t)))) - -(test-equal "5.1.2. but not group names" - '(("z") () () () () (1 0 0 0 0)) - (triv-runner - (lambda () - (test-skip (test-match-name "x")) - (test-begin "x") - (test-assert "z" #t) - (test-end)))) - -(test-end) - -(test-begin "5.2. test-match-nth") -;; See also: [6.4. Short-circuit evaluation] - -(test-equal "5.2.1. skip the nth one after" - '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1)) - (triv-runner - (lambda () - (test-assert "v" #t) - (test-skip (test-match-nth 2)) - (test-assert "w" #t) ; 1 - (test-assert "x" #t) ; 2 SKIP - (test-assert "y" #t) ; 3 - (test-assert "z" #t)))) ; 4 - -(test-equal "5.2.2. skip m, starting at n" - '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2)) - (triv-runner - (lambda () - (test-assert "v" #t) - (test-skip (test-match-nth 2 2)) - (test-assert "w" #t) ; 1 - (test-assert "x" #t) ; 2 SKIP - (test-assert "y" #t) ; 3 SKIP - (test-assert "z" #t)))) ; 4 - -(test-end) - -(test-begin "5.3. test-match-any") -(test-equal "5.3.1. basic disjunction" - '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2)) - (triv-runner - (lambda () - (test-assert "v" #t) - (test-skip (test-match-any (test-match-nth 3) - (test-match-name "x"))) - (test-assert "w" #t) ; 1 - (test-assert "x" #t) ; 2 SKIP(NAME) - (test-assert "y" #t) ; 3 SKIP(COUNT) - (test-assert "z" #t)))) ; 4 - -(test-equal "5.3.2. disjunction is commutative" - '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2)) - (triv-runner - (lambda () - (test-assert "v" #t) - (test-skip (test-match-any (test-match-name "x") - (test-match-nth 3))) - (test-assert "w" #t) ; 1 - (test-assert "x" #t) ; 2 SKIP(NAME) - (test-assert "y" #t) ; 3 SKIP(COUNT) - (test-assert "z" #t)))) ; 4 - -(test-end) - -(test-begin "5.4. test-match-all") -(test-equal "5.4.1. basic conjunction" - '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1)) - (triv-runner - (lambda () - (test-assert "v" #t) - (test-skip (test-match-all (test-match-nth 2 2) - (test-match-name "x"))) - (test-assert "w" #t) ; 1 - (test-assert "x" #t) ; 2 SKIP(NAME) & SKIP(COUNT) - (test-assert "y" #t) ; 3 SKIP(COUNT) - (test-assert "z" #t)))) ; 4 - -(test-equal "5.4.2. conjunction is commutative" - '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1)) - (triv-runner - (lambda () - (test-assert "v" #t) - (test-skip (test-match-all (test-match-name "x") - (test-match-nth 2 2))) - (test-assert "w" #t) ; 1 - (test-assert "x" #t) ; 2 SKIP(NAME) & SKIP(COUNT) - (test-assert "y" #t) ; 3 SKIP(COUNT) - (test-assert "z" #t)))) ; 4 - -(test-end) - -(test-end "5. Test specifiers") - -;;; -;;; -;;; - -(test-begin "6. Skipping selected tests") - -(test-equal - "6.1. Skip by specifier - match-name" - '(("x") () () () ("y") (1 0 0 0 1)) - (triv-runner - (lambda () - (test-begin "a") - (test-skip (test-match-name "y")) - (test-assert "x" #t) ; PASS - (test-assert "y" #f) ; SKIP - (test-end)))) - -(test-equal - "6.2. Shorthand specifiers" - '(("x") () () () ("y") (1 0 0 0 1)) - (triv-runner - (lambda () - (test-begin "a") - (test-skip "y") - (test-assert "x" #t) ; PASS - (test-assert "y" #f) ; SKIP - (test-end)))) - -(test-begin "6.3. Specifier Stack") - -(test-equal - "6.3.1. Clearing the Specifier Stack" - '(("x" "x") ("y") () () ("y") (2 1 0 0 1)) - (triv-runner - (lambda () - (test-begin "a") - (test-skip "y") - (test-assert "x" #t) ; PASS - (test-assert "y" #f) ; SKIP - (test-end) - (test-begin "b") - (test-assert "x" #t) ; PASS - (test-assert "y" #f) ; FAIL - (test-end)))) - -(test-equal - "6.3.2. Inheriting the Specifier Stack" - '(("x" "x") () () () ("y" "y") (2 0 0 0 2)) - (triv-runner - (lambda () - (test-skip "y") - (test-begin "a") - (test-assert "x" #t) ; PASS - (test-assert "y" #f) ; SKIP - (test-end) - (test-begin "b") - (test-assert "x" #t) ; PASS - (test-assert "y" #f) ; SKIP - (test-end)))) - -(test-end);6.3 - -(test-begin "6.4. Short-circuit evaluation") - -(test-equal - "6.4.1. In test-match-all" - '(("x") ("y" "x" "z") () () ("y") (1 3 0 0 1)) - (triv-runner - (lambda () - (test-begin "a") - (test-skip (test-match-all "y" (test-match-nth 2))) - ;; let's label the substructure forms so we can - ;; see which one `test-match-nth' is going to skip - ;; ; # "y" 2 result - (test-assert "x" #t) ; 1 - #f #f PASS - (test-assert "y" #f) ; 2 - #t #t SKIP - (test-assert "y" #f) ; 3 - #t #f FAIL - (test-assert "x" #f) ; 4 - #f #f FAIL - (test-assert "z" #f) ; 5 - #f #f FAIL - (test-end)))) - -(test-equal - "6.4.2. In separate skip-list entries" - '(("x") ("x" "z") () () ("y" "y") (1 2 0 0 2)) - (triv-runner - (lambda () - (test-begin "a") - (test-skip "y") - (test-skip (test-match-nth 2)) - ;; let's label the substructure forms so we can - ;; see which one `test-match-nth' is going to skip - ;; ; # "y" 2 result - (test-assert "x" #t) ; 1 - #f #f PASS - (test-assert "y" #f) ; 2 - #t #t SKIP - (test-assert "y" #f) ; 3 - #t #f SKIP - (test-assert "x" #f) ; 4 - #f #f FAIL - (test-assert "z" #f) ; 5 - #f #f FAIL - (test-end)))) - -(test-begin "6.4.3. Skipping test suites") - -(test-equal - "6.4.3.1. Introduced using 'test-begin'" - '(("x") () () () () (1 0 0 0 0)) - (triv-runner - (lambda () - (test-begin "a") - (test-skip "b") - (test-begin "b") ; not skipped - (test-assert "x" #t) - (test-end "b") - (test-end "a")))) - -(test-expect-fail 1) ;; ??? -(test-equal - "6.4.3.2. Introduced using 'test-group'" - '(() () () () () (0 0 0 0 1)) - (triv-runner - (lambda () - (test-begin "a") - (test-skip "b") - (test-group - "b" ; skipped - (test-assert "x" #t)) - (test-end "a")))) - -(test-equal - "6.4.3.3. Non-skipped 'test-group'" - '(("x") () () () () (1 0 0 0 0)) - (triv-runner - (lambda () - (test-begin "a") - (test-skip "c") - (test-group "b" (test-assert "x" #t)) - (test-end "a")))) - -(test-end) ; 6.4.3 - -(test-end);6.4 - -(test-end "6. Skipping selected tests") - -;;; -;;; -;;; - -(test-begin "7. Expected failures") - -(test-equal "7.1. Simple example" - '(() ("x") ("z") () () (0 1 1 0 0)) - (triv-runner - (lambda () - (test-assert "x" #f) - (test-expect-fail "z") - (test-assert "z" #f)))) - -(test-equal "7.2. Expected exception" - '(() ("x") ("z") () () (0 1 1 0 0)) - (triv-runner - (lambda () - (test-assert "x" #f) - (test-expect-fail "z") - (test-assert "z" (choke))))) - -(test-equal "7.3. Unexpectedly PASS" - '(() () ("y") ("x") () (0 0 1 1 0)) - (triv-runner - (lambda () - (test-expect-fail "x") - (test-expect-fail "y") - (test-assert "x" #t) - (test-assert "y" #f)))) - - - -(test-end "7. Expected failures") - -;;; -;;; -;;; - -(test-begin "8. Test-runner") - -;;; -;;; Because we want this test suite to be accurate even -;;; when the underlying implementation chooses to use, e.g., -;;; a global variable to implement what could be thread variables -;;; or SRFI-39 parameter objects, we really need to save and restore -;;; their state ourselves -;;; -(define (with-factory-saved thunk) - (let* ((saved (test-runner-factory)) - (result (thunk))) - (test-runner-factory saved) - result)) - -(test-begin "8.1. test-runner-current") -(test-assert "8.1.1. automatically restored" - (let ((a 0) - (b 1) - (c 2)) - ; - (triv-runner - (lambda () - (set! a (test-runner-current)) - ;; - (triv-runner - (lambda () - (set! b (test-runner-current)))) - ;; - (set! c (test-runner-current)))) - ;; - (and (eq? a c) - (not (eq? a b))))) - -(test-end) - -(test-begin "8.2. test-runner-simple") -(test-assert "8.2.1. default on-test hook" - (eq? (test-runner-on-test-end (test-runner-simple)) - test-on-test-end-simple)) -(test-assert "8.2.2. default on-final hook" - (eq? (test-runner-on-final (test-runner-simple)) - test-on-final-simple)) -(test-end) - -(test-begin "8.3. test-runner-factory") - -(test-assert "8.3.1. default factory" - (eq? (test-runner-factory) test-runner-simple)) - -(test-assert "8.3.2. settable factory" - (with-factory-saved - (lambda () - (test-runner-factory test-runner-null) - ;; we have no way, without bringing in other SRFIs, - ;; to make sure the following doesn't print anything, - ;; but it shouldn't: - (test-with-runner - (test-runner-create) - (lambda () - (test-begin "a") - (test-assert #t) ; pass - (test-assert #f) ; fail - (test-assert (vector-ref '#(3) 10)) ; fail with error - (test-end "a"))) - (eq? (test-runner-factory) test-runner-null)))) - -(test-end) - -;;; This got tested about as well as it could in 8.3.2 - -(test-begin "8.4. test-runner-create") -(test-end) - -;;; This got tested about as well as it could in 8.3.2 - -(test-begin "8.5. test-runner-factory") -(test-end) - -(test-begin "8.6. test-apply") -(test-equal "8.6.1. Simple (form 1) test-apply" - '(("w" "p" "v") () () () ("x") (3 0 0 0 1)) - (triv-runner - (lambda () - (test-begin "a") - (test-assert "w" #t) - (test-apply - (test-match-name "p") - (lambda () - (test-begin "p") - (test-assert "x" #t) - (test-end) - (test-begin "z") - (test-assert "p" #t) ; only this one should execute in here - (test-end))) - (test-assert "v" #t)))) - -(test-equal "8.6.2. Simple (form 2) test-apply" - '(("w" "p" "v") () () () ("x") (3 0 0 0 1)) - (triv-runner - (lambda () - (test-begin "a") - (test-assert "w" #t) - (test-apply - (test-runner-current) - (test-match-name "p") - (lambda () - (test-begin "p") - (test-assert "x" #t) - (test-end) - (test-begin "z") - (test-assert "p" #t) ; only this one should execute in here - (test-end))) - (test-assert "v" #t)))) - -(test-expect-fail 1) ;; depends on all test-match-nth being called. -(test-equal "8.6.3. test-apply with skips" - '(("w" "q" "v") () () () ("x" "p" "x") (3 0 0 0 3)) - (triv-runner - (lambda () - (test-begin "a") - (test-assert "w" #t) - (test-skip (test-match-nth 2)) - (test-skip (test-match-nth 4)) - (test-apply - (test-runner-current) - (test-match-name "p") - (test-match-name "q") - (lambda () - ; only execute if SKIP=no and APPLY=yes - (test-assert "x" #t) ; # 1 SKIP=no APPLY=no - (test-assert "p" #t) ; # 2 SKIP=yes APPLY=yes - (test-assert "q" #t) ; # 3 SKIP=no APPLY=yes - (test-assert "x" #f) ; # 4 SKIP=yes APPLY=no - 0)) - (test-assert "v" #t)))) - -;;; Unfortunately, since there is no way to UNBIND the current test runner, -;;; there is no way to test the behavior of `test-apply' in the absence -;;; of a current runner within our little meta-test framework. -;;; -;;; To test the behavior manually, you should be able to invoke: -;;; -;;; (test-apply "a" (lambda () (test-assert "a" #t))) -;;; -;;; from the top level (with SRFI 64 available) and it should create a -;;; new, default (simple) test runner. - -(test-end) - -;;; This entire suite depends heavily on 'test-with-runner'. If it didn't -;;; work, this suite would probably go down in flames -(test-begin "8.7. test-with-runner") -(test-end) - -;;; Again, this suite depends heavily on many of the test-runner -;;; components. We'll just test those that aren't being exercised -;;; by the meta-test framework -(test-begin "8.8. test-runner components") - -(define (auxtrack-runner thunk) - (let ((r (test-runner-null))) - (test-runner-aux-value! r '()) - (test-runner-on-test-end! r (lambda (r) - (test-runner-aux-value! - r - (cons (test-runner-test-name r) - (test-runner-aux-value r))))) - (test-with-runner r (thunk)) - (reverse (test-runner-aux-value r)))) - -(test-equal "8.8.1. test-runner-aux-value" - '("x" "" "y") - (auxtrack-runner - (lambda () - (test-assert "x" #t) - (test-begin "a") - (test-assert #t) - (test-end) - (test-assert "y" #f)))) - -(test-end) ; 8.8 - -(test-end "8. Test-runner") - -(test-begin "9. Test Result Properties") - -(test-begin "9.1. test-result-alist") - -(define (symbol-alist? l) - (if (null? l) - #t - (and (pair? l) - (pair? (car l)) - (symbol? (caar l)) - (symbol-alist? (cdr l))))) - -;;; check the various syntactic forms - -(test-assert (symbol-alist? - (car (on-test-runner - (lambda () - (test-assert #t)) - (lambda (r) - (test-result-alist r)))))) - -(test-assert (symbol-alist? - (car (on-test-runner - (lambda () - (test-assert #t)) - (lambda (r) - (test-result-alist r)))))) - -;;; check to make sure the required properties are returned - -(test-equal '((result-kind . pass)) - (prop-runner - '(result-kind) - (lambda () - (test-assert #t))) - ) - -(test-equal - '((result-kind . fail) - (expected-value . 2) - (actual-value . 3)) - (prop-runner - '(result-kind expected-value actual-value) - (lambda () - (test-equal 2 (+ 1 2))))) - -(test-end "9.1. test-result-alist") - -(test-begin "9.2. test-result-ref") - -(test-equal '(pass) - (on-test-runner - (lambda () - (test-assert #t)) - (lambda (r) - (test-result-ref r 'result-kind)))) - -(test-equal '(pass) - (on-test-runner - (lambda () - (test-assert #t)) - (lambda (r) - (test-result-ref r 'result-kind)))) - -(test-equal '(fail pass) - (on-test-runner - (lambda () - (test-assert (= 1 2)) - (test-assert (= 1 1))) - (lambda (r) - (test-result-ref r 'result-kind)))) - -(test-end "9.2. test-result-ref") - -(test-begin "9.3. test-result-set!") - -(test-equal '(100 100) - (on-test-runner - (lambda () - (test-assert (= 1 2)) - (test-assert (= 1 1))) - (lambda (r) - (test-result-set! r 'foo 100) - (test-result-ref r 'foo)))) - -(test-end "9.3. test-result-set!") - -(test-end "9. Test Result Properties") - -;;; -;;; -;;; - -;#| Time to stop having fun... -; -;(test-begin "9. For fun, some meta-test errors") -; -;(test-equal -; "9.1. Really PASSes, but test like it should FAIL" -; '(() ("b") () () ()) -; (triv-runner -; (lambda () -; (test-assert "b" #t)))) -; -;(test-expect-fail "9.2. Expect to FAIL and do so") -;(test-expect-fail "9.3. Expect to FAIL but PASS") -;(test-skip "9.4. SKIP this one") -; -;(test-assert "9.2. Expect to FAIL and do so" #f) -;(test-assert "9.3. Expect to FAIL but PASS" #t) -;(test-assert "9.4. SKIP this one" #t) -; -;(test-end) -; |# - -(test-end "SRFI 64 - Meta-Test Suite") - -(let ((runner (test-runner-current))) - (unless (and (= 0 (test-runner-xpass-count runner)) - (= 0 (test-runner-fail-count runner))) - (exit 1))) - -;;; -;;; -;;; This is a test suite written in the notation of -;;; SRFI-64, A Scheme API for test suites -;;; - -(test-begin "SRFI 64 - Meta-Test Suite") - -;;; -;;; Ironically, in order to set up the meta-test environment, -;;; we have to invoke one of the most sophisticated features: -;;; custom test runners -;;; - -;;; The `prop-runner' invokes `thunk' in the context of a new -;;; test runner, and returns the indicated properties of the -;;; last-executed test result. - -(define (prop-runner props thunk) - (let ((r (test-runner-null)) - (plist '())) - ;; - (test-runner-on-test-end! - r - (lambda (runner) - (set! plist (test-result-alist runner)))) - ;; - (test-with-runner r (thunk)) - ;; reorder the properties so they are in the order - ;; given by `props'. Note that any property listed in `props' - ;; that is not in the property alist will occur as #f - (map (lambda (k) - (assq k plist)) - props))) - -;;; `on-test-runner' creates a null test runner and then -;;; arranged for `visit' to be called with the runner -;;; whenever a test is run. The results of the calls to -;;; `visit' are returned in a list - -(define (on-test-runner thunk visit) - (let ((r (test-runner-null)) - (results '())) - ;; - (test-runner-on-test-end! - r - (lambda (runner) - (set! results (cons (visit r) results)))) - ;; - (test-with-runner r (thunk)) - (reverse results))) - -;;; -;;; The `triv-runner' invokes `thunk' -;;; and returns a list of 6 lists, the first 5 of which -;;; are a list of the names of the tests that, respectively, -;;; PASS, FAIL, XFAIL, XPASS, and SKIP. -;;; The last item is a list of counts. -;;; - -(define (triv-runner thunk) - (let ((r (test-runner-null)) - (accum-pass '()) - (accum-fail '()) - (accum-xfail '()) - (accum-xpass '()) - (accum-skip '())) - ;; - (test-runner-on-bad-count! - r - (lambda (runner count expected-count) - (error (string-append "bad count " (number->string count) - " but expected " - (number->string expected-count))))) - (test-runner-on-bad-end-name! - r - (lambda (runner begin end) - (error (string-append "bad end group name " end - " but expected " begin)))) - (test-runner-on-test-end! - r - (lambda (runner) - (let ((n (test-runner-test-name runner))) - (case (test-result-kind runner) - ((pass) (set! accum-pass (cons n accum-pass))) - ((fail) (set! accum-fail (cons n accum-fail))) - ((xpass) (set! accum-xpass (cons n accum-xpass))) - ((xfail) (set! accum-xfail (cons n accum-xfail))) - ((skip) (set! accum-skip (cons n accum-skip))))))) - ;; - (test-with-runner r (thunk)) - (list (reverse accum-pass) ; passed as expected - (reverse accum-fail) ; failed, but was expected to pass - (reverse accum-xfail) ; failed as expected - (reverse accum-xpass) ; passed, but was expected to fail - (reverse accum-skip) ; was not executed - (list (test-runner-pass-count r) - (test-runner-fail-count r) - (test-runner-xfail-count r) - (test-runner-xpass-count r) - (test-runner-skip-count r))))) - -(define (path-revealing-runner thunk) - (let ((r (test-runner-null)) - (seq '())) - ;; - (test-runner-on-test-end! - r - (lambda (runner) - (set! seq (cons (list (test-runner-group-path runner) - (test-runner-test-name runner)) - seq)))) - (test-with-runner r (thunk)) - (reverse seq))) - -;;; -;;; Now we can start testing compliance with SRFI-64 -;;; - -(test-begin "1. Simple test-cases") - -(test-begin "1.1. test-assert") - -(define (t) - (triv-runner - (lambda () - (test-assert "a" #t) - (test-assert "b" #f)))) - -(test-equal - "1.1.1. Very simple" - '(("a") ("b") () () () (1 1 0 0 0)) - (t)) - -(test-equal - "1.1.2. A test with no name" - '(("a") ("") () () () (1 1 0 0 0)) - (triv-runner (lambda () (test-assert "a" #t) (test-assert #f)))) - -(test-equal - "1.1.3. Tests can have the same name" - '(("a" "a") () () () () (2 0 0 0 0)) - (triv-runner (lambda () (test-assert "a" #t) (test-assert "a" #t)))) - -(define (choke) - (vector-ref '#(1 2) 3)) - -(test-equal - "1.1.4. One way to FAIL is to throw an error" - '(() ("a") () () () (0 1 0 0 0)) - (triv-runner (lambda () (test-assert "a" (choke))))) - -(test-end);1.1 - -(test-begin "1.2. test-eqv") - -(define (mean x y) - (/ (+ x y) 2.0)) - -(test-equal - "1.2.1. Simple numerical equivalence" - '(("c") ("a" "b") () () () (1 2 0 0 0)) - (triv-runner - (lambda () - (test-eqv "a" (mean 3 5) 4) - (test-eqv "b" (mean 3 5) 4.5) - (test-eqv "c" (mean 3 5) 4.0)))) - -(test-end);1.2 - -(test-end "1. Simple test-cases") - -;;; -;;; -;;; - -(test-begin "2. Tests for catching errors") - -(test-begin "2.1. test-error") - -(test-equal - "2.1.1. Baseline test; PASS with no optional args" - '(("") () () () () (1 0 0 0 0)) - (triv-runner - (lambda () - ;; PASS - (test-error (vector-ref '#(1 2) 9))))) - -(test-equal - "2.1.2. Baseline test; FAIL with no optional args" - '(() ("") () () () (0 1 0 0 0)) - (triv-runner - (lambda () - ;; FAIL: the expr does not raise an error and `test-error' is - ;; claiming that it will, so this test should FAIL - (test-error (vector-ref '#(1 2) 0))))) - -(test-equal - "2.1.3. PASS with a test name and error type" - '(("a") () () () () (1 0 0 0 0)) - (triv-runner - (lambda () - ;; PASS - (test-error "a" #t (vector-ref '#(1 2) 9))))) - -(test-end "2.1. test-error") - -(test-end "2. Tests for catching errors") - -;;; -;;; -;;; - -(test-begin "3. Test groups and paths") - -(test-equal - "3.1. test-begin with unspecific test-end" - '(("b") () () () () (1 0 0 0 0)) - (triv-runner - (lambda () - (test-begin "a") - (test-assert "b" #t) - (test-end)))) - -(test-equal - "3.2. test-begin with name-matching test-end" - '(("b") () () () () (1 0 0 0 0)) - (triv-runner - (lambda () - (test-begin "a") - (test-assert "b" #t) - (test-end "a")))) - -;;; since the error raised by `test-end' on a mismatch is not a test -;;; error, we actually expect the triv-runner itself to fail - -(test-error - "3.3. test-begin with mismatched test-end" -#t - (triv-runner - (lambda () - (test-begin "a") - (test-assert "b" #t) - (test-end "x")))) - -(test-equal - "3.4. test-begin with name and count" - '(("b" "c") () () () () (2 0 0 0 0)) - (triv-runner - (lambda () - (test-begin "a" 2) - (test-assert "b" #t) - (test-assert "c" #t) - (test-end "a")))) - -;; similarly here, a mismatched count is a lexical error -;; and not a test failure... - -(test-error - "3.5. test-begin with mismatched count" - #t - (triv-runner - (lambda () - (test-begin "a" 99) - (test-assert "b" #t) - (test-end "a")))) - -(test-equal - "3.6. introspecting on the group path" - '((() "w") - (("a" "b") "x") - (("a" "b") "y") - (("a") "z")) - ;; - ;; `path-revealing-runner' is designed to return a list - ;; of the tests executed, in order. Each entry is a list - ;; (GROUP-PATH TEST-NAME), and each GROUP-PATH is a list - ;; of test groups starting from the topmost - ;; - (path-revealing-runner - (lambda () - (test-assert "w" #t) - (test-begin "a") - (test-begin "b") - (test-assert "x" #t) - (test-assert "y" #t) - (test-end) - (test-assert "z" #t)))) - - -(test-end "3. Test groups and paths") - -;;; -;;; -;;; - -(test-begin "4. Handling set-up and cleanup") - -(test-equal "4.1. Normal exit path" - '(in 1 2 out) - (let ((ex '())) - (define (do s) - (set! ex (cons s ex))) - ;; - (triv-runner - (lambda () - (test-group-with-cleanup - "foo" - (do 'in) - (do 1) - (do 2) - (do 'out)))) - (reverse ex))) - -(test-equal "4.2. Exception exit path" - '(in 1 out) - (let ((ex '())) - (define (do s) - (set! ex (cons s ex))) - ;; - ;; the outer runner is to run the `test-error' in, to - ;; catch the exception raised in the inner runner, - ;; since we don't want to depend on any other - ;; exception-catching support - ;; - (triv-runner - (lambda () - (test-error - (triv-runner - (lambda () - (test-group-with-cleanup - "foo" - (do 'in) (test-assert #t) - (do 1) (test-assert #t) - (choke) (test-assert #t) - (do 2) (test-assert #t) - (do 'out))))))) - (reverse ex))) - -(test-end "4. Handling set-up and cleanup") - -;;; -;;; -;;; - -(test-begin "5. Test specifiers") - -(test-begin "5.1. test-match-named") - -(test-equal "5.1.1. match test names" - '(("y") () () () ("x") (1 0 0 0 1)) - (triv-runner - (lambda () - (test-skip (test-match-name "x")) - (test-assert "x" #t) - (test-assert "y" #t)))) - -(test-equal "5.1.2. but not group names" - '(("z") () () () () (1 0 0 0 0)) - (triv-runner - (lambda () - (test-skip (test-match-name "x")) - (test-begin "x") - (test-assert "z" #t) - (test-end)))) - -(test-end) - -(test-begin "5.2. test-match-nth") -;; See also: [6.4. Short-circuit evaluation] - -(test-equal "5.2.1. skip the nth one after" - '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1)) - (triv-runner - (lambda () - (test-assert "v" #t) - (test-skip (test-match-nth 2)) - (test-assert "w" #t) ; 1 - (test-assert "x" #t) ; 2 SKIP - (test-assert "y" #t) ; 3 - (test-assert "z" #t)))) ; 4 - -(test-equal "5.2.2. skip m, starting at n" - '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2)) - (triv-runner - (lambda () - (test-assert "v" #t) - (test-skip (test-match-nth 2 2)) - (test-assert "w" #t) ; 1 - (test-assert "x" #t) ; 2 SKIP - (test-assert "y" #t) ; 3 SKIP - (test-assert "z" #t)))) ; 4 - -(test-end) - -(test-begin "5.3. test-match-any") -(test-equal "5.3.1. basic disjunction" - '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2)) - (triv-runner - (lambda () - (test-assert "v" #t) - (test-skip (test-match-any (test-match-nth 3) - (test-match-name "x"))) - (test-assert "w" #t) ; 1 - (test-assert "x" #t) ; 2 SKIP(NAME) - (test-assert "y" #t) ; 3 SKIP(COUNT) - (test-assert "z" #t)))) ; 4 - -(test-equal "5.3.2. disjunction is commutative" - '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2)) - (triv-runner - (lambda () - (test-assert "v" #t) - (test-skip (test-match-any (test-match-name "x") - (test-match-nth 3))) - (test-assert "w" #t) ; 1 - (test-assert "x" #t) ; 2 SKIP(NAME) - (test-assert "y" #t) ; 3 SKIP(COUNT) - (test-assert "z" #t)))) ; 4 - -(test-end) - -(test-begin "5.4. test-match-all") -(test-equal "5.4.1. basic conjunction" - '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1)) - (triv-runner - (lambda () - (test-assert "v" #t) - (test-skip (test-match-all (test-match-nth 2 2) - (test-match-name "x"))) - (test-assert "w" #t) ; 1 - (test-assert "x" #t) ; 2 SKIP(NAME) & SKIP(COUNT) - (test-assert "y" #t) ; 3 SKIP(COUNT) - (test-assert "z" #t)))) ; 4 - -(test-equal "5.4.2. conjunction is commutative" - '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1)) - (triv-runner - (lambda () - (test-assert "v" #t) - (test-skip (test-match-all (test-match-name "x") - (test-match-nth 2 2))) - (test-assert "w" #t) ; 1 - (test-assert "x" #t) ; 2 SKIP(NAME) & SKIP(COUNT) - (test-assert "y" #t) ; 3 SKIP(COUNT) - (test-assert "z" #t)))) ; 4 - -(test-end) - -(test-end "5. Test specifiers") - -;;; -;;; -;;; - -(test-begin "6. Skipping selected tests") - -(test-equal - "6.1. Skip by specifier - match-name" - '(("x") () () () ("y") (1 0 0 0 1)) - (triv-runner - (lambda () - (test-begin "a") - (test-skip (test-match-name "y")) - (test-assert "x" #t) ; PASS - (test-assert "y" #f) ; SKIP - (test-end)))) - -(test-equal - "6.2. Shorthand specifiers" - '(("x") () () () ("y") (1 0 0 0 1)) - (triv-runner - (lambda () - (test-begin "a") - (test-skip "y") - (test-assert "x" #t) ; PASS - (test-assert "y" #f) ; SKIP - (test-end)))) - -(test-begin "6.3. Specifier Stack") - -(test-equal - "6.3.1. Clearing the Specifier Stack" - '(("x" "x") ("y") () () ("y") (2 1 0 0 1)) - (triv-runner - (lambda () - (test-begin "a") - (test-skip "y") - (test-assert "x" #t) ; PASS - (test-assert "y" #f) ; SKIP - (test-end) - (test-begin "b") - (test-assert "x" #t) ; PASS - (test-assert "y" #f) ; FAIL - (test-end)))) - -(test-equal - "6.3.2. Inheriting the Specifier Stack" - '(("x" "x") () () () ("y" "y") (2 0 0 0 2)) - (triv-runner - (lambda () - (test-skip "y") - (test-begin "a") - (test-assert "x" #t) ; PASS - (test-assert "y" #f) ; SKIP - (test-end) - (test-begin "b") - (test-assert "x" #t) ; PASS - (test-assert "y" #f) ; SKIP - (test-end)))) - -(test-end);6.3 - -(test-begin "6.4. Short-circuit evaluation") - -(test-equal - "6.4.1. In test-match-all" - '(("x") ("y" "x" "z") () () ("y") (1 3 0 0 1)) - (triv-runner - (lambda () - (test-begin "a") - (test-skip (test-match-all "y" (test-match-nth 2))) - ;; let's label the substructure forms so we can - ;; see which one `test-match-nth' is going to skip - ;; ; # "y" 2 result - (test-assert "x" #t) ; 1 - #f #f PASS - (test-assert "y" #f) ; 2 - #t #t SKIP - (test-assert "y" #f) ; 3 - #t #f FAIL - (test-assert "x" #f) ; 4 - #f #f FAIL - (test-assert "z" #f) ; 5 - #f #f FAIL - (test-end)))) - -(test-equal - "6.4.2. In separate skip-list entries" - '(("x") ("x" "z") () () ("y" "y") (1 2 0 0 2)) - (triv-runner - (lambda () - (test-begin "a") - (test-skip "y") - (test-skip (test-match-nth 2)) - ;; let's label the substructure forms so we can - ;; see which one `test-match-nth' is going to skip - ;; ; # "y" 2 result - (test-assert "x" #t) ; 1 - #f #f PASS - (test-assert "y" #f) ; 2 - #t #t SKIP - (test-assert "y" #f) ; 3 - #t #f SKIP - (test-assert "x" #f) ; 4 - #f #f FAIL - (test-assert "z" #f) ; 5 - #f #f FAIL - (test-end)))) - -(test-begin "6.4.3. Skipping test suites") - -(test-equal - "6.4.3.1. Introduced using 'test-begin'" - '(("x") () () () () (1 0 0 0 0)) - (triv-runner - (lambda () - (test-begin "a") - (test-skip "b") - (test-begin "b") ; not skipped - (test-assert "x" #t) - (test-end "b") - (test-end "a")))) - -(test-expect-fail 1) ;; ??? -(test-equal - "6.4.3.2. Introduced using 'test-group'" - '(() () () () () (0 0 0 0 1)) - (triv-runner - (lambda () - (test-begin "a") - (test-skip "b") - (test-group - "b" ; skipped - (test-assert "x" #t)) - (test-end "a")))) - -(test-equal - "6.4.3.3. Non-skipped 'test-group'" - '(("x") () () () () (1 0 0 0 0)) - (triv-runner - (lambda () - (test-begin "a") - (test-skip "c") - (test-group "b" (test-assert "x" #t)) - (test-end "a")))) - -(test-end) ; 6.4.3 - -(test-end);6.4 - -(test-end "6. Skipping selected tests") - -;;; -;;; -;;; - -(test-begin "7. Expected failures") - -(test-equal "7.1. Simple example" - '(() ("x") ("z") () () (0 1 1 0 0)) - (triv-runner - (lambda () - (test-assert "x" #f) - (test-expect-fail "z") - (test-assert "z" #f)))) - -(test-equal "7.2. Expected exception" - '(() ("x") ("z") () () (0 1 1 0 0)) - (triv-runner - (lambda () - (test-assert "x" #f) - (test-expect-fail "z") - (test-assert "z" (choke))))) - -(test-equal "7.3. Unexpectedly PASS" - '(() () ("y") ("x") () (0 0 1 1 0)) - (triv-runner - (lambda () - (test-expect-fail "x") - (test-expect-fail "y") - (test-assert "x" #t) - (test-assert "y" #f)))) - - - -(test-end "7. Expected failures") - -;;; -;;; -;;; - -(test-begin "8. Test-runner") - -;;; -;;; Because we want this test suite to be accurate even -;;; when the underlying implementation chooses to use, e.g., -;;; a global variable to implement what could be thread variables -;;; or SRFI-39 parameter objects, we really need to save and restore -;;; their state ourselves -;;; -(define (with-factory-saved thunk) - (let* ((saved (test-runner-factory)) - (result (thunk))) - (test-runner-factory saved) - result)) - -(test-begin "8.1. test-runner-current") -(test-assert "8.1.1. automatically restored" - (let ((a 0) - (b 1) - (c 2)) - ; - (triv-runner - (lambda () - (set! a (test-runner-current)) - ;; - (triv-runner - (lambda () - (set! b (test-runner-current)))) - ;; - (set! c (test-runner-current)))) - ;; - (and (eq? a c) - (not (eq? a b))))) - -(test-end) - -(test-begin "8.2. test-runner-simple") -(test-assert "8.2.1. default on-test hook" - (eq? (test-runner-on-test-end (test-runner-simple)) - test-on-test-end-simple)) -(test-assert "8.2.2. default on-final hook" - (eq? (test-runner-on-final (test-runner-simple)) - test-on-final-simple)) -(test-end) - -(test-begin "8.3. test-runner-factory") - -(test-assert "8.3.1. default factory" - (eq? (test-runner-factory) test-runner-simple)) - -(test-assert "8.3.2. settable factory" - (with-factory-saved - (lambda () - (test-runner-factory test-runner-null) - ;; we have no way, without bringing in other SRFIs, - ;; to make sure the following doesn't print anything, - ;; but it shouldn't: - (test-with-runner - (test-runner-create) - (lambda () - (test-begin "a") - (test-assert #t) ; pass - (test-assert #f) ; fail - (test-assert (vector-ref '#(3) 10)) ; fail with error - (test-end "a"))) - (eq? (test-runner-factory) test-runner-null)))) - -(test-end) - -;;; This got tested about as well as it could in 8.3.2 - -(test-begin "8.4. test-runner-create") -(test-end) - -;;; This got tested about as well as it could in 8.3.2 - -(test-begin "8.5. test-runner-factory") -(test-end) - -(test-begin "8.6. test-apply") -(test-equal "8.6.1. Simple (form 1) test-apply" - '(("w" "p" "v") () () () ("x") (3 0 0 0 1)) - (triv-runner - (lambda () - (test-begin "a") - (test-assert "w" #t) - (test-apply - (test-match-name "p") - (lambda () - (test-begin "p") - (test-assert "x" #t) - (test-end) - (test-begin "z") - (test-assert "p" #t) ; only this one should execute in here - (test-end))) - (test-assert "v" #t)))) - -(test-equal "8.6.2. Simple (form 2) test-apply" - '(("w" "p" "v") () () () ("x") (3 0 0 0 1)) - (triv-runner - (lambda () - (test-begin "a") - (test-assert "w" #t) - (test-apply - (test-runner-current) - (test-match-name "p") - (lambda () - (test-begin "p") - (test-assert "x" #t) - (test-end) - (test-begin "z") - (test-assert "p" #t) ; only this one should execute in here - (test-end))) - (test-assert "v" #t)))) - -(test-expect-fail 1) ;; depends on all test-match-nth being called. -(test-equal "8.6.3. test-apply with skips" - '(("w" "q" "v") () () () ("x" "p" "x") (3 0 0 0 3)) - (triv-runner - (lambda () - (test-begin "a") - (test-assert "w" #t) - (test-skip (test-match-nth 2)) - (test-skip (test-match-nth 4)) - (test-apply - (test-runner-current) - (test-match-name "p") - (test-match-name "q") - (lambda () - ; only execute if SKIP=no and APPLY=yes - (test-assert "x" #t) ; # 1 SKIP=no APPLY=no - (test-assert "p" #t) ; # 2 SKIP=yes APPLY=yes - (test-assert "q" #t) ; # 3 SKIP=no APPLY=yes - (test-assert "x" #f) ; # 4 SKIP=yes APPLY=no - 0)) - (test-assert "v" #t)))) - -;;; Unfortunately, since there is no way to UNBIND the current test runner, -;;; there is no way to test the behavior of `test-apply' in the absence -;;; of a current runner within our little meta-test framework. -;;; -;;; To test the behavior manually, you should be able to invoke: -;;; -;;; (test-apply "a" (lambda () (test-assert "a" #t))) -;;; -;;; from the top level (with SRFI 64 available) and it should create a -;;; new, default (simple) test runner. - -(test-end) - -;;; This entire suite depends heavily on 'test-with-runner'. If it didn't -;;; work, this suite would probably go down in flames -(test-begin "8.7. test-with-runner") -(test-end) - -;;; Again, this suite depends heavily on many of the test-runner -;;; components. We'll just test those that aren't being exercised -;;; by the meta-test framework -(test-begin "8.8. test-runner components") - -(define (auxtrack-runner thunk) - (let ((r (test-runner-null))) - (test-runner-aux-value! r '()) - (test-runner-on-test-end! r (lambda (r) - (test-runner-aux-value! - r - (cons (test-runner-test-name r) - (test-runner-aux-value r))))) - (test-with-runner r (thunk)) - (reverse (test-runner-aux-value r)))) - -(test-equal "8.8.1. test-runner-aux-value" - '("x" "" "y") - (auxtrack-runner - (lambda () - (test-assert "x" #t) - (test-begin "a") - (test-assert #t) - (test-end) - (test-assert "y" #f)))) - -(test-end) ; 8.8 - -(test-end "8. Test-runner") - -(test-begin "9. Test Result Properties") - -(test-begin "9.1. test-result-alist") - -(define (symbol-alist? l) - (if (null? l) - #t - (and (pair? l) - (pair? (car l)) - (symbol? (caar l)) - (symbol-alist? (cdr l))))) - -;;; check the various syntactic forms - -(test-assert (symbol-alist? - (car (on-test-runner - (lambda () - (test-assert #t)) - (lambda (r) - (test-result-alist r)))))) - -(test-assert (symbol-alist? - (car (on-test-runner - (lambda () - (test-assert #t)) - (lambda (r) - (test-result-alist r)))))) - -;;; check to make sure the required properties are returned - -(test-equal '((result-kind . pass)) - (prop-runner - '(result-kind) - (lambda () - (test-assert #t))) - ) - -(test-equal - '((result-kind . fail) - (expected-value . 2) - (actual-value . 3)) - (prop-runner - '(result-kind expected-value actual-value) - (lambda () - (test-equal 2 (+ 1 2))))) - -(test-end "9.1. test-result-alist") - -(test-begin "9.2. test-result-ref") - -(test-equal '(pass) - (on-test-runner - (lambda () - (test-assert #t)) - (lambda (r) - (test-result-ref r 'result-kind)))) - -(test-equal '(pass) - (on-test-runner - (lambda () - (test-assert #t)) - (lambda (r) - (test-result-ref r 'result-kind)))) - -(test-equal '(fail pass) - (on-test-runner - (lambda () - (test-assert (= 1 2)) - (test-assert (= 1 1))) - (lambda (r) - (test-result-ref r 'result-kind)))) - -(test-end "9.2. test-result-ref") - -(test-begin "9.3. test-result-set!") - -(test-equal '(100 100) - (on-test-runner - (lambda () - (test-assert (= 1 2)) - (test-assert (= 1 1))) - (lambda (r) - (test-result-set! r 'foo 100) - (test-result-ref r 'foo)))) - -(test-end "9.3. test-result-set!") - -(test-end "9. Test Result Properties") - -;;; -;;; -;;; - -;#| Time to stop having fun... -; -;(test-begin "9. For fun, some meta-test errors") -; -;(test-equal -; "9.1. Really PASSes, but test like it should FAIL" -; '(() ("b") () () ()) -; (triv-runner -; (lambda () -; (test-assert "b" #t)))) -; -;(test-expect-fail "9.2. Expect to FAIL and do so") -;(test-expect-fail "9.3. Expect to FAIL but PASS") -;(test-skip "9.4. SKIP this one") -; -;(test-assert "9.2. Expect to FAIL and do so" #f) -;(test-assert "9.3. Expect to FAIL but PASS" #t) -;(test-assert "9.4. SKIP this one" #t) -; -;(test-end) -; |# - -(test-end "SRFI 64 - Meta-Test Suite") - -;;; -;;; Copyright (C) Philip L. Bewig (2007). All Rights Reserved. - -;;; Made an R7RS library by Taylan Ulrich Bayırlı/Kammer, Copyright (C) 2014. - -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to -;;; deal in the Software without restriction, including without limitation the -;;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -;;; sell copies of the Software, and to permit persons to whom the Software is -;;; furnished to do so, subject to the following conditions: - -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. - -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -;;; Eval these in Emacs: -;; (put 'stream-lambda 'scheme-indent-function 1) -;; (put 'stream-let 'scheme-indent-function 2) - -(define-syntax define-stream - (syntax-rules () - ((define-stream (name . formal) body0 body1 ...) - (define name (stream-lambda formal body0 body1 ...))))) - -(define (list->stream objs) - (define list->stream - (stream-lambda (objs) - (if (null? objs) - stream-null - (stream-cons (car objs) (list->stream (cdr objs)))))) - (if (not (list? objs)) - (error "non-list argument" objs) - (list->stream objs))) - -(define (port->stream . port) - (define port->stream - (stream-lambda (p) - (let ((c (read-char p))) - (if (eof-object? c) - stream-null - (stream-cons c (port->stream p)))))) - (let ((p (if (null? port) (current-input-port) (car port)))) - (if (not (input-port? p)) - (error "non-input-port argument" p) - (port->stream p)))) - -(define-syntax stream - (syntax-rules () - ((stream) stream-null) - ((stream x y ...) (stream-cons x (stream y ...))))) - -(define (stream->list . args) - (let ((n (if (= 1 (length args)) #f (car args))) - (strm (if (= 1 (length args)) (car args) (cadr args)))) - (cond - ((not (stream? strm)) (error "non-stream argument" strm)) - ((and n (not (integer? n))) (error "non-integer count" n)) - ((and n (negative? n)) (error "negative count" n)) - (else (let loop ((n (if n n -1)) (strm strm)) - (if (or (zero? n) (stream-null? strm)) - '() - (cons (stream-car strm) - (loop (- n 1) (stream-cdr strm))))))))) - -(define (stream-append . strms) - (define stream-append - (stream-lambda (strms) - (cond - ((null? (cdr strms)) (car strms)) - ((stream-null? (car strms)) (stream-append (cdr strms))) - (else (stream-cons (stream-car (car strms)) - (stream-append (cons (stream-cdr (car strms)) - (cdr strms)))))))) - (cond - ((null? strms) stream-null) - ((find (lambda (x) (not (stream? x))) strms) - => (lambda (strm) - (error "non-stream argument" strm))) - (else (stream-append strms)))) - -(define (stream-concat strms) - (define stream-concat - (stream-lambda (strms) - (cond - ((stream-null? strms) stream-null) - ((not (stream? (stream-car strms))) - (error "non-stream object in input stream" strms)) - ((stream-null? (stream-car strms)) - (stream-concat (stream-cdr strms))) - (else (stream-cons - (stream-car (stream-car strms)) - (stream-concat - (stream-cons (stream-cdr (stream-car strms)) - (stream-cdr strms)))))))) - (if (not (stream? strms)) - (error "non-stream argument" strms) - (stream-concat strms))) - -(define stream-constant - (stream-lambda objs - (cond - ((null? objs) stream-null) - ((null? (cdr objs)) (stream-cons (car objs) - (stream-constant (car objs)))) - (else (stream-cons (car objs) - (apply stream-constant - (append (cdr objs) (list (car objs))))))))) - -(define (stream-drop n strm) - (define stream-drop - (stream-lambda (n strm) - (if (or (zero? n) (stream-null? strm)) - strm - (stream-drop (- n 1) (stream-cdr strm))))) - (cond - ((not (integer? n)) (error "non-integer argument" n)) - ((negative? n) (error "negative argument" n)) - ((not (stream? strm)) (error "non-stream argument" strm)) - (else (stream-drop n strm)))) - -(define (stream-drop-while pred? strm) - (define stream-drop-while - (stream-lambda (strm) - (if (and (stream-pair? strm) (pred? (stream-car strm))) - (stream-drop-while (stream-cdr strm)) - strm))) - (cond - ((not (procedure? pred?)) (error "non-procedural argument" pred?)) - ((not (stream? strm)) (error "non-stream argument" strm)) - (else (stream-drop-while strm)))) - -(define (stream-filter pred? strm) - (define stream-filter - (stream-lambda (strm) - (cond - ((stream-null? strm) stream-null) - ((pred? (stream-car strm)) - (stream-cons (stream-car strm) (stream-filter (stream-cdr strm)))) - (else (stream-filter (stream-cdr strm)))))) - (cond - ((not (procedure? pred?)) (error "non-procedural argument" pred?)) - ((not (stream? strm)) (error "non-stream argument" strm)) - (else (stream-filter strm)))) - -(define (stream-fold proc base strm) - (cond - ((not (procedure? proc)) (error "non-procedural argument" proc)) - ((not (stream? strm)) (error "non-stream argument" strm)) - (else (let loop ((base base) (strm strm)) - (if (stream-null? strm) - base - (loop (proc base (stream-car strm)) (stream-cdr strm))))))) - -(define (stream-for-each proc . strms) - (define (stream-for-each strms) - (if (not (find stream-null? strms)) - (begin (apply proc (map stream-car strms)) - (stream-for-each (map stream-cdr strms))))) - (cond - ((not (procedure? proc)) (error "non-procedural argument" proc)) - ((null? strms) (error "no stream arguments")) - ((find (lambda (x) (not (stream? x))) strms) - => (lambda (strm) - (error "non-stream argument" strm))) - (else (stream-for-each strms)))) - -(define (stream-from first . step) - (define stream-from - (stream-lambda (first delta) - (stream-cons first (stream-from (+ first delta) delta)))) - (let ((delta (if (null? step) 1 (car step)))) - (cond - ((not (number? first)) (error "non-numeric starting number" first)) - ((not (number? delta)) (error "non-numeric step size" delta)) - (else (stream-from first delta))))) - -(define (stream-iterate proc base) - (define stream-iterate - (stream-lambda (base) - (stream-cons base (stream-iterate (proc base))))) - (if (not (procedure? proc)) - (error "non-procedural argument" proc) - (stream-iterate base))) - -(define (stream-length strm) - (if (not (stream? strm)) - (error "non-stream argument" strm) - (let loop ((len 0) (strm strm)) - (if (stream-null? strm) - len - (loop (+ len 1) (stream-cdr strm)))))) - -(define-syntax stream-let - (syntax-rules () - ((stream-let tag ((name val) ...) body1 body2 ...) - ((letrec ((tag (stream-lambda (name ...) body1 body2 ...))) - tag) - val ...)))) - -(define (stream-map proc . strms) - (define stream-map - (stream-lambda (strms) - (if (find stream-null? strms) - stream-null - (stream-cons (apply proc (map stream-car strms)) - (stream-map (map stream-cdr strms)))))) - (cond - ((not (procedure? proc)) (error "non-procedural argument" proc)) - ((null? strms) (error "no stream arguments")) - ((find (lambda (x) (not (stream? x))) strms) - => (lambda (strm) - (error "non-stream argument" strm))) - (else (stream-map strms)))) - -(define-syntax stream-match - (syntax-rules () - ((stream-match strm-expr clause ...) - (let ((strm strm-expr)) - (cond - ((not (stream? strm)) (error "non-stream argument" strm)) - ((stream-match-test strm clause) => car) ... - (else (error "pattern failure"))))))) - -(define-syntax stream-match-test - (syntax-rules () - ((stream-match-test strm (pattern fender expr)) - (stream-match-pattern strm pattern () (and fender (list expr)))) - ((stream-match-test strm (pattern expr)) - (stream-match-pattern strm pattern () (list expr))))) - -(define-syntax stream-match-pattern - (syntax-rules (_) - ((stream-match-pattern strm () (binding ...) body) - (and (stream-null? strm) (let (binding ...) body))) - ((stream-match-pattern strm (_ . rest) (binding ...) body) - (and (stream-pair? strm) - (let ((strm (stream-cdr strm))) - (stream-match-pattern strm rest (binding ...) body)))) - ((stream-match-pattern strm (var . rest) (binding ...) body) - (and (stream-pair? strm) - (let ((temp (stream-car strm)) (strm (stream-cdr strm))) - (stream-match-pattern strm rest ((var temp) binding ...) body)))) - ((stream-match-pattern strm _ (binding ...) body) - (let (binding ...) body)) - ((stream-match-pattern strm var (binding ...) body) - (let ((var strm) binding ...) body)))) - -(define-syntax stream-of - (syntax-rules () - ((_ expr rest ...) - (stream-of-aux expr stream-null rest ...)))) - -(define-syntax stream-of-aux - (syntax-rules (in is) - ((stream-of-aux expr base) - (stream-cons expr base)) - ((stream-of-aux expr base (var in stream) rest ...) - (stream-let loop ((strm stream)) - (if (stream-null? strm) - base - (let ((var (stream-car strm))) - (stream-of-aux expr (loop (stream-cdr strm)) rest ...))))) - ((stream-of-aux expr base (var is exp) rest ...) - (let ((var exp)) (stream-of-aux expr base rest ...))) - ((stream-of-aux expr base pred? rest ...) - (if pred? (stream-of-aux expr base rest ...) base)))) - -(define (stream-range first past . step) - (define stream-range - (stream-lambda (first past delta lt?) - (if (lt? first past) - (stream-cons first (stream-range (+ first delta) past delta lt?)) - stream-null))) - (cond - ((not (number? first)) (error "non-numeric starting number" first)) - ((not (number? past)) (error "non-numeric ending number" past)) - (else (let ((delta (cond ((pair? step) (car step)) - ((< first past) 1) - (else -1)))) - (if (not (number? delta)) - (error "non-numeric step size" delta) - (let ((lt? (if (< 0 delta) < >))) - (stream-range first past delta lt?))))))) - -(define (stream-ref strm n) - (cond - ((not (stream? strm)) (error "non-stream argument" strm)) - ((not (integer? n)) (error "non-integer argument" n)) - ((negative? n) (error "negative argument" n)) - (else (let loop ((strm strm) (n n)) - (cond - ((stream-null? strm) (error "beyond end of stream" strm)) - ((zero? n) (stream-car strm)) - (else (loop (stream-cdr strm) (- n 1)))))))) - -(define (stream-reverse strm) - (define stream-reverse - (stream-lambda (strm rev) - (if (stream-null? strm) - rev - (stream-reverse (stream-cdr strm) - (stream-cons (stream-car strm) rev))))) - (if (not (stream? strm)) - (error "non-stream argument" strm) - (stream-reverse strm stream-null))) - -(define (stream-scan proc base strm) - (define stream-scan - (stream-lambda (base strm) - (if (stream-null? strm) - (stream base) - (stream-cons base (stream-scan (proc base (stream-car strm)) - (stream-cdr strm)))))) - (cond - ((not (procedure? proc)) (error "non-procedural argument" proc)) - ((not (stream? strm)) (error "non-stream argument" strm)) - (else (stream-scan base strm)))) - -(define (stream-take n strm) - (define stream-take - (stream-lambda (n strm) - (if (or (stream-null? strm) (zero? n)) - stream-null - (stream-cons (stream-car strm) - (stream-take (- n 1) (stream-cdr strm)))))) - (cond - ((not (stream? strm)) (error "non-stream argument" strm)) - ((not (integer? n)) (error "non-integer argument" n)) - ((negative? n) (error "negative argument" n)) - (else (stream-take n strm)))) - -(define (stream-take-while pred? strm) - (define stream-take-while - (stream-lambda (strm) - (cond - ((stream-null? strm) stream-null) - ((pred? (stream-car strm)) - (stream-cons (stream-car strm) - (stream-take-while (stream-cdr strm)))) - (else stream-null)))) - (cond - ((not (stream? strm)) (error "non-stream argument" strm)) - ((not (procedure? pred?)) (error "non-procedural argument" pred?)) - (else (stream-take-while strm)))) - -(define (stream-unfold mapper pred? generator base) - (define stream-unfold - (stream-lambda (base) - (if (pred? base) - (stream-cons (mapper base) (stream-unfold (generator base))) - stream-null))) - (cond - ((not (procedure? mapper)) (error "non-procedural mapper" mapper)) - ((not (procedure? pred?)) (error "non-procedural pred?" pred?)) - ((not (procedure? generator)) (error "non-procedural generator" generator)) - (else (stream-unfold base)))) - -(define (stream-unfolds gen seed) - (define (len-values gen seed) - (call-with-values - (lambda () (gen seed)) - (lambda vs (- (length vs) 1)))) - (define unfold-result-stream - (stream-lambda (gen seed) - (call-with-values - (lambda () (gen seed)) - (lambda (next . results) - (stream-cons results (unfold-result-stream gen next)))))) - (define result-stream->output-stream - (stream-lambda (result-stream i) - (let ((result (list-ref (stream-car result-stream) (- i 1)))) - (cond - ((pair? result) - (stream-cons - (car result) - (result-stream->output-stream (stream-cdr result-stream) i))) - ((not result) - (result-stream->output-stream (stream-cdr result-stream) i)) - ((null? result) stream-null) - (else (error "can't happen")))))) - (define (result-stream->output-streams result-stream) - (let loop ((i (len-values gen seed)) (outputs '())) - (if (zero? i) - (apply values outputs) - (loop (- i 1) (cons (result-stream->output-stream result-stream i) - outputs))))) - (if (not (procedure? gen)) - (error "non-procedural argument" gen) - (result-stream->output-streams (unfold-result-stream gen seed)))) - -(define (stream-zip . strms) - (define stream-zip - (stream-lambda (strms) - (if (find stream-null? strms) - stream-null - (stream-cons (map stream-car strms) - (stream-zip (map stream-cdr strms)))))) - (cond - ((null? strms) (error "no stream arguments")) - ((find (lambda (x) (not (stream? x))) strms) - => (lambda (strm) - (error "non-stream argument" strm))) - (else (stream-zip strms)))) -(define-library (srfi 41 derived) - (export - stream-null stream-cons stream? stream-null? stream-pair? stream-car - stream-cdr stream-lambda define-stream list->stream port->stream stream - stream->list stream-append stream-concat stream-constant stream-drop - stream-drop-while stream-filter stream-fold stream-for-each stream-from - stream-iterate stream-length stream-let stream-map stream-match _ - stream-of stream-range stream-ref stream-reverse stream-scan stream-take - stream-take-while stream-unfold stream-unfolds stream-zip - ) - (import - (scheme base) - (srfi 1) - (srfi 41 primitive)) - (include "derived.body.scm")) -;;; Copyright (C) Philip L. Bewig (2007). All Rights Reserved. - -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to -;;; deal in the Software without restriction, including without limitation the -;;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -;;; sell copies of the Software, and to permit persons to whom the Software is -;;; furnished to do so, subject to the following conditions: - -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. - -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(library (streams derived) - - (export stream-null stream-cons stream? stream-null? stream-pair? stream-car - stream-cdr stream-lambda define-stream list->stream port->stream stream - stream->list stream-append stream-concat stream-constant stream-drop - stream-drop-while stream-filter stream-fold stream-for-each stream-from - stream-iterate stream-length stream-let stream-map stream-match _ - stream-of stream-range stream-ref stream-reverse stream-scan stream-take - stream-take-while stream-unfold stream-unfolds stream-zip) - - (import (rnrs) (streams primitive)) - - (define-syntax define-stream - (syntax-rules () - ((define-stream (name . formal) body0 body1 ...) - (define name (stream-lambda formal body0 body1 ...))))) - - (define (list->stream objs) - (define list->stream - (stream-lambda (objs) - (if (null? objs) - stream-null - (stream-cons (car objs) (list->stream (cdr objs)))))) - (if (not (list? objs)) - (error 'list->stream "non-list argument") - (list->stream objs))) - - (define (port->stream . port) - (define port->stream - (stream-lambda (p) - (let ((c (read-char p))) - (if (eof-object? c) - stream-null - (stream-cons c (port->stream p)))))) - (let ((p (if (null? port) (current-input-port) (car port)))) - (if (not (input-port? p)) - (error 'port->stream "non-input-port argument") - (port->stream p)))) - - (define-syntax stream - (syntax-rules () - ((stream) stream-null) - ((stream x y ...) (stream-cons x (stream y ...))))) - - (define (stream->list . args) - (let ((n (if (= 1 (length args)) #f (car args))) - (strm (if (= 1 (length args)) (car args) (cadr args)))) - (cond ((not (stream? strm)) (error 'stream->list "non-stream argument")) - ((and n (not (integer? n))) (error 'stream->list "non-integer count")) - ((and n (negative? n)) (error 'stream->list "negative count")) - (else (let loop ((n (if n n -1)) (strm strm)) - (if (or (zero? n) (stream-null? strm)) - '() - (cons (stream-car strm) (loop (- n 1) (stream-cdr strm))))))))) - - (define (stream-append . strms) - (define stream-append - (stream-lambda (strms) - (cond ((null? (cdr strms)) (car strms)) - ((stream-null? (car strms)) (stream-append (cdr strms))) - (else (stream-cons (stream-car (car strms)) - (stream-append (cons (stream-cdr (car strms)) (cdr strms)))))))) - (cond ((null? strms) stream-null) - ((exists (lambda (x) (not (stream? x))) strms) - (error 'stream-append "non-stream argument")) - (else (stream-append strms)))) - - (define (stream-concat strms) - (define stream-concat - (stream-lambda (strms) - (cond ((stream-null? strms) stream-null) - ((not (stream? (stream-car strms))) - (error 'stream-concat "non-stream object in input stream")) - ((stream-null? (stream-car strms)) - (stream-concat (stream-cdr strms))) - (else (stream-cons - (stream-car (stream-car strms)) - (stream-concat - (stream-cons (stream-cdr (stream-car strms)) (stream-cdr strms)))))))) - (if (not (stream? strms)) - (error 'stream-concat "non-stream argument") - (stream-concat strms))) - - (define stream-constant - (stream-lambda objs - (cond ((null? objs) stream-null) - ((null? (cdr objs)) (stream-cons (car objs) (stream-constant (car objs)))) - (else (stream-cons (car objs) - (apply stream-constant (append (cdr objs) (list (car objs))))))))) - - (define (stream-drop n strm) - (define stream-drop - (stream-lambda (n strm) - (if (or (zero? n) (stream-null? strm)) - strm - (stream-drop (- n 1) (stream-cdr strm))))) - (cond ((not (integer? n)) (error 'stream-drop "non-integer argument")) - ((negative? n) (error 'stream-drop "negative argument")) - ((not (stream? strm)) (error 'stream-drop "non-stream argument")) - (else (stream-drop n strm)))) - - (define (stream-drop-while pred? strm) - (define stream-drop-while - (stream-lambda (strm) - (if (and (stream-pair? strm) (pred? (stream-car strm))) - (stream-drop-while (stream-cdr strm)) - strm))) - (cond ((not (procedure? pred?)) (error 'stream-drop-while "non-procedural argument")) - ((not (stream? strm)) (error 'stream-drop-while "non-stream argument")) - (else (stream-drop-while strm)))) - - (define (stream-filter pred? strm) - (define stream-filter - (stream-lambda (strm) - (cond ((stream-null? strm) stream-null) - ((pred? (stream-car strm)) - (stream-cons (stream-car strm) (stream-filter (stream-cdr strm)))) - (else (stream-filter (stream-cdr strm)))))) - (cond ((not (procedure? pred?)) (error 'stream-filter "non-procedural argument")) - ((not (stream? strm)) (error 'stream-filter "non-stream argument")) - (else (stream-filter strm)))) - - (define (stream-fold proc base strm) - (cond ((not (procedure? proc)) (error 'stream-fold "non-procedural argument")) - ((not (stream? strm)) (error 'stream-fold "non-stream argument")) - (else (let loop ((base base) (strm strm)) - (if (stream-null? strm) - base - (loop (proc base (stream-car strm)) (stream-cdr strm))))))) - - (define (stream-for-each proc . strms) - (define (stream-for-each strms) - (if (not (exists stream-null? strms)) - (begin (apply proc (map stream-car strms)) - (stream-for-each (map stream-cdr strms))))) - (cond ((not (procedure? proc)) (error 'stream-for-each "non-procedural argument")) - ((null? strms) (error 'stream-for-each "no stream arguments")) - ((exists (lambda (x) (not (stream? x))) strms) - (error 'stream-for-each "non-stream argument")) - (else (stream-for-each strms)))) - - (define (stream-from first . step) - (define stream-from - (stream-lambda (first delta) - (stream-cons first (stream-from (+ first delta) delta)))) - (let ((delta (if (null? step) 1 (car step)))) - (cond ((not (number? first)) (error 'stream-from "non-numeric starting number")) - ((not (number? delta)) (error 'stream-from "non-numeric step size")) - (else (stream-from first delta))))) - - (define (stream-iterate proc base) - (define stream-iterate - (stream-lambda (base) - (stream-cons base (stream-iterate (proc base))))) - (if (not (procedure? proc)) - (error 'stream-iterate "non-procedural argument") - (stream-iterate base))) - - (define (stream-length strm) - (if (not (stream? strm)) - (error 'stream-length "non-stream argument") - (let loop ((len 0) (strm strm)) - (if (stream-null? strm) - len - (loop (+ len 1) (stream-cdr strm)))))) - - (define-syntax stream-let - (syntax-rules () - ((stream-let tag ((name val) ...) body1 body2 ...) - ((letrec ((tag (stream-lambda (name ...) body1 body2 ...))) tag) val ...)))) - - (define (stream-map proc . strms) - (define stream-map - (stream-lambda (strms) - (if (exists stream-null? strms) - stream-null - (stream-cons (apply proc (map stream-car strms)) - (stream-map (map stream-cdr strms)))))) - (cond ((not (procedure? proc)) (error 'stream-map "non-procedural argument")) - ((null? strms) (error 'stream-map "no stream arguments")) - ((exists (lambda (x) (not (stream? x))) strms) - (error 'stream-map "non-stream argument")) - (else (stream-map strms)))) - - (define-syntax stream-match - (syntax-rules () - ((stream-match strm-expr clause ...) - (let ((strm strm-expr)) - (cond - ((not (stream? strm)) (error 'stream-match "non-stream argument")) - ((stream-match-test strm clause) => car) ... - (else (error 'stream-match "pattern failure"))))))) - - (define-syntax stream-match-test - (syntax-rules () - ((stream-match-test strm (pattern fender expr)) - (stream-match-pattern strm pattern () (and fender (list expr)))) - ((stream-match-test strm (pattern expr)) - (stream-match-pattern strm pattern () (list expr))))) - - (define-syntax stream-match-pattern - (lambda (x) - (define (wildcard? x) - (and (identifier? x) - (free-identifier=? x (syntax _)))) - (syntax-case x () - ((stream-match-pattern strm () (binding ...) body) - (syntax (and (stream-null? strm) (let (binding ...) body)))) - ((stream-match-pattern strm (w? . rest) (binding ...) body) - (wildcard? #'w?) - (syntax (and (stream-pair? strm) - (let ((strm (stream-cdr strm))) - (stream-match-pattern strm rest (binding ...) body))))) - ((stream-match-pattern strm (var . rest) (binding ...) body) - (syntax (and (stream-pair? strm) - (let ((temp (stream-car strm)) (strm (stream-cdr strm))) - (stream-match-pattern strm rest ((var temp) binding ...) body))))) - ((stream-match-pattern strm w? (binding ...) body) - (wildcard? #'w?) - (syntax (let (binding ...) body))) - ((stream-match-pattern strm var (binding ...) body) - (syntax (let ((var strm) binding ...) body)))))) - - (define-syntax stream-of - (syntax-rules () - ((_ expr rest ...) - (stream-of-aux expr stream-null rest ...)))) - - (define-syntax stream-of-aux - (syntax-rules (in is) - ((stream-of-aux expr base) - (stream-cons expr base)) - ((stream-of-aux expr base (var in stream) rest ...) - (stream-let loop ((strm stream)) - (if (stream-null? strm) - base - (let ((var (stream-car strm))) - (stream-of-aux expr (loop (stream-cdr strm)) rest ...))))) - ((stream-of-aux expr base (var is exp) rest ...) - (let ((var exp)) (stream-of-aux expr base rest ...))) - ((stream-of-aux expr base pred? rest ...) - (if pred? (stream-of-aux expr base rest ...) base)))) - - (define (stream-range first past . step) - (define stream-range - (stream-lambda (first past delta lt?) - (if (lt? first past) - (stream-cons first (stream-range (+ first delta) past delta lt?)) - stream-null))) - (cond ((not (number? first)) (error 'stream-range "non-numeric starting number")) - ((not (number? past)) (error 'stream-range "non-numeric ending number")) - (else (let ((delta (cond ((pair? step) (car step)) ((< first past) 1) (else -1)))) - (if (not (number? delta)) - (error 'stream-range "non-numeric step size") - (let ((lt? (if (< 0 delta) < >))) - (stream-range first past delta lt?))))))) - - (define (stream-ref strm n) - (cond ((not (stream? strm)) (error 'stream-ref "non-stream argument")) - ((not (integer? n)) (error 'stream-ref "non-integer argument")) - ((negative? n) (error 'stream-ref "negative argument")) - (else (let loop ((strm strm) (n n)) - (cond ((stream-null? strm) (error 'stream-ref "beyond end of stream")) - ((zero? n) (stream-car strm)) - (else (loop (stream-cdr strm) (- n 1)))))))) - - (define (stream-reverse strm) - (define stream-reverse - (stream-lambda (strm rev) - (if (stream-null? strm) - rev - (stream-reverse (stream-cdr strm) (stream-cons (stream-car strm) rev))))) - (if (not (stream? strm)) - (error 'stream-reverse "non-stream argument") - (stream-reverse strm stream-null))) - - (define (stream-scan proc base strm) - (define stream-scan - (stream-lambda (base strm) - (if (stream-null? strm) - (stream base) - (stream-cons base (stream-scan (proc base (stream-car strm)) (stream-cdr strm)))))) - (cond ((not (procedure? proc)) (error 'stream-scan "non-procedural argument")) - ((not (stream? strm)) (error 'stream-scan "non-stream argument")) - (else (stream-scan base strm)))) - - (define (stream-take n strm) - (define stream-take - (stream-lambda (n strm) - (if (or (stream-null? strm) (zero? n)) - stream-null - (stream-cons (stream-car strm) (stream-take (- n 1) (stream-cdr strm)))))) - (cond ((not (stream? strm)) (error 'stream-take "non-stream argument")) - ((not (integer? n)) (error 'stream-take "non-integer argument")) - ((negative? n) (error 'stream-take "negative argument")) - (else (stream-take n strm)))) - - (define (stream-take-while pred? strm) - (define stream-take-while - (stream-lambda (strm) - (cond ((stream-null? strm) stream-null) - ((pred? (stream-car strm)) - (stream-cons (stream-car strm) (stream-take-while (stream-cdr strm)))) - (else stream-null)))) - (cond ((not (stream? strm)) (error 'stream-take-while "non-stream argument")) - ((not (procedure? pred?)) (error 'stream-take-while "non-procedural argument")) - (else (stream-take-while strm)))) - - (define (stream-unfold mapper pred? generator base) - (define stream-unfold - (stream-lambda (base) - (if (pred? base) - (stream-cons (mapper base) (stream-unfold (generator base))) - stream-null))) - (cond ((not (procedure? mapper)) (error 'stream-unfold "non-procedural mapper")) - ((not (procedure? pred?)) (error 'stream-unfold "non-procedural pred?")) - ((not (procedure? generator)) (error 'stream-unfold "non-procedural generator")) - (else (stream-unfold base)))) - - (define (stream-unfolds gen seed) - (define (len-values gen seed) - (call-with-values - (lambda () (gen seed)) - (lambda vs (- (length vs) 1)))) - (define unfold-result-stream - (stream-lambda (gen seed) - (call-with-values - (lambda () (gen seed)) - (lambda (next . results) - (stream-cons results (unfold-result-stream gen next)))))) - (define result-stream->output-stream - (stream-lambda (result-stream i) - (let ((result (list-ref (stream-car result-stream) (- i 1)))) - (cond ((pair? result) - (stream-cons - (car result) - (result-stream->output-stream (stream-cdr result-stream) i))) - ((not result) - (result-stream->output-stream (stream-cdr result-stream) i)) - ((null? result) stream-null) - (else (error 'stream-unfolds "can't happen")))))) - (define (result-stream->output-streams result-stream) - (let loop ((i (len-values gen seed)) (outputs '())) - (if (zero? i) - (apply values outputs) - (loop (- i 1) (cons (result-stream->output-stream result-stream i) outputs))))) - (if (not (procedure? gen)) - (error 'stream-unfolds "non-procedural argument") - (result-stream->output-streams (unfold-result-stream gen seed)))) - - (define (stream-zip . strms) - (define stream-zip - (stream-lambda (strms) - (if (exists stream-null? strms) - stream-null - (stream-cons (map stream-car strms) (stream-zip (map stream-cdr strms)))))) - (cond ((null? strms) (error 'stream-zip "no stream arguments")) - ((exists (lambda (x) (not (stream? x))) strms) - (error 'stream-zip "non-stream argument")) - (else (stream-zip strms))))) -;;; Copyright (C) Philip L. Bewig (2007). All Rights Reserved. - -;;; Made an R7RS library by Taylan Ulrich Bayırlı/Kammer, Copyright (C) 2014. - -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to -;;; deal in the Software without restriction, including without limitation the -;;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -;;; sell copies of the Software, and to permit persons to whom the Software is -;;; furnished to do so, subject to the following conditions: - -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. - -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(define-record-type - (make-stream promise) - stream? - (promise stream-promise stream-promise!)) - -(define-syntax stream-lazy - (syntax-rules () - ((stream-lazy expr) - (make-stream - (cons 'lazy (lambda () expr)))))) - -(define (stream-eager expr) - (make-stream - (cons 'eager expr))) - -(define-syntax stream-delay - (syntax-rules () - ((stream-delay expr) - (stream-lazy (stream-eager expr))))) - -(define (stream-force promise) - (let ((content (stream-promise promise))) - (case (car content) - ((eager) (cdr content)) - ((lazy) (let* ((promise* ((cdr content))) - (content (stream-promise promise))) - (if (not (eqv? (car content) 'eager)) - (begin (set-car! content (car (stream-promise promise*))) - (set-cdr! content (cdr (stream-promise promise*))) - (stream-promise! promise* content))) - (stream-force promise)))))) - -(define stream-null (stream-delay (cons 'stream 'null))) - -(define-record-type - (make-stream-pare kar kdr) - stream-pare? - (kar stream-kar) - (kdr stream-kdr)) - -(define (stream-pair? obj) - (and (stream? obj) (stream-pare? (stream-force obj)))) - -(define (stream-null? obj) - (and (stream? obj) - (eqv? (stream-force obj) - (stream-force stream-null)))) - -(define-syntax stream-cons - (syntax-rules () - ((stream-cons obj strm) - (stream-eager (make-stream-pare (stream-delay obj) (stream-lazy strm)))))) - -(define (stream-car strm) - (cond ((not (stream? strm)) (error "non-stream" strm)) - ((stream-null? strm) (error "null stream" strm)) - (else (stream-force (stream-kar (stream-force strm)))))) - -(define (stream-cdr strm) - (cond ((not (stream? strm)) (error "non-stream" strm)) - ((stream-null? strm) (error "null stream" strm)) - (else (stream-kdr (stream-force strm))))) - -(define-syntax stream-lambda - (syntax-rules () - ((stream-lambda formals body0 body1 ...) - (lambda formals (stream-lazy (let () body0 body1 ...)))))) -(define-library (srfi 41 primitive) - (export - stream-null stream-cons stream? stream-null? stream-pair? - stream-car stream-cdr stream-lambda - ) - (import (scheme base)) - (include "primitive.body.scm")) -;;; Copyright (C) Philip L. Bewig (2007). All Rights Reserved. - -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to -;;; deal in the Software without restriction, including without limitation the -;;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -;;; sell copies of the Software, and to permit persons to whom the Software is -;;; furnished to do so, subject to the following conditions: - -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. - -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(library (streams primitive) - - (export stream-null stream-cons stream? stream-null? stream-pair? - stream-car stream-cdr stream-lambda) - - (import (rnrs) (rnrs mutable-pairs)) - - (define-record-type (stream-type make-stream stream?) - (fields (mutable box stream-promise stream-promise!))) - - (define-syntax stream-lazy - (syntax-rules () - ((stream-lazy expr) - (make-stream - (cons 'lazy (lambda () expr)))))) - - (define (stream-eager expr) - (make-stream - (cons 'eager expr))) - - (define-syntax stream-delay - (syntax-rules () - ((stream-delay expr) - (stream-lazy (stream-eager expr))))) - - (define (stream-force promise) - (let ((content (stream-promise promise))) - (case (car content) - ((eager) (cdr content)) - ((lazy) (let* ((promise* ((cdr content))) - (content (stream-promise promise))) - (if (not (eqv? (car content) 'eager)) - (begin (set-car! content (car (stream-promise promise*))) - (set-cdr! content (cdr (stream-promise promise*))) - (stream-promise! promise* content))) - (stream-force promise)))))) - - (define stream-null (stream-delay (cons 'stream 'null))) - - (define-record-type (stream-pare-type make-stream-pare stream-pare?) - (fields (immutable kar stream-kar) (immutable kdr stream-kdr))) - - (define (stream-pair? obj) - (and (stream? obj) (stream-pare? (stream-force obj)))) - - (define (stream-null? obj) - (and (stream? obj) - (eqv? (stream-force obj) - (stream-force stream-null)))) - - (define-syntax stream-cons - (syntax-rules () - ((stream-cons obj strm) - (stream-eager (make-stream-pare (stream-delay obj) (stream-lazy strm)))))) - - (define (stream-car strm) - (cond ((not (stream? strm)) (error 'stream-car "non-stream")) - ((stream-null? strm) (error 'stream-car "null stream")) - (else (stream-force (stream-kar (stream-force strm)))))) - - (define (stream-cdr strm) - (cond ((not (stream? strm)) (error 'stream-cdr "non-stream")) - ((stream-null? strm) (error 'stream-cdr "null stream")) - (else (stream-kdr (stream-force strm))))) - - (define-syntax stream-lambda - (syntax-rules () - ((stream-lambda formals body0 body1 ...) - (lambda formals (stream-lazy (let () body0 body1 ...))))))) -;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner -;; Added "full" support for Chicken, Gauche, Guile and SISC. -;; Alex Shinn, Copyright (c) 2005. -;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012. -;; Support for Guile 2 by Mark H Weaver , Copyright (c) 2014. -;; Refactored by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014, 2015. -;; -;; Permission is hereby granted, free of charge, to any person -;; obtaining a copy of this software and associated documentation -;; files (the "Software"), to deal in the Software without -;; restriction, including without limitation the rights to use, copy, -;; modify, merge, publish, distribute, sublicense, and/or sell copies -;; of the Software, and to permit persons to whom the Software is -;; furnished to do so, subject to the following conditions: -;; -;; The above copyright notice and this permission notice shall be -;; included in all copies or substantial portions of the Software. -;; -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -;; SOFTWARE. - -;;; Note: to prevent producing massive amounts of code from the macro-expand -;;; phase (which makes compile times suffer and may hit code size limits in some -;;; systems), keep macro bodies minimal by delegating work to procedures. - - -;;; Grouping - -(define (maybe-install-default-runner suite-name) - (when (not (test-runner-current)) - (let* ((log-file (string-append suite-name ".srfi64.log")) - (runner (test-runner-simple log-file))) - (%test-runner-auto-installed! runner #t) - (test-runner-current runner)))) - -(define (maybe-uninstall-default-runner) - (when (%test-runner-auto-installed? (test-runner-current)) - (test-runner-current #f))) - -(define test-begin - (case-lambda - ((name) - (test-begin name #f)) - ((name count) - (maybe-install-default-runner name) - (let ((r (test-runner-current))) - (let ((skip-list (%test-runner-skip-list r)) - (skip-save (%test-runner-skip-save r)) - (fail-list (%test-runner-fail-list r)) - (fail-save (%test-runner-fail-save r)) - (total-count (%test-runner-total-count r)) - (count-list (%test-runner-count-list r)) - (group-stack (test-runner-group-stack r))) - ((test-runner-on-group-begin r) r name count) - (%test-runner-skip-save! r (cons skip-list skip-save)) - (%test-runner-fail-save! r (cons fail-list fail-save)) - (%test-runner-count-list! r (cons (cons total-count count) - count-list)) - (test-runner-group-stack! r (cons name group-stack))))))) - -(define test-end - (case-lambda - (() - (test-end #f)) - ((name) - (let* ((r (test-runner-get)) - (groups (test-runner-group-stack r))) - (test-result-clear r) - (when (null? groups) - (error "test-end not in a group")) - (when (and name (not (equal? name (car groups)))) - ((test-runner-on-bad-end-name r) r name (car groups))) - (let* ((count-list (%test-runner-count-list r)) - (expected-count (cdar count-list)) - (saved-count (caar count-list)) - (group-count (- (%test-runner-total-count r) saved-count))) - (when (and expected-count - (not (= expected-count group-count))) - ((test-runner-on-bad-count r) r group-count expected-count)) - ((test-runner-on-group-end r) r) - (test-runner-group-stack! r (cdr (test-runner-group-stack r))) - (%test-runner-skip-list! r (car (%test-runner-skip-save r))) - (%test-runner-skip-save! r (cdr (%test-runner-skip-save r))) - (%test-runner-fail-list! r (car (%test-runner-fail-save r))) - (%test-runner-fail-save! r (cdr (%test-runner-fail-save r))) - (%test-runner-count-list! r (cdr count-list)) - (when (null? (test-runner-group-stack r)) - ((test-runner-on-final r) r) - (maybe-uninstall-default-runner))))))) - -(define-syntax test-group - (syntax-rules () - ((_ . *) - (%test-group (lambda () . *))))) - -(define (%test-group name thunk) - (begin - (maybe-install-default-runner name) - (let ((runner (test-runner-get))) - (test-result-clear runner) - (test-result-set! runner 'name name) - (unless (test-skip? runner) - (dynamic-wind - (lambda () (test-begin name)) - thunk - (lambda () (test-end name))))))) - -(define-syntax test-group-with-cleanup - (syntax-rules () - ((_ * ... ) - (test-group - (dynamic-wind (lambda () #f) - (lambda () * ...) - (lambda () )))))) - - -;;; Skipping, expected-failing, matching - -(define (test-skip . specs) - (let ((runner (test-runner-get))) - (%test-runner-skip-list! - runner (cons (apply test-match-all specs) - (%test-runner-skip-list runner))))) - -(define (test-skip? runner) - (let ((run-list (%test-runner-run-list runner)) - (skip-list (%test-runner-skip-list runner))) - (or (and run-list (not (any-pred run-list runner))) - (any-pred skip-list runner)))) - -(define (test-expect-fail . specs) - (let ((runner (test-runner-get))) - (%test-runner-fail-list! - runner (cons (apply test-match-all specs) - (%test-runner-fail-list runner))))) - -(define (test-match-any . specs) - (let ((preds (map make-pred specs))) - (lambda (runner) - (any-pred preds runner)))) - -(define (test-match-all . specs) - (let ((preds (map make-pred specs))) - (lambda (runner) - (every-pred preds runner)))) - -(define (make-pred spec) - (cond - ((procedure? spec) - spec) - ((integer? spec) - (test-match-nth 1 spec)) - ((string? spec) - (test-match-name spec)) - (else - (error "not a valid test specifier" spec)))) - -(define test-match-nth - (case-lambda - ((n) (test-match-nth n 1)) - ((n count) - (let ((i 0)) - (lambda (runner) - (set! i (+ i 1)) - (and (>= i n) (< i (+ n count)))))))) - -(define (test-match-name name) - (lambda (runner) - (equal? name (test-runner-test-name runner)))) - -;;; Beware: all predicates must be called because they might have side-effects; -;;; no early returning or and/or short-circuiting of procedure calls allowed. - -(define (any-pred preds object) - (let loop ((matched? #f) - (preds preds)) - (if (null? preds) - matched? - (let ((result ((car preds) object))) - (loop (or matched? result) - (cdr preds)))))) - -(define (every-pred preds object) - (let loop ((failed? #f) - (preds preds)) - (if (null? preds) - (not failed?) - (let ((result ((car preds) object))) - (loop (or failed? (not result)) - (cdr preds)))))) - -;;; Actual testing - -(define-syntax false-if-error - (syntax-rules () - ((_ ) - (guard (error - (else - (test-result-set! 'actual-error error) - #f)) - )))) - -(define (test-prelude source-info runner name form) - (test-result-clear runner) - (set-source-info! runner source-info) - (when name - (test-result-set! runner 'name name)) - (test-result-set! runner 'source-form form) - (let ((skip? (test-skip? runner))) - (if skip? - (test-result-set! runner 'result-kind 'skip) - (let ((fail-list (%test-runner-fail-list runner))) - (when (any-pred fail-list runner) - ;; For later inspection only. - (test-result-set! runner 'result-kind 'xfail)))) - ((test-runner-on-test-begin runner) runner) - (not skip?))) - -(define (test-postlude runner) - (let ((result-kind (test-result-kind runner))) - (case result-kind - ((pass) - (test-runner-pass-count! runner (+ 1 (test-runner-pass-count runner)))) - ((fail) - (test-runner-fail-count! runner (+ 1 (test-runner-fail-count runner)))) - ((xpass) - (test-runner-xpass-count! runner (+ 1 (test-runner-xpass-count runner)))) - ((xfail) - (test-runner-xfail-count! runner (+ 1 (test-runner-xfail-count runner)))) - ((skip) - (test-runner-skip-count! runner (+ 1 (test-runner-skip-count runner))))) - (%test-runner-total-count! runner (+ 1 (%test-runner-total-count runner))) - ((test-runner-on-test-end runner) runner))) - -(define (set-result-kind! runner pass?) - (test-result-set! runner 'result-kind - (if (eq? (test-result-kind runner) 'xfail) - (if pass? 'xpass 'xfail) - (if pass? 'pass 'fail)))) - -;;; We need to use some trickery to get the source info right. The important -;;; thing is to pass a syntax object that is a pair to `source-info', and make -;;; sure this syntax object comes from user code and not from ourselves. - -(define-syntax test-assert - (syntax-rules () - ((_ . ) - (test-assert/source-info (source-info ) . )))) - -(define-syntax test-assert/source-info - (syntax-rules () - ((_ ) - (test-assert/source-info #f )) - ((_ ) - (%test-assert ' (lambda () ))))) - -(define (%test-assert source-info name form thunk) - (let ((runner (test-runner-get))) - (when (test-prelude source-info runner name form) - (let ((val (false-if-error (thunk) runner))) - (test-result-set! runner 'actual-value val) - (set-result-kind! runner val))) - (test-postlude runner))) - -(define-syntax test-compare - (syntax-rules () - ((_ . ) - (test-compare/source-info (source-info ) . )))) - -(define-syntax test-compare/source-info - (syntax-rules () - ((_ ) - (test-compare/source-info #f )) - ((_ ) - (%test-compare ' - (lambda () ))))) - -(define (%test-compare source-info compare name expected form thunk) - (let ((runner (test-runner-get))) - (when (test-prelude source-info runner name form) - (test-result-set! runner 'expected-value expected) - (let ((pass? (false-if-error - (let ((val (thunk))) - (test-result-set! runner 'actual-value val) - (compare expected val)) - runner))) - (set-result-kind! runner pass?))) - (test-postlude runner))) - -(define-syntax test-equal - (syntax-rules () - ((_ . ) - (test-compare/source-info (source-info ) equal? . )))) - -(define-syntax test-eqv - (syntax-rules () - ((_ . ) - (test-compare/source-info (source-info ) eqv? . )))) - -(define-syntax test-eq - (syntax-rules () - ((_ . ) - (test-compare/source-info (source-info ) eq? . )))) - -(define (approx= margin) - (lambda (value expected) - (let ((rval (real-part value)) - (ival (imag-part value)) - (rexp (real-part expected)) - (iexp (imag-part expected))) - (and (>= rval (- rexp margin)) - (>= ival (- iexp margin)) - (<= rval (+ rexp margin)) - (<= ival (+ iexp margin)))))) - -(define-syntax test-approximate - (syntax-rules () - ((_ . ) - (test-approximate/source-info (source-info ) . )))) - -(define-syntax test-approximate/source-info - (syntax-rules () - ((_ ) - (test-approximate/source-info - #f )) - ((_ ) - (test-compare/source-info - (approx= ) )))) - -(define (error-matches? error type) - (cond - ((eq? type #t) - #t) - ((condition-type? type) - (and (condition? error) (condition-has-type? error type))) - ((procedure? type) - (type error)) - (else - (let ((runner (test-runner-get))) - ((%test-runner-on-bad-error-type runner) runner type error)) - #f))) - -(define-syntax test-error - (syntax-rules () - ((_ . ) - (test-error/source-info (source-info ) . )))) - -(define-syntax test-error/source-info - (syntax-rules () - ((_ ) - (test-error/source-info #f #t )) - ((_ ) - (test-error/source-info #f )) - ((_ ) - (%test-error ' - (lambda () ))))) - -(define (%test-error source-info name error-type form thunk) - (let ((runner (test-runner-get))) - (when (test-prelude source-info runner name form) - (test-result-set! runner 'expected-error error-type) - (let ((pass? (guard (error (else (test-result-set! - runner 'actual-error error) - (error-matches? error error-type))) - (let ((val (thunk))) - (test-result-set! runner 'actual-value val)) - #f))) - (set-result-kind! runner pass?))) - (test-postlude runner))) - -(define (default-module) - (cond-expand - (guile (current-module)) - (else #f))) - -(define test-read-eval-string - (case-lambda - ((string) - (test-read-eval-string string (default-module))) - ((string env) - (let* ((port (open-input-string string)) - (form (read port))) - (if (eof-object? (read-char port)) - (if env - (eval form env) - (eval form)) - (error "(not at eof)")))))) - - -;;; Test runner control flow - -(define-syntax test-with-runner - (syntax-rules () - ((_ . *) - (let ((saved-runner (test-runner-current))) - (dynamic-wind - (lambda () (test-runner-current )) - (lambda () . *) - (lambda () (test-runner-current saved-runner))))))) - -(define (test-apply first . rest) - (let ((runner (if (test-runner? first) - first - (or (test-runner-current) (test-runner-create)))) - (run-list (if (test-runner? first) - (drop-right rest 1) - (cons first (drop-right rest 1)))) - (proc (last rest))) - (test-with-runner runner - (let ((saved-run-list (%test-runner-run-list runner))) - (%test-runner-run-list! runner run-list) - (proc) - (%test-runner-run-list! runner saved-run-list))))) - - -;;; Indicate success/failure via exit status - -(define (test-exit) - (let ((runner (test-runner-current))) - (when (not runner) - (error "No test runner installed. Might have been auto-removed -by test-end if you had not installed one explicitly.")) - (if (and (zero? (test-runner-xpass-count runner)) - (zero? (test-runner-fail-count runner))) - (exit 0) - (exit 1)))) - -;;; execution.scm ends here -(export - test-begin test-end test-group test-group-with-cleanup - - test-skip test-expect-fail - test-match-name test-match-nth - test-match-all test-match-any - - test-assert test-eqv test-eq test-equal test-approximate - test-error test-read-eval-string - - test-apply test-with-runner - - test-exit - ) -(define-library (srfi 64 execution) - (import - (scheme base) - (scheme case-lambda) - (scheme complex) - (scheme eval) - (scheme process-context) - (scheme read) - (srfi 1) - (srfi 35) - (srfi 48) - (srfi 64 source-info) - (srfi 64 test-runner) - (srfi 64 test-runner-simple)) - (include-library-declarations "execution.exports.sld") - (include "execution.body.scm")) -;; Copyright (c) 2015 Taylan Ulrich Bayırlı/Kammer -;; -;; Permission is hereby granted, free of charge, to any person -;; obtaining a copy of this software and associated documentation -;; files (the "Software"), to deal in the Software without -;; restriction, including without limitation the rights to use, copy, -;; modify, merge, publish, distribute, sublicense, and/or sell copies -;; of the Software, and to permit persons to whom the Software is -;; furnished to do so, subject to the following conditions: -;; -;; The above copyright notice and this permission notice shall be -;; included in all copies or substantial portions of the Software. -;; -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -;; SOFTWARE. - -;;; In some systems, a macro use like (source-info ...), that resides in a -;;; syntax-rules macro body, first gets inserted into the place where the -;;; syntax-rules macro was used, and then the transformer of 'source-info' is -;;; called with a syntax object that has the source location information of that -;;; position. That works fine when the user calls e.g. (test-assert ...), whose -;;; body contains (source-info ...); the user gets the source location of the -;;; (test-assert ...) call as intended, and not the source location of the real -;;; (source-info ...) call. - -;;; In other systems, *first* the (source-info ...) is processed to get its real -;;; position, which is within the body of a syntax-rules macro like test-assert, -;;; so no matter where the user calls (test-assert ...), they get source -;;; location information of where we defined test-assert with the call to -;;; (source-info ...) in its body. That's arguably more correct behavior, -;;; although in this case it makes our job a bit harder; we need to get the -;;; source location from an argument to 'source-info' instead. - -(define (canonical-syntax form arg) - (cond-expand - (kawa arg) - (guile-2 form) - (else #f))) - -(cond-expand - ((or kawa guile-2) - (define-syntax source-info - (lambda (stx) - (syntax-case stx () - ((_ ) - (let* ((stx (canonical-syntax stx (syntax ))) - (file (syntax-source-file stx)) - (line (syntax-source-line stx))) - (quasisyntax - (cons (unsyntax file) (unsyntax line))))))))) - (else - (define-syntax source-info - (syntax-rules () - ((_ ) - #f))))) - -(define (syntax-source-file stx) - (cond-expand - (kawa - (syntax-source stx)) - (guile-2 - (let ((source (syntax-source stx))) - (and source (assq-ref source 'filename)))) - (else - #f))) - -(define (syntax-source-line stx) - (cond-expand - (kawa - (syntax-line stx)) - (guile-2 - (let ((source (syntax-source stx))) - (and source (assq-ref source 'line)))) - (else - #f))) - -(define (set-source-info! runner source-info) - (when source-info - (test-result-set! runner 'source-file (car source-info)) - (test-result-set! runner 'source-line (cdr source-info)))) - -;;; source-info.body.scm ends here -(define-library (srfi 64 source-info) - (import - (scheme base) - (srfi 64 test-runner)) - (export source-info set-source-info!) - (include "source-info.body.scm")) -;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner -;; Added "full" support for Chicken, Gauche, Guile and SISC. -;; Alex Shinn, Copyright (c) 2005. -;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012. -;; Support for Guile 2 by Mark H Weaver , Copyright (c) 2014. -;; Refactored by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014, 2015. -;; -;; Permission is hereby granted, free of charge, to any person -;; obtaining a copy of this software and associated documentation -;; files (the "Software"), to deal in the Software without -;; restriction, including without limitation the rights to use, copy, -;; modify, merge, publish, distribute, sublicense, and/or sell copies -;; of the Software, and to permit persons to whom the Software is -;; furnished to do so, subject to the following conditions: -;; -;; The above copyright notice and this permission notice shall be -;; included in all copies or substantial portions of the Software. -;; -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -;; SOFTWARE. - -;;; Helpers - -(define (string-join strings delimiter) - (if (null? strings) - "" - (let loop ((result (car strings)) - (rest (cdr strings))) - (if (null? rest) - result - (loop (string-append result delimiter (car rest)) - (cdr rest)))))) - -(define (truncate-string string length) - (define (newline->space c) (if (char=? #\newline c) #\space c)) - (let* ((string (string-map newline->space string)) - (fill "...") - (fill-len (string-length fill)) - (string-len (string-length string))) - (if (<= string-len (+ length fill-len)) - string - (let-values (((q r) (floor/ length 4))) - ;; Left part gets 3/4 plus the remainder. - (let ((left-end (+ (* q 3) r)) - (right-start (- string-len q))) - (string-append (substring string 0 left-end) - fill - (substring string right-start string-len))))))) - -(define (print runner format-string . args) - (apply format #t format-string args) - (let ((port (%test-runner-log-port runner))) - (when port - (apply format port format-string args)))) - -;;; Main - -(define test-runner-simple - (case-lambda - (() - (test-runner-simple #f)) - ((log-file) - (let ((runner (test-runner-null))) - (test-runner-reset runner) - (test-runner-on-group-begin! runner test-on-group-begin-simple) - (test-runner-on-group-end! runner test-on-group-end-simple) - (test-runner-on-final! runner test-on-final-simple) - (test-runner-on-test-begin! runner test-on-test-begin-simple) - (test-runner-on-test-end! runner test-on-test-end-simple) - (test-runner-on-bad-count! runner test-on-bad-count-simple) - (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple) - (%test-runner-on-bad-error-type! runner on-bad-error-type) - (%test-runner-log-file! runner log-file) - runner)))) - -(when (not (test-runner-factory)) - (test-runner-factory test-runner-simple)) - -(define (test-on-group-begin-simple runner name count) - (when (null? (test-runner-group-stack runner)) - (maybe-start-logging runner) - (print runner "Test suite begin: ~a~%" name))) - -(define (test-on-group-end-simple runner) - (let ((name (car (test-runner-group-stack runner)))) - (when (= 1 (length (test-runner-group-stack runner))) - (print runner "Test suite end: ~a~%" name)))) - -(define (test-on-final-simple runner) - (print runner "Passes: ~a\n" (test-runner-pass-count runner)) - (print runner "Expected failures: ~a\n" (test-runner-xfail-count runner)) - (print runner "Failures: ~a\n" (test-runner-fail-count runner)) - (print runner "Unexpected passes: ~a\n" (test-runner-xpass-count runner)) - (print runner "Skipped tests: ~a~%" (test-runner-skip-count runner)) - (maybe-finish-logging runner)) - -(define (maybe-start-logging runner) - (let ((log-file (%test-runner-log-file runner))) - (when log-file - ;; The possible race-condition here doesn't bother us. - (when (file-exists? log-file) - (delete-file log-file)) - (%test-runner-log-port! runner (open-output-file log-file)) - (print runner "Writing log file: ~a~%" log-file)))) - -(define (maybe-finish-logging runner) - (let ((log-file (%test-runner-log-file runner))) - (when log-file - (print runner "Wrote log file: ~a~%" log-file) - (close-output-port (%test-runner-log-port runner))))) - -(define (test-on-test-begin-simple runner) - (values)) - -(define (test-on-test-end-simple runner) - (let* ((result-kind (test-result-kind runner)) - (result-kind-name (case result-kind - ((pass) "PASS") ((fail) "FAIL") - ((xpass) "XPASS") ((xfail) "XFAIL") - ((skip) "SKIP"))) - (name (let ((name (test-runner-test-name runner))) - (if (string=? "" name) - (truncate-string - (format #f "~a" (test-result-ref runner 'source-form)) - 30) - name))) - (label (string-join (append (test-runner-group-path runner) - (list name)) - ": "))) - (print runner "[~a] ~a~%" result-kind-name label) - (when (memq result-kind '(fail xpass)) - (let ((nil (cons #f #f))) - (define (found? value) - (not (eq? nil value))) - (define (maybe-print value message) - (when (found? value) - (print runner message value))) - (let ((file (test-result-ref runner 'source-file "(unknown file)")) - (line (test-result-ref runner 'source-line "(unknown line)")) - (expression (test-result-ref runner 'source-form)) - (expected-value (test-result-ref runner 'expected-value nil)) - (actual-value (test-result-ref runner 'actual-value nil)) - (expected-error (test-result-ref runner 'expected-error nil)) - (actual-error (test-result-ref runner 'actual-error nil))) - (print runner "~a:~a: ~s~%" file line expression) - (maybe-print expected-value "Expected value: ~s~%") - (maybe-print expected-error "Expected error: ~a~%") - (when (or (found? expected-value) (found? expected-error)) - (maybe-print actual-value "Returned value: ~s~%")) - (maybe-print actual-error "Raised error: ~a~%") - (newline)))))) - -(define (test-on-bad-count-simple runner count expected-count) - (print runner "*** Total number of tests was ~a but should be ~a. ***~%" - count expected-count) - (print runner - "*** Discrepancy indicates testsuite error or exceptions. ***~%")) - -(define (test-on-bad-end-name-simple runner begin-name end-name) - (error (format #f "Test-end \"~a\" does not match test-begin \"~a\"." - end-name begin-name))) - -(define (on-bad-error-type runner type error) - (print runner "WARNING: unknown error type predicate: ~a~%" type) - (print runner " error was: ~a~%" error)) - -;;; test-runner-simple.scm ends here -(export - test-runner-simple - ;; The following are exported so you can leverage their existing functionality - ;; when making more complex test runners. - test-on-group-begin-simple test-on-group-end-simple test-on-final-simple - test-on-test-begin-simple test-on-test-end-simple - test-on-bad-count-simple test-on-bad-end-name-simple - ) -(define-library (srfi 64 test-runner-simple) - (import - (scheme base) - (scheme case-lambda) - (scheme file) - (scheme write) - (srfi 48) - (srfi 64 test-runner)) - (include-library-declarations "test-runner-simple.exports.sld") - (include "test-runner-simple.body.scm")) -;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner -;; Added "full" support for Chicken, Gauche, Guile and SISC. -;; Alex Shinn, Copyright (c) 2005. -;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012. -;; Support for Guile 2 by Mark H Weaver , Copyright (c) 2014. -;; Refactored by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014, 2015. -;; -;; Permission is hereby granted, free of charge, to any person -;; obtaining a copy of this software and associated documentation -;; files (the "Software"), to deal in the Software without -;; restriction, including without limitation the rights to use, copy, -;; modify, merge, publish, distribute, sublicense, and/or sell copies -;; of the Software, and to permit persons to whom the Software is -;; furnished to do so, subject to the following conditions: -;; -;; The above copyright notice and this permission notice shall be -;; included in all copies or substantial portions of the Software. -;; -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -;; SOFTWARE. - - -;;; The data type - -(define-record-type - (make-test-runner) test-runner? - - (result-alist test-result-alist test-result-alist!) - - (pass-count test-runner-pass-count test-runner-pass-count!) - (fail-count test-runner-fail-count test-runner-fail-count!) - (xpass-count test-runner-xpass-count test-runner-xpass-count!) - (xfail-count test-runner-xfail-count test-runner-xfail-count!) - (skip-count test-runner-skip-count test-runner-skip-count!) - (total-count %test-runner-total-count %test-runner-total-count!) - - ;; Stack (list) of (count-at-start . expected-count): - (count-list %test-runner-count-list %test-runner-count-list!) - - ;; Normally #f, except when in a test-apply. - (run-list %test-runner-run-list %test-runner-run-list!) - - (skip-list %test-runner-skip-list %test-runner-skip-list!) - (fail-list %test-runner-fail-list %test-runner-fail-list!) - - (skip-save %test-runner-skip-save %test-runner-skip-save!) - (fail-save %test-runner-fail-save %test-runner-fail-save!) - - (group-stack test-runner-group-stack test-runner-group-stack!) - - ;; Note: on-test-begin and on-test-end are unrelated to the test-begin and - ;; test-end forms in the execution library. They're called at the - ;; beginning/end of each individual test, whereas the test-begin and test-end - ;; forms demarcate test groups. - - (on-group-begin test-runner-on-group-begin test-runner-on-group-begin!) - (on-test-begin test-runner-on-test-begin test-runner-on-test-begin!) - (on-test-end test-runner-on-test-end test-runner-on-test-end!) - (on-group-end test-runner-on-group-end test-runner-on-group-end!) - (on-final test-runner-on-final test-runner-on-final!) - (on-bad-count test-runner-on-bad-count test-runner-on-bad-count!) - (on-bad-end-name test-runner-on-bad-end-name test-runner-on-bad-end-name!) - - (on-bad-error-type %test-runner-on-bad-error-type - %test-runner-on-bad-error-type!) - - (aux-value test-runner-aux-value test-runner-aux-value!) - - (auto-installed %test-runner-auto-installed? %test-runner-auto-installed!) - - (log-file %test-runner-log-file %test-runner-log-file!) - (log-port %test-runner-log-port %test-runner-log-port!)) - -(define (test-runner-group-path runner) - (reverse (test-runner-group-stack runner))) - -(define (test-runner-reset runner) - (test-result-alist! runner '()) - (test-runner-pass-count! runner 0) - (test-runner-fail-count! runner 0) - (test-runner-xpass-count! runner 0) - (test-runner-xfail-count! runner 0) - (test-runner-skip-count! runner 0) - (%test-runner-total-count! runner 0) - (%test-runner-count-list! runner '()) - (%test-runner-run-list! runner #f) - (%test-runner-skip-list! runner '()) - (%test-runner-fail-list! runner '()) - (%test-runner-skip-save! runner '()) - (%test-runner-fail-save! runner '()) - (test-runner-group-stack! runner '())) - -(define (test-runner-null) - (define (test-null-callback . args) #f) - (let ((runner (make-test-runner))) - (test-runner-reset runner) - (test-runner-on-group-begin! runner test-null-callback) - (test-runner-on-group-end! runner test-null-callback) - (test-runner-on-final! runner test-null-callback) - (test-runner-on-test-begin! runner test-null-callback) - (test-runner-on-test-end! runner test-null-callback) - (test-runner-on-bad-count! runner test-null-callback) - (test-runner-on-bad-end-name! runner test-null-callback) - (%test-runner-on-bad-error-type! runner test-null-callback) - (%test-runner-auto-installed! runner #f) - (%test-runner-log-file! runner #f) - (%test-runner-log-port! runner #f) - runner)) - - -;;; State - -(define test-result-ref - (case-lambda - ((runner key) - (test-result-ref runner key #f)) - ((runner key default) - (let ((entry (assq key (test-result-alist runner)))) - (if entry (cdr entry) default))))) - -(define (test-result-set! runner key value) - (let* ((alist (test-result-alist runner)) - (entry (assq key alist))) - (if entry - (set-cdr! entry value) - (test-result-alist! runner (cons (cons key value) alist))))) - -(define (test-result-remove runner key) - (test-result-alist! runner (remove (lambda (entry) - (eq? key (car entry))) - (test-result-alist runner)))) - -(define (test-result-clear runner) - (test-result-alist! runner '())) - -(define (test-runner-test-name runner) - (or (test-result-ref runner 'name) "")) - -(define test-result-kind - (case-lambda - (() (test-result-kind (test-runner-get))) - ((runner) (test-result-ref runner 'result-kind)))) - -(define test-passed? - (case-lambda - (() (test-passed? (test-runner-get))) - ((runner) (memq (test-result-kind runner) '(pass xpass))))) - - -;;; Factory and current instance - -(define test-runner-factory (make-parameter #f)) - -(define (test-runner-create) ((test-runner-factory))) - -(define test-runner-current (make-parameter #f)) - -(define (test-runner-get) - (or (test-runner-current) - (error "test-runner not initialized - test-begin missing?"))) - -;;; test-runner.scm ends here -(export - ;; The data type - test-runner-null test-runner? test-runner-reset - - test-result-alist test-result-alist! - - test-runner-pass-count test-runner-pass-count! - test-runner-fail-count test-runner-fail-count! - test-runner-xpass-count test-runner-xpass-count! - test-runner-xfail-count test-runner-xfail-count! - test-runner-skip-count test-runner-skip-count! - %test-runner-total-count %test-runner-total-count! - - %test-runner-count-list %test-runner-count-list! - - %test-runner-run-list %test-runner-run-list! - - %test-runner-skip-list %test-runner-skip-list! - %test-runner-fail-list %test-runner-fail-list! - - %test-runner-skip-save %test-runner-skip-save! - %test-runner-fail-save %test-runner-fail-save! - - test-runner-group-stack test-runner-group-stack! - test-runner-group-path - - test-runner-on-test-begin test-runner-on-test-begin! - test-runner-on-test-end test-runner-on-test-end! - test-runner-on-group-begin test-runner-on-group-begin! - test-runner-on-group-end test-runner-on-group-end! - test-runner-on-final test-runner-on-final! - test-runner-on-bad-count test-runner-on-bad-count! - test-runner-on-bad-end-name test-runner-on-bad-end-name! - - %test-runner-on-bad-error-type %test-runner-on-bad-error-type! - - test-runner-aux-value test-runner-aux-value! - - %test-runner-log-file %test-runner-log-file! - %test-runner-log-port %test-runner-log-port! - - ;; State - test-result-ref test-result-set! - test-result-remove test-result-clear - test-runner-test-name test-result-kind test-passed? - - ;; Factory and current instance - test-runner-factory test-runner-create - test-runner-current test-runner-get - ) -(define-library (srfi 64 test-runner) - (import - (scheme base) - (scheme case-lambda) - (srfi 1)) - (include-library-declarations "test-runner.exports.sld") - (include "test-runner.body.scm")) -;;; SRFI-1 list-processing library -*- Scheme -*- -;;; Reference implementation -;;; -;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with -;;; this code as long as you do not remove this copyright notice or -;;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu. -;;; -Olin -;;; -;;; Made an R7RS library by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014. - -;;; See 1.upstream.scm in the same repository for a bunch of comments which I -;;; removed here because what they document does not necessarily correspond with -;;; the code anymore. Diff with the same file to see changes in the code. - -;;; Constructors -;;;;;;;;;;;;;;;; - -;;; Occasionally useful as a value to be passed to a fold or other -;;; higher-order procedure. -(define (xcons d a) (cons a d)) - -;;;; Recursively copy every cons. -;(define (tree-copy x) -; (let recur ((x x)) -; (if (not (pair? x)) x -; (cons (recur (car x)) (recur (cdr x)))))) - - -;(define (list . ans) ans) ; R4RS - - -;;; Make a list of length LEN. Elt i is (PROC i) for 0 <= i < LEN. - -(define (list-tabulate len proc) - (check-arg (lambda (n) (and (integer? n) (>= n 0))) len list-tabulate) - (check-arg procedure? proc list-tabulate) - (do ((i (- len 1) (- i 1)) - (ans '() (cons (proc i) ans))) - ((< i 0) ans))) - -;;; (cons* a1 a2 ... an) = (cons a1 (cons a2 (cons ... an))) -;;; (cons* a1) = a1 (cons* a1 a2 ...) = (cons a1 (cons* a2 ...)) -;;; -;;; (cons first (unfold not-pair? car cdr rest values)) - -(define (cons* first . rest) - (let recur ((x first) (rest rest)) - (if (pair? rest) - (cons x (recur (car rest) (cdr rest))) - x))) - -;;; IOTA count [start step] (start start+step ... start+(count-1)*step) - -(define (nonnegative? x) - (not (negative? x))) - -(define/opt (iota count (start 0) (step 1)) - (check-arg integer? count iota) - (check-arg nonnegative? count iota) - (check-arg number? start iota) - (check-arg number? step iota) - (let loop ((n 0) (r '())) - (if (= n count) - (reverse r) - (loop (+ 1 n) - (cons (+ start (* n step)) r))))) - -;;; I thought these were lovely, but the public at large did not share my -;;; enthusiasm... -;;; :IOTA to (0 ... to-1) -;;; :IOTA from to (from ... to-1) -;;; :IOTA from to step (from from+step ...) - -;;; IOTA: to (1 ... to) -;;; IOTA: from to (from+1 ... to) -;;; IOTA: from to step (from+step from+2step ...) - -;(define (%parse-iota-args arg1 rest-args proc) -; (let ((check (lambda (n) (check-arg integer? n proc)))) -; (check arg1) -; (if (pair? rest-args) -; (let ((arg2 (check (car rest-args))) -; (rest (cdr rest-args))) -; (if (pair? rest) -; (let ((arg3 (check (car rest))) -; (rest (cdr rest))) -; (if (pair? rest) (error "Too many parameters" proc arg1 rest-args) -; (values arg1 arg2 arg3))) -; (values arg1 arg2 1))) -; (values 0 arg1 1)))) -; -;(define (iota: arg1 . rest-args) -; (receive (from to step) (%parse-iota-args arg1 rest-args iota:) -; (let* ((numsteps (floor (/ (- to from) step))) -; (last-val (+ from (* step numsteps)))) -; (if (< numsteps 0) (error "Negative step count" iota: from to step)) -; (do ((steps-left numsteps (- steps-left 1)) -; (val last-val (- val step)) -; (ans '() (cons val ans))) -; ((<= steps-left 0) ans))))) -; -; -;(define (\:iota arg1 . rest-args) -; (receive (from to step) (%parse-iota-args arg1 rest-args :iota) -; (let* ((numsteps (ceiling (/ (- to from) step))) -; (last-val (+ from (* step (- numsteps 1))))) -; (if (< numsteps 0) (error "Negative step count" :iota from to step)) -; (do ((steps-left numsteps (- steps-left 1)) -; (val last-val (- val step)) -; (ans '() (cons val ans))) -; ((<= steps-left 0) ans))))) - - - -(define (circular-list val1 . vals) - (let ((ans (cons val1 vals))) - (set-cdr! (last-pair ans) ans) - ans)) - -;;; ::= () ; Empty proper list -;;; | (cons ) ; Proper-list pair -;;; Note that this definition rules out circular lists -- and this -;;; function is required to detect this case and return false. - -(define (proper-list? x) - (let lp ((x x) (lag x)) - (if (pair? x) - (let ((x (cdr x))) - (if (pair? x) - (let ((x (cdr x)) - (lag (cdr lag))) - (and (not (eq? x lag)) (lp x lag))) - (null? x))) - (null? x)))) - - -;;; A dotted list is a finite list (possibly of length 0) terminated -;;; by a non-nil value. Any non-cons, non-nil value (e.g., "foo" or 5) -;;; is a dotted list of length 0. -;;; -;;; ::= ; Empty dotted list -;;; | (cons ) ; Proper-list pair - -(define (dotted-list? x) - (let lp ((x x) (lag x)) - (if (pair? x) - (let ((x (cdr x))) - (if (pair? x) - (let ((x (cdr x)) - (lag (cdr lag))) - (and (not (eq? x lag)) (lp x lag))) - (not (null? x)))) - (not (null? x))))) - -(define (circular-list? x) - (let lp ((x x) (lag x)) - (and (pair? x) - (let ((x (cdr x))) - (and (pair? x) - (let ((x (cdr x)) - (lag (cdr lag))) - (or (eq? x lag) (lp x lag)))))))) - -(define (not-pair? x) (not (pair? x))) ; Inline me. - -;;; This is a legal definition which is fast and sloppy: -;;; (define null-list? not-pair?) -;;; but we'll provide a more careful one: -(define (null-list? l) - (cond ((pair? l) #f) - ((null? l) #t) - (else (error "null-list?: argument out of domain" l)))) - - -(define (list= = . lists) - (or (null? lists) ; special case - - (let lp1 ((list-a (car lists)) (others (cdr lists))) - (or (null? others) - (let ((list-b (car others)) - (others (cdr others))) - (if (eq? list-a list-b) ; EQ? => LIST= - (lp1 list-b others) - (let lp2 ((list-a list-a) (list-b list-b)) - (if (null-list? list-a) - (and (null-list? list-b) - (lp1 list-b others)) - (and (not (null-list? list-b)) - (= (car list-a) (car list-b)) - (lp2 (cdr list-a) (cdr list-b))))))))))) - - - -;;; R4RS, so commented out. -;(define (length x) ; LENGTH may diverge or -; (let lp ((x x) (len 0)) ; raise an error if X is -; (if (pair? x) ; a circular list. This version -; (lp (cdr x) (+ len 1)) ; diverges. -; len))) - -(define (length+ x) ; Returns #f if X is circular. - (let lp ((x x) (lag x) (len 0)) - (if (pair? x) - (let ((x (cdr x)) - (len (+ len 1))) - (if (pair? x) - (let ((x (cdr x)) - (lag (cdr lag)) - (len (+ len 1))) - (and (not (eq? x lag)) (lp x lag len))) - len)) - len))) - -(define (zip list1 . more-lists) (apply map list list1 more-lists)) - - -;;; Selectors -;;;;;;;;;;;;; - -;;; R4RS non-primitives: -;(define (caar x) (car (car x))) -;(define (cadr x) (car (cdr x))) -;(define (cdar x) (cdr (car x))) -;(define (cddr x) (cdr (cdr x))) -; -;(define (caaar x) (caar (car x))) -;(define (caadr x) (caar (cdr x))) -;(define (cadar x) (cadr (car x))) -;(define (caddr x) (cadr (cdr x))) -;(define (cdaar x) (cdar (car x))) -;(define (cdadr x) (cdar (cdr x))) -;(define (cddar x) (cddr (car x))) -;(define (cdddr x) (cddr (cdr x))) -; -;(define (caaaar x) (caaar (car x))) -;(define (caaadr x) (caaar (cdr x))) -;(define (caadar x) (caadr (car x))) -;(define (caaddr x) (caadr (cdr x))) -;(define (cadaar x) (cadar (car x))) -;(define (cadadr x) (cadar (cdr x))) -;(define (caddar x) (caddr (car x))) -;(define (cadddr x) (caddr (cdr x))) -;(define (cdaaar x) (cdaar (car x))) -;(define (cdaadr x) (cdaar (cdr x))) -;(define (cdadar x) (cdadr (car x))) -;(define (cdaddr x) (cdadr (cdr x))) -;(define (cddaar x) (cddar (car x))) -;(define (cddadr x) (cddar (cdr x))) -;(define (cdddar x) (cdddr (car x))) -;(define (cddddr x) (cdddr (cdr x))) - - -(define first car) -(define second cadr) -(define third caddr) -(define fourth cadddr) -(define (fifth x) (car (cddddr x))) -(define (sixth x) (cadr (cddddr x))) -(define (seventh x) (caddr (cddddr x))) -(define (eighth x) (cadddr (cddddr x))) -(define (ninth x) (car (cddddr (cddddr x)))) -(define (tenth x) (cadr (cddddr (cddddr x)))) - -(define (car+cdr pair) (values (car pair) (cdr pair))) - -;;; take & drop - -(define (take lis k) - (check-arg integer? k take) - (let recur ((lis lis) (k k)) - (if (zero? k) '() - (cons (car lis) - (recur (cdr lis) (- k 1)))))) - -(define (drop lis k) - (check-arg integer? k drop) - (let iter ((lis lis) (k k)) - (if (zero? k) lis (iter (cdr lis) (- k 1))))) - -(define (take! lis k) - (check-arg integer? k take!) - (if (zero? k) '() - (begin (set-cdr! (drop lis (- k 1)) '()) - lis))) - -;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list, -;;; off by K, then chasing down the list until the lead pointer falls off -;;; the end. - -(define (take-right lis k) - (check-arg integer? k take-right) - (let lp ((lag lis) (lead (drop lis k))) - (if (pair? lead) - (lp (cdr lag) (cdr lead)) - lag))) - -(define (drop-right lis k) - (check-arg integer? k drop-right) - (let recur ((lag lis) (lead (drop lis k))) - (if (pair? lead) - (cons (car lag) (recur (cdr lag) (cdr lead))) - '()))) - -;;; In this function, LEAD is actually K+1 ahead of LAG. This lets -;;; us stop LAG one step early, in time to smash its cdr to (). -(define (drop-right! lis k) - (check-arg integer? k drop-right!) - (let ((lead (drop lis k))) - (if (pair? lead) - - (let lp ((lag lis) (lead (cdr lead))) ; Standard case - (if (pair? lead) - (lp (cdr lag) (cdr lead)) - (begin (set-cdr! lag '()) - lis))) - - '()))) ; Special case dropping everything -- no cons to side-effect. - -;(define (list-ref lis i) (car (drop lis i))) ; R4RS - -;;; These use the APL convention, whereby negative indices mean -;;; "from the right." I liked them, but they didn't win over the -;;; SRFI reviewers. -;;; K >= 0: Take and drop K elts from the front of the list. -;;; K <= 0: Take and drop -K elts from the end of the list. - -;(define (take lis k) -; (check-arg integer? k take) -; (if (negative? k) -; (list-tail lis (+ k (length lis))) -; (let recur ((lis lis) (k k)) -; (if (zero? k) '() -; (cons (car lis) -; (recur (cdr lis) (- k 1))))))) -; -;(define (drop lis k) -; (check-arg integer? k drop) -; (if (negative? k) -; (let recur ((lis lis) (nelts (+ k (length lis)))) -; (if (zero? nelts) '() -; (cons (car lis) -; (recur (cdr lis) (- nelts 1))))) -; (list-tail lis k))) -; -; -;(define (take! lis k) -; (check-arg integer? k take!) -; (cond ((zero? k) '()) -; ((positive? k) -; (set-cdr! (list-tail lis (- k 1)) '()) -; lis) -; (else (list-tail lis (+ k (length lis)))))) -; -;(define (drop! lis k) -; (check-arg integer? k drop!) -; (if (negative? k) -; (let ((nelts (+ k (length lis)))) -; (if (zero? nelts) '() -; (begin (set-cdr! (list-tail lis (- nelts 1)) '()) -; lis))) -; (list-tail lis k))) - -(define (split-at x k) - (check-arg integer? k split-at) - (let recur ((lis x) (k k)) - (if (zero? k) (values '() lis) - (receive (prefix suffix) (recur (cdr lis) (- k 1)) - (values (cons (car lis) prefix) suffix))))) - -(define (split-at! x k) - (check-arg integer? k split-at!) - (if (zero? k) (values '() x) - (let* ((prev (drop x (- k 1))) - (suffix (cdr prev))) - (set-cdr! prev '()) - (values x suffix)))) - - -(define (last lis) (car (last-pair lis))) - -(define (last-pair lis) - (check-arg pair? lis last-pair) - (let lp ((lis lis)) - (let ((tail (cdr lis))) - (if (pair? tail) (lp tail) lis)))) - - -;;; Unzippers -- 1 through 5 -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (unzip1 lis) (map car lis)) - -(define (unzip2 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle - (let ((elt (car lis))) ; dotted lists. - (receive (a b) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b))))))) - -(define (unzip3 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis lis) - (let ((elt (car lis))) - (receive (a b c) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b) - (cons (caddr elt) c))))))) - -(define (unzip4 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis lis lis) - (let ((elt (car lis))) - (receive (a b c d) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b) - (cons (caddr elt) c) - (cons (cadddr elt) d))))))) - -(define (unzip5 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis lis lis lis) - (let ((elt (car lis))) - (receive (a b c d e) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b) - (cons (caddr elt) c) - (cons (cadddr elt) d) - (cons (car (cddddr elt)) e))))))) - - -;;; append! append-reverse append-reverse! concatenate concatenate! -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (append! . lists) - ;; First, scan through lists looking for a non-empty one. - (let lp ((lists lists) (prev '())) - (if (not (pair? lists)) prev - (let ((first (car lists)) - (rest (cdr lists))) - (if (not (pair? first)) (lp rest first) - - ;; Now, do the splicing. - (let lp2 ((tail-cons (last-pair first)) - (rest rest)) - (if (pair? rest) - (let ((next (car rest)) - (rest (cdr rest))) - (set-cdr! tail-cons next) - (lp2 (if (pair? next) (last-pair next) tail-cons) - rest)) - first))))))) - -;;; APPEND is R4RS. -;(define (append . lists) -; (if (pair? lists) -; (let recur ((list1 (car lists)) (lists (cdr lists))) -; (if (pair? lists) -; (let ((tail (recur (car lists) (cdr lists)))) -; (fold-right cons tail list1)) ; Append LIST1 & TAIL. -; list1)) -; '())) - -;(define (append-reverse rev-head tail) (fold cons tail rev-head)) - -;(define (append-reverse! rev-head tail) -; (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair) -; tail -; rev-head)) - -;;; Hand-inline the FOLD and PAIR-FOLD ops for speed. - -(define (append-reverse rev-head tail) - (let lp ((rev-head rev-head) (tail tail)) - (if (null-list? rev-head) tail - (lp (cdr rev-head) (cons (car rev-head) tail))))) - -(define (append-reverse! rev-head tail) - (let lp ((rev-head rev-head) (tail tail)) - (if (null-list? rev-head) tail - (let ((next-rev (cdr rev-head))) - (set-cdr! rev-head tail) - (lp next-rev rev-head))))) - - -(define (concatenate lists) (reduce-right append '() lists)) -(define (concatenate! lists) (reduce-right append! '() lists)) - -;;; Fold/map internal utilities -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; These little internal utilities are used by the general -;;; fold & mapper funs for the n-ary cases . It'd be nice if they got inlined. -;;; One the other hand, the n-ary cases are painfully inefficient as it is. -;;; An aggressive implementation should simply re-write these functions -;;; for raw efficiency; I have written them for as much clarity, portability, -;;; and simplicity as can be achieved. -;;; -;;; I use the dreaded call/cc to do local aborts. A good compiler could -;;; handle this with extreme efficiency. An implementation that provides -;;; a one-shot, non-persistent continuation grabber could help the compiler -;;; out by using that in place of the call/cc's in these routines. -;;; -;;; These functions have funky definitions that are precisely tuned to -;;; the needs of the fold/map procs -- for example, to minimize the number -;;; of times the argument lists need to be examined. - -;;; Return (map cdr lists). -;;; However, if any element of LISTS is empty, just abort and return '(). -(define (%cdrs lists) - (call-with-current-continuation - (lambda (abort) - (let recur ((lists lists)) - (if (pair? lists) - (let ((lis (car lists))) - (if (null-list? lis) (abort '()) - (cons (cdr lis) (recur (cdr lists))))) - '()))))) - -(define (%cars+ lists last-elt) ; (append! (map car lists) (list last-elt)) - (let recur ((lists lists)) - (if (pair? lists) (cons (caar lists) (recur (cdr lists))) (list last-elt)))) - -;;; LISTS is a (not very long) non-empty list of lists. -;;; Return two lists: the cars & the cdrs of the lists. -;;; However, if any of the lists is empty, just abort and return [() ()]. - -(define (%cars+cdrs lists) - (call-with-current-continuation - (lambda (abort) - (let recur ((lists lists)) - (if (pair? lists) - (receive (list other-lists) (car+cdr lists) - (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out - (receive (a d) (car+cdr list) - (receive (cars cdrs) (recur other-lists) - (values (cons a cars) (cons d cdrs)))))) - (values '() '())))))) - -;;; Like %CARS+CDRS, but we pass in a final elt tacked onto the end of the -;;; cars list. What a hack. -(define (%cars+cdrs+ lists cars-final) - (call-with-current-continuation - (lambda (abort) - (let recur ((lists lists)) - (if (pair? lists) - (receive (list other-lists) (car+cdr lists) - (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out - (receive (a d) (car+cdr list) - (receive (cars cdrs) (recur other-lists) - (values (cons a cars) (cons d cdrs)))))) - (values (list cars-final) '())))))) - -;;; Like %CARS+CDRS, but blow up if any list is empty. -(define (%cars+cdrs/no-test lists) - (let recur ((lists lists)) - (if (pair? lists) - (receive (list other-lists) (car+cdr lists) - (receive (a d) (car+cdr list) - (receive (cars cdrs) (recur other-lists) - (values (cons a cars) (cons d cdrs))))) - (values '() '())))) - - -;;; count -;;;;;;;;; -(define (count pred list1 . lists) - (check-arg procedure? pred count) - (if (pair? lists) - - ;; N-ary case - (let lp ((list1 list1) (lists lists) (i 0)) - (if (null-list? list1) i - (receive (as ds) (%cars+cdrs lists) - (if (null? as) i - (lp (cdr list1) ds - (if (apply pred (car list1) as) (+ i 1) i)))))) - - ;; Fast path - (let lp ((lis list1) (i 0)) - (if (null-list? lis) i - (lp (cdr lis) (if (pred (car lis)) (+ i 1) i)))))) - - -;;; fold/unfold -;;;;;;;;;;;;;;; - -(define/opt (unfold-right p f g seed (tail '())) - (check-arg procedure? p unfold-right) - (check-arg procedure? f unfold-right) - (check-arg procedure? g unfold-right) - (let lp ((seed seed) (ans tail)) - (if (p seed) ans - (lp (g seed) - (cons (f seed) ans))))) - - -(define/opt (unfold p f g seed (tail-gen #f)) - (check-arg procedure? p unfold) - (check-arg procedure? f unfold) - (check-arg procedure? g unfold) - (check-arg procedure? tail-gen unfold) - (let recur ((seed seed)) - (if (p seed) - (if tail-gen (tail-gen seed) '()) - (cons (f seed) (recur (g seed)))))) - - -(define (fold kons knil lis1 . lists) - (check-arg procedure? kons fold) - (if (pair? lists) - (let lp ((lists (cons lis1 lists)) (ans knil)) ; N-ary case - (receive (cars+ans cdrs) (%cars+cdrs+ lists ans) - (if (null? cars+ans) ans ; Done. - (lp cdrs (apply kons cars+ans))))) - - (let lp ((lis lis1) (ans knil)) ; Fast path - (if (null-list? lis) ans - (lp (cdr lis) (kons (car lis) ans)))))) - - -(define (fold-right kons knil lis1 . lists) - (check-arg procedure? kons fold-right) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) ; N-ary case - (let ((cdrs (%cdrs lists))) - (if (null? cdrs) knil - (apply kons (%cars+ lists (recur cdrs)))))) - - (let recur ((lis lis1)) ; Fast path - (if (null-list? lis) knil - (let ((head (car lis))) - (kons head (recur (cdr lis)))))))) - - -(define (pair-fold-right f zero lis1 . lists) - (check-arg procedure? f pair-fold-right) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) ; N-ary case - (let ((cdrs (%cdrs lists))) - (if (null? cdrs) zero - (apply f (append! lists (list (recur cdrs))))))) - - (let recur ((lis lis1)) ; Fast path - (if (null-list? lis) zero (f lis (recur (cdr lis))))))) - -(define (pair-fold f zero lis1 . lists) - (check-arg procedure? f pair-fold) - (if (pair? lists) - (let lp ((lists (cons lis1 lists)) (ans zero)) ; N-ary case - (let ((tails (%cdrs lists))) - (if (null? tails) ans - (lp tails (apply f (append! lists (list ans))))))) - - (let lp ((lis lis1) (ans zero)) - (if (null-list? lis) ans - (let ((tail (cdr lis))) ; Grab the cdr now, - (lp tail (f lis ans))))))) ; in case F SET-CDR!s LIS. - - -;;; REDUCE and REDUCE-RIGHT only use RIDENTITY in the empty-list case. -;;; These cannot meaningfully be n-ary. - -(define (reduce f ridentity lis) - (check-arg procedure? f reduce) - (if (null-list? lis) ridentity - (fold f (car lis) (cdr lis)))) - -(define (reduce-right f ridentity lis) - (check-arg procedure? f reduce-right) - (if (null-list? lis) ridentity - (let recur ((head (car lis)) (lis (cdr lis))) - (if (pair? lis) - (f head (recur (car lis) (cdr lis))) - head)))) - - - -;;; Mappers: append-map append-map! pair-for-each map! filter-map map-in-order -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (append-map f lis1 . lists) - (really-append-map append-map append f lis1 lists)) -(define (append-map! f lis1 . lists) - (really-append-map append-map! append! f lis1 lists)) - -(define (really-append-map who appender f lis1 lists) - (check-arg procedure? f who) - (if (pair? lists) - (receive (cars cdrs) (%cars+cdrs (cons lis1 lists)) - (if (null? cars) '() - (let recur ((cars cars) (cdrs cdrs)) - (let ((vals (apply f cars))) - (receive (cars2 cdrs2) (%cars+cdrs cdrs) - (if (null? cars2) vals - (appender vals (recur cars2 cdrs2)))))))) - - ;; Fast path - (if (null-list? lis1) '() - (let recur ((elt (car lis1)) (rest (cdr lis1))) - (let ((vals (f elt))) - (if (null-list? rest) vals - (appender vals (recur (car rest) (cdr rest))))))))) - - -(define (pair-for-each proc lis1 . lists) - (check-arg procedure? proc pair-for-each) - (if (pair? lists) - - (let lp ((lists (cons lis1 lists))) - (let ((tails (%cdrs lists))) - (if (pair? tails) - (begin (apply proc lists) - (lp tails))))) - - ;; Fast path. - (let lp ((lis lis1)) - (if (not (null-list? lis)) - (let ((tail (cdr lis))) ; Grab the cdr now, - (proc lis) ; in case PROC SET-CDR!s LIS. - (lp tail)))))) - -;;; We stop when LIS1 runs out, not when any list runs out. -(define (map! f lis1 . lists) - (check-arg procedure? f map!) - (if (pair? lists) - (let lp ((lis1 lis1) (lists lists)) - (if (not (null-list? lis1)) - (receive (heads tails) (%cars+cdrs/no-test lists) - (set-car! lis1 (apply f (car lis1) heads)) - (lp (cdr lis1) tails)))) - - ;; Fast path. - (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1)) - lis1) - - -;;; Map F across L, and save up all the non-false results. -(define (filter-map f lis1 . lists) - (check-arg procedure? f filter-map) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) - (receive (cars cdrs) (%cars+cdrs lists) - (if (pair? cars) - (cond ((apply f cars) => (lambda (x) (cons x (recur cdrs)))) - (else (recur cdrs))) ; Tail call in this arm. - '()))) - - ;; Fast path. - (let recur ((lis lis1)) - (if (null-list? lis) lis - (let ((tail (recur (cdr lis)))) - (cond ((f (car lis)) => (lambda (x) (cons x tail))) - (else tail))))))) - - -;;; Map F across lists, guaranteeing to go left-to-right. -;;; NOTE: Some implementations of R5RS MAP are compliant with this spec; -;;; in which case this procedure may simply be defined as a synonym for MAP. - -(define (map-in-order f lis1 . lists) - (check-arg procedure? f map-in-order) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) - (receive (cars cdrs) (%cars+cdrs lists) - (if (pair? cars) - (let ((x (apply f cars))) ; Do head first, - (cons x (recur cdrs))) ; then tail. - '()))) - - ;; Fast path. - (let recur ((lis lis1)) - (if (null-list? lis) lis - (let ((tail (cdr lis)) - (x (f (car lis)))) ; Do head first, - (cons x (recur tail))))))) ; then tail. - - -;;; We extend MAP to handle arguments of unequal length. -(define map map-in-order) - - -;;; filter, remove, partition -;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; FILTER, REMOVE, PARTITION and their destructive counterparts do not -;;; disorder the elements of their argument. - -;; This FILTER shares the longest tail of L that has no deleted elements. -;; If Scheme had multi-continuation calls, they could be made more efficient. - -(define (filter pred lis) ; Sleazing with EQ? makes this - (check-arg procedure? pred filter) ; one faster. - (let recur ((lis lis)) - (if (null-list? lis) lis ; Use NOT-PAIR? to handle dotted lists. - (let ((head (car lis)) - (tail (cdr lis))) - (if (pred head) - (let ((new-tail (recur tail))) ; Replicate the RECUR call so - (if (eq? tail new-tail) lis - (cons head new-tail))) - (recur tail)))))) ; this one can be a tail call. - - -;;; Another version that shares longest tail. -;(define (filter pred lis) -; (receive (ans no-del?) -; ;; (recur l) returns L with (pred x) values filtered. -; ;; It also returns a flag NO-DEL? if the returned value -; ;; is EQ? to L, i.e. if it didn't have to delete anything. -; (let recur ((l l)) -; (if (null-list? l) (values l #t) -; (let ((x (car l)) -; (tl (cdr l))) -; (if (pred x) -; (receive (ans no-del?) (recur tl) -; (if no-del? -; (values l #t) -; (values (cons x ans) #f))) -; (receive (ans no-del?) (recur tl) ; Delete X. -; (values ans #f)))))) -; ans)) - - - -;(define (filter! pred lis) ; Things are much simpler -; (let recur ((lis lis)) ; if you are willing to -; (if (pair? lis) ; push N stack frames & do N -; (cond ((pred (car lis)) ; SET-CDR! writes, where N is -; (set-cdr! lis (recur (cdr lis))); the length of the answer. -; lis) -; (else (recur (cdr lis)))) -; lis))) - - -;;; This implementation of FILTER! -;;; - doesn't cons, and uses no stack; -;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are -;;; usually expensive on modern machines, and can be extremely expensive on -;;; modern Schemes (e.g., ones that have generational GC's). -;;; It just zips down contiguous runs of in and out elts in LIS doing the -;;; minimal number of SET-CDR!s to splice the tail of one run of ins to the -;;; beginning of the next. - -(define (filter! pred lis) - (check-arg procedure? pred filter!) - (let lp ((ans lis)) - (cond ((null-list? ans) ans) ; Scan looking for - ((not (pred (car ans))) (lp (cdr ans))) ; first cons of result. - - ;; ANS is the eventual answer. - ;; SCAN-IN: (CDR PREV) = LIS and (CAR PREV) satisfies PRED. - ;; Scan over a contiguous segment of the list that - ;; satisfies PRED. - ;; SCAN-OUT: (CAR PREV) satisfies PRED. Scan over a contiguous - ;; segment of the list that *doesn't* satisfy PRED. - ;; When the segment ends, patch in a link from PREV - ;; to the start of the next good segment, and jump to - ;; SCAN-IN. - (else (letrec ((scan-in (lambda (prev lis) - (if (pair? lis) - (if (pred (car lis)) - (scan-in lis (cdr lis)) - (scan-out prev (cdr lis)))))) - (scan-out (lambda (prev lis) - (let lp ((lis lis)) - (if (pair? lis) - (if (pred (car lis)) - (begin (set-cdr! prev lis) - (scan-in lis (cdr lis))) - (lp (cdr lis))) - (set-cdr! prev lis)))))) - (scan-in ans (cdr ans)) - ans))))) - - - -;;; Answers share common tail with LIS where possible; -;;; the technique is slightly subtle. - -(define (partition pred lis) - (check-arg procedure? pred partition) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle dotted lists. - (let ((elt (car lis)) - (tail (cdr lis))) - (receive (in out) (recur tail) - (if (pred elt) - (values (if (pair? out) (cons elt in) lis) out) - (values in (if (pair? in) (cons elt out) lis)))))))) - - - -;(define (partition! pred lis) ; Things are much simpler -; (let recur ((lis lis)) ; if you are willing to -; (if (null-list? lis) (values lis lis) ; push N stack frames & do N -; (let ((elt (car lis))) ; SET-CDR! writes, where N is -; (receive (in out) (recur (cdr lis)) ; the length of LIS. -; (cond ((pred elt) -; (set-cdr! lis in) -; (values lis out)) -; (else (set-cdr! lis out) -; (values in lis)))))))) - - -;;; This implementation of PARTITION! -;;; - doesn't cons, and uses no stack; -;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are -;;; usually expensive on modern machines, and can be extremely expensive on -;;; modern Schemes (e.g., ones that have generational GC's). -;;; It just zips down contiguous runs of in and out elts in LIS doing the -;;; minimal number of SET-CDR!s to splice these runs together into the result -;;; lists. - -(define (partition! pred lis) - (check-arg procedure? pred partition!) - (if (null-list? lis) (values lis lis) - - ;; This pair of loops zips down contiguous in & out runs of the - ;; list, splicing the runs together. The invariants are - ;; SCAN-IN: (cdr in-prev) = LIS. - ;; SCAN-OUT: (cdr out-prev) = LIS. - (letrec ((scan-in (lambda (in-prev out-prev lis) - (let lp ((in-prev in-prev) (lis lis)) - (if (pair? lis) - (if (pred (car lis)) - (lp lis (cdr lis)) - (begin (set-cdr! out-prev lis) - (scan-out in-prev lis (cdr lis)))) - (set-cdr! out-prev lis))))) ; Done. - - (scan-out (lambda (in-prev out-prev lis) - (let lp ((out-prev out-prev) (lis lis)) - (if (pair? lis) - (if (pred (car lis)) - (begin (set-cdr! in-prev lis) - (scan-in lis out-prev (cdr lis))) - (lp lis (cdr lis))) - (set-cdr! in-prev lis)))))) ; Done. - - ;; Crank up the scan&splice loops. - (if (pred (car lis)) - ;; LIS begins in-list. Search for out-list's first pair. - (let lp ((prev-l lis) (l (cdr lis))) - (cond ((not (pair? l)) (values lis l)) - ((pred (car l)) (lp l (cdr l))) - (else (scan-out prev-l l (cdr l)) - (values lis l)))) ; Done. - - ;; LIS begins out-list. Search for in-list's first pair. - (let lp ((prev-l lis) (l (cdr lis))) - (cond ((not (pair? l)) (values l lis)) - ((pred (car l)) - (scan-in l prev-l (cdr l)) - (values l lis)) ; Done. - (else (lp l (cdr l))))))))) - - -;;; Inline us, please. -(define (remove pred l) (filter (lambda (x) (not (pred x))) l)) -(define (remove! pred l) (filter! (lambda (x) (not (pred x))) l)) - - - -;;; Here's the taxonomy for the DELETE/ASSOC/MEMBER functions. -;;; (I don't actually think these are the world's most important -;;; functions -- the procedural FILTER/REMOVE/FIND/FIND-TAIL variants -;;; are far more general.) -;;; -;;; Function Action -;;; --------------------------------------------------------------------------- -;;; remove pred lis Delete by general predicate -;;; delete x lis [=] Delete by element comparison -;;; -;;; find pred lis Search by general predicate -;;; find-tail pred lis Search by general predicate -;;; member x lis [=] Search by element comparison -;;; -;;; assoc key lis [=] Search alist by key comparison -;;; alist-delete key alist [=] Alist-delete by key comparison - -(define/opt (delete x lis (= equal?)) - (filter (lambda (y) (not (= x y))) lis)) - -(define/opt (delete! x lis (= equal?)) - (filter! (lambda (y) (not (= x y))) lis)) - -;;; Extended from R4RS to take an optional comparison argument. -(define/opt (member x lis (= equal?)) - (find-tail (lambda (y) (= x y)) lis)) - -;;; R4RS, hence we don't bother to define. -;;; The MEMBER and then FIND-TAIL call should definitely -;;; be inlined for MEMQ & MEMV. -;(define (memq x lis) (member x lis eq?)) -;(define (memv x lis) (member x lis eqv?)) - - -;;; right-duplicate deletion -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; delete-duplicates delete-duplicates! -;;; -;;; Beware -- these are N^2 algorithms. To efficiently remove duplicates -;;; in long lists, sort the list to bring duplicates together, then use a -;;; linear-time algorithm to kill the dups. Or use an algorithm based on -;;; element-marking. The former gives you O(n lg n), the latter is linear. - -(define/opt (delete-duplicates lis (elt= equal?)) - (check-arg procedure? elt= delete-duplicates) - (let recur ((lis lis)) - (if (null-list? lis) lis - (let* ((x (car lis)) - (tail (cdr lis)) - (new-tail (recur (delete x tail elt=)))) - (if (eq? tail new-tail) lis (cons x new-tail)))))) - -(define/opt (delete-duplicates! lis (elt= equal?)) - (check-arg procedure? elt= delete-duplicates!) - (let recur ((lis lis)) - (if (null-list? lis) lis - (let* ((x (car lis)) - (tail (cdr lis)) - (new-tail (recur (delete! x tail elt=)))) - (if (eq? tail new-tail) lis (cons x new-tail)))))) - - -;;; alist stuff -;;;;;;;;;;;;;;; - -;;; Extended from R4RS to take an optional comparison argument. -(define/opt (assoc x lis (= equal?)) - (find (lambda (entry) (= x (car entry))) lis)) - -(define (alist-cons key datum alist) (cons (cons key datum) alist)) - -(define (alist-copy alist) - (map (lambda (elt) (cons (car elt) (cdr elt))) - alist)) - -(define/opt (alist-delete key alist (= equal?)) - (filter (lambda (elt) (not (= key (car elt)))) alist)) - -(define/opt (alist-delete! key alist (= equal?)) - (filter! (lambda (elt) (not (= key (car elt)))) alist)) - - -;;; find find-tail take-while drop-while span break any every list-index -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (find pred list) - (cond ((find-tail pred list) => car) - (else #f))) - -(define (find-tail pred list) - (check-arg procedure? pred find-tail) - (let lp ((list list)) - (and (not (null-list? list)) - (if (pred (car list)) list - (lp (cdr list)))))) - -(define (take-while pred lis) - (check-arg procedure? pred take-while) - (let recur ((lis lis)) - (if (null-list? lis) '() - (let ((x (car lis))) - (if (pred x) - (cons x (recur (cdr lis))) - '()))))) - -(define (drop-while pred lis) - (check-arg procedure? pred drop-while) - (let lp ((lis lis)) - (if (null-list? lis) '() - (if (pred (car lis)) - (lp (cdr lis)) - lis)))) - -(define (take-while! pred lis) - (check-arg procedure? pred take-while!) - (if (or (null-list? lis) (not (pred (car lis)))) '() - (begin (let lp ((prev lis) (rest (cdr lis))) - (if (pair? rest) - (let ((x (car rest))) - (if (pred x) (lp rest (cdr rest)) - (set-cdr! prev '()))))) - lis))) - -(define (span pred lis) - (check-arg procedure? pred span) - (let recur ((lis lis)) - (if (null-list? lis) (values '() '()) - (let ((x (car lis))) - (if (pred x) - (receive (prefix suffix) (recur (cdr lis)) - (values (cons x prefix) suffix)) - (values '() lis)))))) - -(define (span! pred lis) - (check-arg procedure? pred span!) - (if (or (null-list? lis) (not (pred (car lis)))) (values '() lis) - (let ((suffix (let lp ((prev lis) (rest (cdr lis))) - (if (null-list? rest) rest - (let ((x (car rest))) - (if (pred x) (lp rest (cdr rest)) - (begin (set-cdr! prev '()) - rest))))))) - (values lis suffix)))) - - -(define (break pred lis) (span (lambda (x) (not (pred x))) lis)) -(define (break! pred lis) (span! (lambda (x) (not (pred x))) lis)) - -(define (any pred lis1 . lists) - (check-arg procedure? pred any) - (if (pair? lists) - - ;; N-ary case - (receive (heads tails) (%cars+cdrs (cons lis1 lists)) - (and (pair? heads) - (let lp ((heads heads) (tails tails)) - (receive (next-heads next-tails) (%cars+cdrs tails) - (if (pair? next-heads) - (or (apply pred heads) (lp next-heads next-tails)) - (apply pred heads)))))) ; Last PRED app is tail call. - - ;; Fast path - (and (not (null-list? lis1)) - (let lp ((head (car lis1)) (tail (cdr lis1))) - (if (null-list? tail) - (pred head) ; Last PRED app is tail call. - (or (pred head) (lp (car tail) (cdr tail)))))))) - - -;(define (every pred list) ; Simple definition. -; (let lp ((list list)) ; Doesn't return the last PRED value. -; (or (not (pair? list)) -; (and (pred (car list)) -; (lp (cdr list)))))) - -(define (every pred lis1 . lists) - (check-arg procedure? pred every) - (if (pair? lists) - - ;; N-ary case - (receive (heads tails) (%cars+cdrs (cons lis1 lists)) - (or (not (pair? heads)) - (let lp ((heads heads) (tails tails)) - (receive (next-heads next-tails) (%cars+cdrs tails) - (if (pair? next-heads) - (and (apply pred heads) (lp next-heads next-tails)) - (apply pred heads)))))) ; Last PRED app is tail call. - - ;; Fast path - (or (null-list? lis1) - (let lp ((head (car lis1)) (tail (cdr lis1))) - (if (null-list? tail) - (pred head) ; Last PRED app is tail call. - (and (pred head) (lp (car tail) (cdr tail)))))))) - -(define (list-index pred lis1 . lists) - (check-arg procedure? pred list-index) - (if (pair? lists) - - ;; N-ary case - (let lp ((lists (cons lis1 lists)) (n 0)) - (receive (heads tails) (%cars+cdrs lists) - (and (pair? heads) - (if (apply pred heads) n - (lp tails (+ n 1)))))) - - ;; Fast path - (let lp ((lis lis1) (n 0)) - (and (not (null-list? lis)) - (if (pred (car lis)) n (lp (cdr lis) (+ n 1))))))) - -;;; Reverse -;;;;;;;;;;; - -;R4RS, so not defined here. -;(define (reverse lis) (fold cons '() lis)) - -;(define (reverse! lis) -; (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair) '() lis)) - -(define (reverse! lis) - (let lp ((lis lis) (ans '())) - (if (null-list? lis) ans - (let ((tail (cdr lis))) - (set-cdr! lis ans) - (lp tail lis))))) - -;;; Lists-as-sets -;;;;;;;;;;;;;;;;; - -;;; This is carefully tuned code; do not modify casually. -;;; - It is careful to share storage when possible; -;;; - Side-effecting code tries not to perform redundant writes. -;;; - It tries to avoid linear-time scans in special cases where constant-time -;;; computations can be performed. -;;; - It relies on similar properties from the other list-lib procs it calls. -;;; For example, it uses the fact that the implementations of MEMBER and -;;; FILTER in this source code share longest common tails between args -;;; and results to get structure sharing in the lset procedures. - -(define (%lset2<= = lis1 lis2) (every (lambda (x) (member x lis2 =)) lis1)) - -(define (lset<= = . lists) - (check-arg procedure? = lset<=) - (or (not (pair? lists)) ; 0-ary case - (let lp ((s1 (car lists)) (rest (cdr lists))) - (or (not (pair? rest)) - (let ((s2 (car rest)) (rest (cdr rest))) - (and (or (eq? s2 s1) ; Fast path - (%lset2<= = s1 s2)) ; Real test - (lp s2 rest))))))) - -(define (lset= = . lists) - (check-arg procedure? = lset=) - (or (not (pair? lists)) ; 0-ary case - (let lp ((s1 (car lists)) (rest (cdr lists))) - (or (not (pair? rest)) - (let ((s2 (car rest)) - (rest (cdr rest))) - (and (or (eq? s1 s2) ; Fast path - (and (%lset2<= = s1 s2) (%lset2<= = s2 s1))) ; Real test - (lp s2 rest))))))) - - -(define (lset-adjoin = lis . elts) - (check-arg procedure? = lset-adjoin) - (fold (lambda (elt ans) (if (member elt ans =) ans (cons elt ans))) - lis elts)) - - -(define (lset-union = . lists) - (check-arg procedure? = lset-union) - (reduce (lambda (lis ans) ; Compute ANS + LIS. - (cond ((null? lis) ans) ; Don't copy any lists - ((null? ans) lis) ; if we don't have to. - ((eq? lis ans) ans) - (else - (fold (lambda (elt ans) (if (any (lambda (x) (= x elt)) ans) - ans - (cons elt ans))) - ans lis)))) - '() lists)) - -(define (lset-union! = . lists) - (check-arg procedure? = lset-union!) - (reduce (lambda (lis ans) ; Splice new elts of LIS onto the front of ANS. - (cond ((null? lis) ans) ; Don't copy any lists - ((null? ans) lis) ; if we don't have to. - ((eq? lis ans) ans) - (else - (pair-fold (lambda (pair ans) - (let ((elt (car pair))) - (if (any (lambda (x) (= x elt)) ans) - ans - (begin (set-cdr! pair ans) pair)))) - ans lis)))) - '() lists)) - - -(define (lset-intersection = lis1 . lists) - (check-arg procedure? = lset-intersection) - (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. - (cond ((any null-list? lists) '()) ; Short cut - ((null? lists) lis1) ; Short cut - (else (filter (lambda (x) - (every (lambda (lis) (member x lis =)) lists)) - lis1))))) - -(define (lset-intersection! = lis1 . lists) - (check-arg procedure? = lset-intersection!) - (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. - (cond ((any null-list? lists) '()) ; Short cut - ((null? lists) lis1) ; Short cut - (else (filter! (lambda (x) - (every (lambda (lis) (member x lis =)) lists)) - lis1))))) - - -(define (lset-difference = lis1 . lists) - (check-arg procedure? = lset-difference) - (let ((lists (filter pair? lists))) ; Throw out empty lists. - (cond ((null? lists) lis1) ; Short cut - ((memq lis1 lists) '()) ; Short cut - (else (filter (lambda (x) - (every (lambda (lis) (not (member x lis =))) - lists)) - lis1))))) - -(define (lset-difference! = lis1 . lists) - (check-arg procedure? = lset-difference!) - (let ((lists (filter pair? lists))) ; Throw out empty lists. - (cond ((null? lists) lis1) ; Short cut - ((memq lis1 lists) '()) ; Short cut - (else (filter! (lambda (x) - (every (lambda (lis) (not (member x lis =))) - lists)) - lis1))))) - - -(define (lset-xor = . lists) - (check-arg procedure? = lset-xor) - (reduce (lambda (b a) ; Compute A xor B: - ;; Note that this code relies on the constant-time - ;; short-cuts provided by LSET-DIFF+INTERSECTION, - ;; LSET-DIFFERENCE & APPEND to provide constant-time short - ;; cuts for the cases A = (), B = (), and A eq? B. It takes - ;; a careful case analysis to see it, but it's carefully - ;; built in. - - ;; Compute a-b and a^b, then compute b-(a^b) and - ;; cons it onto the front of a-b. - (receive (a-b a-int-b) (lset-diff+intersection = a b) - (cond ((null? a-b) (lset-difference = b a)) - ((null? a-int-b) (append b a)) - (else (fold (lambda (xb ans) - (if (member xb a-int-b =) ans (cons xb ans))) - a-b - b))))) - '() lists)) - - -(define (lset-xor! = . lists) - (check-arg procedure? = lset-xor!) - (reduce (lambda (b a) ; Compute A xor B: - ;; Note that this code relies on the constant-time - ;; short-cuts provided by LSET-DIFF+INTERSECTION, - ;; LSET-DIFFERENCE & APPEND to provide constant-time short - ;; cuts for the cases A = (), B = (), and A eq? B. It takes - ;; a careful case analysis to see it, but it's carefully - ;; built in. - - ;; Compute a-b and a^b, then compute b-(a^b) and - ;; cons it onto the front of a-b. - (receive (a-b a-int-b) (lset-diff+intersection! = a b) - (cond ((null? a-b) (lset-difference! = b a)) - ((null? a-int-b) (append! b a)) - (else (pair-fold (lambda (b-pair ans) - (if (member (car b-pair) a-int-b =) ans - (begin (set-cdr! b-pair ans) b-pair))) - a-b - b))))) - '() lists)) - - -(define (lset-diff+intersection = lis1 . lists) - (check-arg procedure? = lset-diff+intersection) - (cond ((every null-list? lists) (values lis1 '())) ; Short cut - ((memq lis1 lists) (values '() lis1)) ; Short cut - (else (partition (lambda (elt) - (not (any (lambda (lis) (member elt lis =)) - lists))) - lis1)))) - -(define (lset-diff+intersection! = lis1 . lists) - (check-arg procedure? = lset-diff+intersection!) - (cond ((every null-list? lists) (values lis1 '())) ; Short cut - ((memq lis1 lists) (values '() lis1)) ; Short cut - (else (partition! (lambda (elt) - (not (any (lambda (lis) (member elt lis =)) - lists))) - lis1)))) -(define-library (srfi 1) - (export - xcons list-tabulate cons* - proper-list? circular-list? dotted-list? not-pair? null-list? list= - circular-list length+ - iota - first second third fourth fifth sixth seventh eighth ninth tenth - car+cdr - take drop - take-right drop-right - take! drop-right! - split-at split-at! - last last-pair - zip unzip1 unzip2 unzip3 unzip4 unzip5 - count - append! append-reverse append-reverse! concatenate concatenate! - unfold fold pair-fold reduce - unfold-right fold-right pair-fold-right reduce-right - append-map append-map! map! pair-for-each filter-map map-in-order - filter partition remove - filter! partition! remove! - find find-tail any every list-index - take-while drop-while take-while! - span break span! break! - delete delete! - alist-cons alist-copy - delete-duplicates delete-duplicates! - alist-delete alist-delete! - reverse! - lset<= lset= lset-adjoin - lset-union lset-intersection lset-difference lset-xor lset-diff+intersection - lset-union! lset-intersection! lset-difference! lset-xor! lset-diff+intersection! - ) - (import - (except (scheme base) map member assoc) - (scheme case-lambda) - (scheme cxr) - (srfi 8) - (srfi aux)) - (begin - (define-check-arg check-arg)) - (include "1.body.scm")) -;;;;"array.scm" Arrays for Scheme -; Copyright (C) 2001, 2003 Aubrey Jaffer -; -;Permission to copy this software, to modify it, to redistribute it, -;to distribute modified versions, and to use it for any purpose is -;granted, subject to the following restrictions and understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warranty or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -;;@code{(require 'array)} or @code{(require 'srfi-63)} -;;@ftindex array - -(define-record-type - (array:construct dimensions scales offset store) - array:array? - (dimensions dimensions) - (scales scales) - (offset offset) - (store store)) - -(define (array:dimensions array) - (cond ((vector? array) (list (vector-length array))) - ((string? array) (list (string-length array))) - (else (dimensions array)))) - -(define (array:scales array) - (cond ((vector? array) '(1)) - ((string? array) '(1)) - (else (scales array)))) - -(define (array:store array) - (cond ((vector? array) array) - ((string? array) array) - (else (store array)))) - -(define (array:offset array) - (cond ((vector? array) 0) - ((string? array) 0) - (else (offset array)))) - -;;@args obj -;;Returns @code{#t} if the @1 is an array, and @code{#f} if not. -(define (array? obj) - (or (vector? obj) (string? obj) (array:array? obj))) - -;;@noindent -;;@emph{Note:} Arrays are not disjoint from other Scheme types. -;;Vectors and possibly strings also satisfy @code{array?}. -;;A disjoint array predicate can be written: -;; -;;@example -;;(define (strict-array? obj) -;; (and (array? obj) (not (string? obj)) (not (vector? obj)))) -;;@end example - -;;@body -;;Returns @code{#t} if @1 and @2 have the same rank and dimensions and the -;;corresponding elements of @1 and @2 are @code{equal?}. - -;;@body -;;@0 recursively compares the contents of pairs, vectors, strings, and -;;@emph{arrays}, applying @code{eqv?} on other objects such as numbers -;;and symbols. A rule of thumb is that objects are generally @0 if -;;they print the same. @0 may fail to terminate if its arguments are -;;circular data structures. -;; -;;@example -;;(equal? 'a 'a) @result{} #t -;;(equal? '(a) '(a)) @result{} #t -;;(equal? '(a (b) c) -;; '(a (b) c)) @result{} #t -;;(equal? "abc" "abc") @result{} #t -;;(equal? 2 2) @result{} #t -;;(equal? (make-vector 5 'a) -;; (make-vector 5 'a)) @result{} #t -;;(equal? (make-array (a:fixN32b 4) 5 3) -;; (make-array (a:fixN32b 4) 5 3)) @result{} #t -;;(equal? (make-array '#(foo) 3 3) -;; (make-array '#(foo) 3 3)) @result{} #t -;;(equal? (lambda (x) x) -;; (lambda (y) y)) @result{} @emph{unspecified} -;;@end example -(define (equal? obj1 obj2) - (cond ((eqv? obj1 obj2) #t) - ((or (pair? obj1) (pair? obj2)) - (and (pair? obj1) (pair? obj2) - (equal? (car obj1) (car obj2)) - (equal? (cdr obj1) (cdr obj2)))) - ((or (string? obj1) (string? obj2)) - (and (string? obj1) (string? obj2) - (string=? obj1 obj2))) - ((or (vector? obj1) (vector? obj2)) - (and (vector? obj1) (vector? obj2) - (equal? (vector-length obj1) (vector-length obj2)) - (do ((idx (+ -1 (vector-length obj1)) (+ -1 idx))) - ((or (negative? idx) - (not (equal? (vector-ref obj1 idx) - (vector-ref obj2 idx)))) - (negative? idx))))) - ((or (array? obj1) (array? obj2)) - (and (array? obj1) (array? obj2) - (equal? (array:dimensions obj1) (array:dimensions obj2)) - (equal? (array:store obj1) (array:store obj2)))) - (else #f))) - -;;@body -;;Returns the number of dimensions of @1. If @1 is not an array, 0 is -;;returned. -(define (array-rank obj) - (if (array? obj) (length (array:dimensions obj)) 0)) - -;;@args array -;;Returns a list of dimensions. -;; -;;@example -;;(array-dimensions (make-array '#() 3 5)) -;; @result{} (3 5) -;;@end example -(define array-dimensions array:dimensions) - -;;@args prototype k1 @dots{} -;; -;;Creates and returns an array of type @1 with dimensions @2, @dots{} -;;and filled with elements from @1. @1 must be an array, vector, or -;;string. The implementation-dependent type of the returned array -;;will be the same as the type of @1; except if that would be a vector -;;or string with rank not equal to one, in which case some variety of -;;array will be returned. -;; -;;If the @1 has no elements, then the initial contents of the returned -;;array are unspecified. Otherwise, the returned array will be filled -;;with the element at the origin of @1. -(define (make-array prototype . dimensions) - (define tcnt (apply * dimensions)) - (let ((store - (if (string? prototype) - (case (string-length prototype) - ((0) (make-string tcnt)) - (else (make-string tcnt - (string-ref prototype 0)))) - (let ((pdims (array:dimensions prototype))) - (case (apply * pdims) - ((0) (make-vector tcnt)) - (else (make-vector tcnt - (apply array-ref prototype - (map (lambda (x) 0) pdims))))))))) - (define (loop dims scales) - (if (null? dims) - (array:construct dimensions (cdr scales) 0 store) - (loop (cdr dims) (cons (* (car dims) (car scales)) scales)))) - (loop (reverse dimensions) '(1)))) -;;@args prototype k1 @dots{} -;;@0 is an alias for @code{make-array}. -(define create-array make-array) - -;;@args array mapper k1 @dots{} -;;@0 can be used to create shared subarrays of other -;;arrays. The @var{mapper} is a function that translates coordinates in -;;the new array into coordinates in the old array. A @var{mapper} must be -;;linear, and its range must stay within the bounds of the old array, but -;;it can be otherwise arbitrary. A simple example: -;; -;;@example -;;(define fred (make-array '#(#f) 8 8)) -;;(define freds-diagonal -;; (make-shared-array fred (lambda (i) (list i i)) 8)) -;;(array-set! freds-diagonal 'foo 3) -;;(array-ref fred 3 3) -;; @result{} FOO -;;(define freds-center -;; (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) -;; 2 2)) -;;(array-ref freds-center 0 0) -;; @result{} FOO -;;@end example -(define (make-shared-array array mapper . dimensions) - (define odl (array:scales array)) - (define rank (length dimensions)) - (define shape - (map (lambda (dim) (if (list? dim) dim (list 0 (+ -1 dim)))) dimensions)) - (do ((idx (+ -1 rank) (+ -1 idx)) - (uvt (append (cdr (vector->list (make-vector rank 0))) '(1)) - (append (cdr uvt) '(0))) - (uvts '() (cons uvt uvts))) - ((negative? idx) - (let ((ker0 (apply + (map * odl (apply mapper uvt))))) - (array:construct - (map (lambda (dim) (+ 1 (- (cadr dim) (car dim)))) shape) - (map (lambda (uvt) (- (apply + (map * odl (apply mapper uvt))) ker0)) - uvts) - (apply + - (array:offset array) - (map * odl (apply mapper (map car shape)))) - (array:store array)))))) - -;;@args rank proto list -;;@3 must be a rank-nested list consisting of all the elements, in -;;row-major order, of the array to be created. -;; -;;@0 returns an array of rank @1 and type @2 consisting of all the -;;elements, in row-major order, of @3. When @1 is 0, @3 is the lone -;;array element; not necessarily a list. -;; -;;@example -;;(list->array 2 '#() '((1 2) (3 4))) -;; @result{} #2A((1 2) (3 4)) -;;(list->array 0 '#() 3) -;; @result{} #0A 3 -;;@end example -(define (list->array rank proto lst) - (define dimensions - (do ((shp '() (cons (length row) shp)) - (row lst (car lst)) - (rnk (+ -1 rank) (+ -1 rnk))) - ((negative? rnk) (reverse shp)))) - (let ((nra (apply make-array proto dimensions))) - (define (l2ra dims idxs row) - (cond ((null? dims) - (apply array-set! nra row (reverse idxs))) - (else - (if (not (eqv? (car dims) (length row))) - (error "Array not rectangular:" dims dimensions)) - (do ((idx 0 (+ 1 idx)) - (row row (cdr row))) - ((>= idx (car dims))) - (l2ra (cdr dims) (cons idx idxs) (car row)))))) - (l2ra dimensions '() lst) - nra)) - -;;@args array -;;Returns a rank-nested list consisting of all the elements, in -;;row-major order, of @1. In the case of a rank-0 array, @0 returns -;;the single element. -;; -;;@example -;;(array->list #2A((ho ho ho) (ho oh oh))) -;; @result{} ((ho ho ho) (ho oh oh)) -;;(array->list #0A ho) -;; @result{} ho -;;@end example -(define (array->list ra) - (define (ra2l dims idxs) - (if (null? dims) - (apply array-ref ra (reverse idxs)) - (do ((lst '() (cons (ra2l (cdr dims) (cons idx idxs)) lst)) - (idx (+ -1 (car dims)) (+ -1 idx))) - ((negative? idx) lst)))) - (ra2l (array-dimensions ra) '())) - -;;@args vect proto dim1 @dots{} -;;@1 must be a vector of length equal to the product of exact -;;nonnegative integers @3, @dots{}. -;; -;;@0 returns an array of type @2 consisting of all the elements, in -;;row-major order, of @1. In the case of a rank-0 array, @1 has a -;;single element. -;; -;;@example -;;(vector->array #(1 2 3 4) #() 2 2) -;; @result{} #2A((1 2) (3 4)) -;;(vector->array '#(3) '#()) -;; @result{} #0A 3 -;;@end example -(define (vector->array vect prototype . dimensions) - (define vdx (vector-length vect)) - (if (not (eqv? vdx (apply * dimensions))) - (error "Vector length does not equal product of dimensions:" - vdx dimensions)) - (let ((ra (apply make-array prototype dimensions))) - (define (v2ra dims idxs) - (cond ((null? dims) - (set! vdx (+ -1 vdx)) - (apply array-set! ra (vector-ref vect vdx) (reverse idxs))) - (else - (do ((idx (+ -1 (car dims)) (+ -1 idx))) - ((negative? idx) vect) - (v2ra (cdr dims) (cons idx idxs)))))) - (v2ra dimensions '()) - ra)) - -;;@args array -;;Returns a new vector consisting of all the elements of @1 in -;;row-major order. -;; -;;@example -;;(array->vector #2A ((1 2)( 3 4))) -;; @result{} #(1 2 3 4) -;;(array->vector #0A ho) -;; @result{} #(ho) -;;@end example -(define (array->vector ra) - (define dims (array-dimensions ra)) - (let* ((vdx (apply * dims)) - (vect (make-vector vdx))) - (define (ra2v dims idxs) - (if (null? dims) - (let ((val (apply array-ref ra (reverse idxs)))) - (set! vdx (+ -1 vdx)) - (vector-set! vect vdx val) - vect) - (do ((idx (+ -1 (car dims)) (+ -1 idx))) - ((negative? idx) vect) - (ra2v (cdr dims) (cons idx idxs))))) - (ra2v dims '()))) - -(define (array:in-bounds? array indices) - (do ((bnds (array:dimensions array) (cdr bnds)) - (idxs indices (cdr idxs))) - ((or (null? bnds) - (null? idxs) - (not (integer? (car idxs))) - (not (< -1 (car idxs) (car bnds)))) - (and (null? bnds) (null? idxs))))) - -;;@args array index1 @dots{} -;;Returns @code{#t} if its arguments would be acceptable to -;;@code{array-ref}. -(define (array-in-bounds? array . indices) - (array:in-bounds? array indices)) - -;;@args array k1 @dots{} -;;Returns the (@2, @dots{}) element of @1. -(define (array-ref array . indices) - (define store (array:store array)) - (or (array:in-bounds? array indices) - (error "Bad indices:" indices)) - ((if (string? store) string-ref vector-ref) - store (apply + (array:offset array) (map * (array:scales array) indices)))) - -;;@args array obj k1 @dots{} -;;Stores @2 in the (@3, @dots{}) element of @1. The value returned -;;by @0 is unspecified. -(define (array-set! array obj . indices) - (define store (array:store array)) - (or (array:in-bounds? array indices) - (error "Bad indices:" indices)) - ((if (string? store) string-set! vector-set!) - store (apply + (array:offset array) (map * (array:scales array) indices)) - obj)) - -;;@noindent -;;These functions return a prototypical uniform-array enclosing the -;;optional argument (which must be of the correct type). If the -;;uniform-array type is supported by the implementation, then it is -;;returned; defaulting to the next larger precision type; resorting -;;finally to vector. - -(define (make-prototype-checker name pred? creator) - (lambda args - (case (length args) - ((1) (if (pred? (car args)) - (creator (car args)) - (error "Incompatible type:" name (car args)))) - ((0) (creator)) - (else (error "Wrong number of arguments:" name args))))) - -(define (integer-bytes?? n) - (lambda (obj) - (and (integer? obj) - (exact? obj) - (or (negative? n) (not (negative? obj))) - (do ((num obj (quotient num 256)) - (n (+ -1 (abs n)) (+ -1 n))) - ((or (zero? num) (negative? n)) - (zero? num)))))) - -;;@args z -;;@args -;;Returns an inexact 128.bit flonum complex uniform-array prototype. -(define a:floc128b (make-prototype-checker 'a:floc128b complex? vector)) -;;@args z -;;@args -;;Returns an inexact 64.bit flonum complex uniform-array prototype. -(define a:floc64b (make-prototype-checker 'a:floc64b complex? vector)) -;;@args z -;;@args -;;Returns an inexact 32.bit flonum complex uniform-array prototype. -(define a:floc32b (make-prototype-checker 'a:floc32b complex? vector)) -;;@args z -;;@args -;;Returns an inexact 16.bit flonum complex uniform-array prototype. -(define a:floc16b (make-prototype-checker 'a:floc16b complex? vector)) - -;;@args z -;;@args -;;Returns an inexact 128.bit flonum real uniform-array prototype. -(define a:flor128b (make-prototype-checker 'a:flor128b real? vector)) -;;@args z -;;@args -;;Returns an inexact 64.bit flonum real uniform-array prototype. -(define a:flor64b (make-prototype-checker 'a:flor64b real? vector)) -;;@args z -;;@args -;;Returns an inexact 32.bit flonum real uniform-array prototype. -(define a:flor32b (make-prototype-checker 'a:flor32b real? vector)) -;;@args z -;;@args -;;Returns an inexact 16.bit flonum real uniform-array prototype. -(define a:flor16b (make-prototype-checker 'a:flor16b real? vector)) - -;;@args z -;;@args -;;Returns an exact 128.bit decimal flonum rational uniform-array prototype. -(define a:flor128b (make-prototype-checker 'a:flor128b real? vector)) -;;@args z -;;@args -;;Returns an exact 64.bit decimal flonum rational uniform-array prototype. -(define a:flor64b (make-prototype-checker 'a:flor64b real? vector)) -;;@args z -;;@args -;;Returns an exact 32.bit decimal flonum rational uniform-array prototype. -(define a:flor32b (make-prototype-checker 'a:flor32b real? vector)) - -;;@args n -;;@args -;;Returns an exact binary fixnum uniform-array prototype with at least -;;64 bits of precision. -(define a:fixz64b (make-prototype-checker 'a:fixz64b (integer-bytes?? -8) vector)) -;;@args n -;;@args -;;Returns an exact binary fixnum uniform-array prototype with at least -;;32 bits of precision. -(define a:fixz32b (make-prototype-checker 'a:fixz32b (integer-bytes?? -4) vector)) -;;@args n -;;@args -;;Returns an exact binary fixnum uniform-array prototype with at least -;;16 bits of precision. -(define a:fixz16b (make-prototype-checker 'a:fixz16b (integer-bytes?? -2) vector)) -;;@args n -;;@args -;;Returns an exact binary fixnum uniform-array prototype with at least -;;8 bits of precision. -(define a:fixz8b (make-prototype-checker 'a:fixz8b (integer-bytes?? -1) vector)) - -;;@args k -;;@args -;;Returns an exact non-negative binary fixnum uniform-array prototype with at -;;least 64 bits of precision. -(define a:fixn64b (make-prototype-checker 'a:fixn64b (integer-bytes?? 8) vector)) -;;@args k -;;@args -;;Returns an exact non-negative binary fixnum uniform-array prototype with at -;;least 32 bits of precision. -(define a:fixn32b (make-prototype-checker 'a:fixn32b (integer-bytes?? 4) vector)) -;;@args k -;;@args -;;Returns an exact non-negative binary fixnum uniform-array prototype with at -;;least 16 bits of precision. -(define a:fixn16b (make-prototype-checker 'a:fixn16b (integer-bytes?? 2) vector)) -;;@args k -;;@args -;;Returns an exact non-negative binary fixnum uniform-array prototype with at -;;least 8 bits of precision. -(define a:fixn8b (make-prototype-checker 'a:fixn8b (integer-bytes?? 1) vector)) - -;;@args bool -;;@args -;;Returns a boolean uniform-array prototype. -(define a:bool (make-prototype-checker 'a:bool boolean? vector)) -;;; SRFI-1 list-processing library -*- Scheme -*- -;;; Reference implementation -;;; -;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with -;;; this code as long as you do not remove this copyright notice or -;;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu. -;;; -Olin - -;;; This is a library of list- and pair-processing functions. I wrote it after -;;; carefully considering the functions provided by the libraries found in -;;; R4RS/R5RS Scheme, MIT Scheme, Gambit, RScheme, MzScheme, slib, Common -;;; Lisp, Bigloo, guile, T, APL and the SML standard basis. It is a pretty -;;; rich toolkit, providing a superset of the functionality found in any of -;;; the various Schemes I considered. - -;;; This implementation is intended as a portable reference implementation -;;; for SRFI-1. See the porting notes below for more information. - -;;; Exported: -;;; xcons tree-copy make-list list-tabulate cons* list-copy -;;; proper-list? circular-list? dotted-list? not-pair? null-list? list= -;;; circular-list length+ -;;; iota -;;; first second third fourth fifth sixth seventh eighth ninth tenth -;;; car+cdr -;;; take drop -;;; take-right drop-right -;;; take! drop-right! -;;; split-at split-at! -;;; last last-pair -;;; zip unzip1 unzip2 unzip3 unzip4 unzip5 -;;; count -;;; append! append-reverse append-reverse! concatenate concatenate! -;;; unfold fold pair-fold reduce -;;; unfold-right fold-right pair-fold-right reduce-right -;;; append-map append-map! map! pair-for-each filter-map map-in-order -;;; filter partition remove -;;; filter! partition! remove! -;;; find find-tail any every list-index -;;; take-while drop-while take-while! -;;; span break span! break! -;;; delete delete! -;;; alist-cons alist-copy -;;; delete-duplicates delete-duplicates! -;;; alist-delete alist-delete! -;;; reverse! -;;; lset<= lset= lset-adjoin -;;; lset-union lset-intersection lset-difference lset-xor lset-diff+intersection -;;; lset-union! lset-intersection! lset-difference! lset-xor! lset-diff+intersection! -;;; -;;; In principle, the following R4RS list- and pair-processing procedures -;;; are also part of this package's exports, although they are not defined -;;; in this file: -;;; Primitives: cons pair? null? car cdr set-car! set-cdr! -;;; Non-primitives: list length append reverse cadr ... cddddr list-ref -;;; memq memv assq assv -;;; (The non-primitives are defined in this file, but commented out.) -;;; -;;; These R4RS procedures have extended definitions in SRFI-1 and are defined -;;; in this file: -;;; map for-each member assoc -;;; -;;; The remaining two R4RS list-processing procedures are not included: -;;; list-tail (use drop) -;;; list? (use proper-list?) - - -;;; A note on recursion and iteration/reversal: -;;; Many iterative list-processing algorithms naturally compute the elements -;;; of the answer list in the wrong order (left-to-right or head-to-tail) from -;;; the order needed to cons them into the proper answer (right-to-left, or -;;; tail-then-head). One style or idiom of programming these algorithms, then, -;;; loops, consing up the elements in reverse order, then destructively -;;; reverses the list at the end of the loop. I do not do this. The natural -;;; and efficient way to code these algorithms is recursively. This trades off -;;; intermediate temporary list structure for intermediate temporary stack -;;; structure. In a stack-based system, this improves cache locality and -;;; lightens the load on the GC system. Don't stand on your head to iterate! -;;; Recurse, where natural. Multiple-value returns make this even more -;;; convenient, when the recursion/iteration has multiple state values. - -;;; Porting: -;;; This is carefully tuned code; do not modify casually. -;;; - It is careful to share storage when possible; -;;; - Side-effecting code tries not to perform redundant writes. -;;; -;;; That said, a port of this library to a specific Scheme system might wish -;;; to tune this code to exploit particulars of the implementation. -;;; The single most important compiler-specific optimisation you could make -;;; to this library would be to add rewrite rules or transforms to: -;;; - transform applications of n-ary procedures (e.g. LIST=, CONS*, APPEND, -;;; LSET-UNION) into multiple applications of a primitive two-argument -;;; variant. -;;; - transform applications of the mapping functions (MAP, FOR-EACH, FOLD, -;;; ANY, EVERY) into open-coded loops. The killer here is that these -;;; functions are n-ary. Handling the general case is quite inefficient, -;;; requiring many intermediate data structures to be allocated and -;;; discarded. -;;; - transform applications of procedures that take optional arguments -;;; into calls to variants that do not take optional arguments. This -;;; eliminates unnecessary consing and parsing of the rest parameter. -;;; -;;; These transforms would provide BIG speedups. In particular, the n-ary -;;; mapping functions are particularly slow and cons-intensive, and are good -;;; candidates for tuning. I have coded fast paths for the single-list cases, -;;; but what you really want to do is exploit the fact that the compiler -;;; usually knows how many arguments are being passed to a particular -;;; application of these functions -- they are usually explicitly called, not -;;; passed around as higher-order values. If you can arrange to have your -;;; compiler produce custom code or custom linkages based on the number of -;;; arguments in the call, you can speed these functions up a *lot*. But this -;;; kind of compiler technology no longer exists in the Scheme world as far as -;;; I can see. -;;; -;;; Note that this code is, of course, dependent upon standard bindings for -;;; the R5RS procedures -- i.e., it assumes that the variable CAR is bound -;;; to the procedure that takes the car of a list. If your Scheme -;;; implementation allows user code to alter the bindings of these procedures -;;; in a manner that would be visible to these definitions, then there might -;;; be trouble. You could consider horrible kludgery along the lines of -;;; (define fact -;;; (let ((= =) (- -) (* *)) -;;; (letrec ((real-fact (lambda (n) -;;; (if (= n 0) 1 (* n (real-fact (- n 1))))))) -;;; real-fact))) -;;; Or you could consider shifting to a reasonable Scheme system that, say, -;;; has a module system protecting code from this kind of lossage. -;;; -;;; This code does a fair amount of run-time argument checking. If your -;;; Scheme system has a sophisticated compiler that can eliminate redundant -;;; error checks, this is no problem. However, if not, these checks incur -;;; some performance overhead -- and, in a safe Scheme implementation, they -;;; are in some sense redundant: if we don't check to see that the PROC -;;; parameter is a procedure, we'll find out anyway three lines later when -;;; we try to call the value. It's pretty easy to rip all this argument -;;; checking code out if it's inappropriate for your implementation -- just -;;; nuke every call to CHECK-ARG. -;;; -;;; On the other hand, if you *do* have a sophisticated compiler that will -;;; actually perform soft-typing and eliminate redundant checks (Rice's systems -;;; being the only possible candidate of which I'm aware), leaving these checks -;;; in can *help*, since their presence can be elided in redundant cases, -;;; and in cases where they are needed, performing the checks early, at -;;; procedure entry, can "lift" a check out of a loop. -;;; -;;; Finally, I have only checked the properties that can portably be checked -;;; with R5RS Scheme -- and this is not complete. You may wish to alter -;;; the CHECK-ARG parameter checks to perform extra, implementation-specific -;;; checks, such as procedure arity for higher-order values. -;;; -;;; The code has only these non-R4RS dependencies: -;;; A few calls to an ERROR procedure; -;;; Uses of the R5RS multiple-value procedure VALUES and the m-v binding -;;; RECEIVE macro (which isn't R5RS, but is a trivial macro). -;;; Many calls to a parameter-checking procedure check-arg: -;;; (define (check-arg pred val caller) -;;; (let lp ((val val)) -;;; (if (pred val) val (lp (error "Bad argument" val pred caller))))) -;;; A few uses of the LET-OPTIONAL and :OPTIONAL macros for parsing -;;; optional arguments. -;;; -;;; Most of these procedures use the NULL-LIST? test to trigger the -;;; base case in the inner loop or recursion. The NULL-LIST? function -;;; is defined to be a careful one -- it raises an error if passed a -;;; non-nil, non-pair value. The spec allows an implementation to use -;;; a less-careful implementation that simply defines NULL-LIST? to -;;; be NOT-PAIR?. This would speed up the inner loops of these procedures -;;; at the expense of having them silently accept dotted lists. - -;;; A note on dotted lists: -;;; I, personally, take the view that the only consistent view of lists -;;; in Scheme is the view that *everything* is a list -- values such as -;;; 3 or "foo" or 'bar are simply empty dotted lists. This is due to the -;;; fact that Scheme actually has no true list type. It has a pair type, -;;; and there is an *interpretation* of the trees built using this type -;;; as lists. -;;; -;;; I lobbied to have these list-processing procedures hew to this -;;; view, and accept any value as a list argument. I was overwhelmingly -;;; overruled during the SRFI discussion phase. So I am inserting this -;;; text in the reference lib and the SRFI spec as a sort of "minority -;;; opinion" dissent. -;;; -;;; Many of the procedures in this library can be trivially redefined -;;; to handle dotted lists, just by changing the NULL-LIST? base-case -;;; check to NOT-PAIR?, meaning that any non-pair value is taken to be -;;; an empty list. For most of these procedures, that's all that is -;;; required. -;;; -;;; However, we have to do a little more work for some procedures that -;;; *produce* lists from other lists. Were we to extend these procedures to -;;; accept dotted lists, we would have to define how they terminate the lists -;;; produced as results when passed a dotted list. I designed a coherent set -;;; of termination rules for these cases; this was posted to the SRFI-1 -;;; discussion list. I additionally wrote an earlier version of this library -;;; that implemented that spec. It has been discarded during later phases of -;;; the definition and implementation of this library. -;;; -;;; The argument *against* defining these procedures to work on dotted -;;; lists is that dotted lists are the rare, odd case, and that by -;;; arranging for the procedures to handle them, we lose error checking -;;; in the cases where a dotted list is passed by accident -- e.g., when -;;; the programmer swaps a two arguments to a list-processing function, -;;; one being a scalar and one being a list. For example, -;;; (member '(1 3 5 7 9) 7) -;;; This would quietly return #f if we extended MEMBER to accept dotted -;;; lists. -;;; -;;; The SRFI discussion record contains more discussion on this topic. - - -;;; Constructors -;;;;;;;;;;;;;;;; - -;;; Occasionally useful as a value to be passed to a fold or other -;;; higher-order procedure. -(define (xcons d a) (cons a d)) - -;;;; Recursively copy every cons. -;(define (tree-copy x) -; (let recur ((x x)) -; (if (not (pair? x)) x -; (cons (recur (car x)) (recur (cdr x)))))) - -;;; Make a list of length LEN. - -(define (make-list len . maybe-elt) - (check-arg (lambda (n) (and (integer? n) (>= n 0))) len make-list) - (let ((elt (cond ((null? maybe-elt) #f) ; Default value - ((null? (cdr maybe-elt)) (car maybe-elt)) - (else (error "Too many arguments to MAKE-LIST" - (cons len maybe-elt)))))) - (do ((i len (- i 1)) - (ans '() (cons elt ans))) - ((<= i 0) ans)))) - - -;(define (list . ans) ans) ; R4RS - - -;;; Make a list of length LEN. Elt i is (PROC i) for 0 <= i < LEN. - -(define (list-tabulate len proc) - (check-arg (lambda (n) (and (integer? n) (>= n 0))) len list-tabulate) - (check-arg procedure? proc list-tabulate) - (do ((i (- len 1) (- i 1)) - (ans '() (cons (proc i) ans))) - ((< i 0) ans))) - -;;; (cons* a1 a2 ... an) = (cons a1 (cons a2 (cons ... an))) -;;; (cons* a1) = a1 (cons* a1 a2 ...) = (cons a1 (cons* a2 ...)) -;;; -;;; (cons first (unfold not-pair? car cdr rest values)) - -(define (cons* first . rest) - (let recur ((x first) (rest rest)) - (if (pair? rest) - (cons x (recur (car rest) (cdr rest))) - x))) - -;;; (unfold not-pair? car cdr lis values) - -(define (list-copy lis) - (let recur ((lis lis)) - (if (pair? lis) - (cons (car lis) (recur (cdr lis))) - lis))) - -;;; IOTA count [start step] (start start+step ... start+(count-1)*step) - -(define (iota count . maybe-start+step) - (check-arg integer? count iota) - (if (< count 0) (error "Negative step count" iota count)) - (let-optionals maybe-start+step ((start 0) (step 1)) - (check-arg number? start iota) - (check-arg number? step iota) - (let loop ((n 0) (r '())) - (if (= n count) - (reverse r) - (loop (+ 1 n) - (cons (+ start (* n step)) r)))))) - -;;; I thought these were lovely, but the public at large did not share my -;;; enthusiasm... -;;; :IOTA to (0 ... to-1) -;;; :IOTA from to (from ... to-1) -;;; :IOTA from to step (from from+step ...) - -;;; IOTA: to (1 ... to) -;;; IOTA: from to (from+1 ... to) -;;; IOTA: from to step (from+step from+2step ...) - -;(define (%parse-iota-args arg1 rest-args proc) -; (let ((check (lambda (n) (check-arg integer? n proc)))) -; (check arg1) -; (if (pair? rest-args) -; (let ((arg2 (check (car rest-args))) -; (rest (cdr rest-args))) -; (if (pair? rest) -; (let ((arg3 (check (car rest))) -; (rest (cdr rest))) -; (if (pair? rest) (error "Too many parameters" proc arg1 rest-args) -; (values arg1 arg2 arg3))) -; (values arg1 arg2 1))) -; (values 0 arg1 1)))) -; -;(define (iota: arg1 . rest-args) -; (receive (from to step) (%parse-iota-args arg1 rest-args iota:) -; (let* ((numsteps (floor (/ (- to from) step))) -; (last-val (+ from (* step numsteps)))) -; (if (< numsteps 0) (error "Negative step count" iota: from to step)) -; (do ((steps-left numsteps (- steps-left 1)) -; (val last-val (- val step)) -; (ans '() (cons val ans))) -; ((<= steps-left 0) ans))))) -; -; -;(define (\:iota arg1 . rest-args) -; (receive (from to step) (%parse-iota-args arg1 rest-args :iota) -; (let* ((numsteps (ceiling (/ (- to from) step))) -; (last-val (+ from (* step (- numsteps 1))))) -; (if (< numsteps 0) (error "Negative step count" :iota from to step)) -; (do ((steps-left numsteps (- steps-left 1)) -; (val last-val (- val step)) -; (ans '() (cons val ans))) -; ((<= steps-left 0) ans))))) - - - -(define (circular-list val1 . vals) - (let ((ans (cons val1 vals))) - (set-cdr! (last-pair ans) ans) - ans)) - -;;; ::= () ; Empty proper list -;;; | (cons ) ; Proper-list pair -;;; Note that this definition rules out circular lists -- and this -;;; function is required to detect this case and return false. - -(define (proper-list? x) - (let lp ((x x) (lag x)) - (if (pair? x) - (let ((x (cdr x))) - (if (pair? x) - (let ((x (cdr x)) - (lag (cdr lag))) - (and (not (eq? x lag)) (lp x lag))) - (null? x))) - (null? x)))) - - -;;; A dotted list is a finite list (possibly of length 0) terminated -;;; by a non-nil value. Any non-cons, non-nil value (e.g., "foo" or 5) -;;; is a dotted list of length 0. -;;; -;;; ::= ; Empty dotted list -;;; | (cons ) ; Proper-list pair - -(define (dotted-list? x) - (let lp ((x x) (lag x)) - (if (pair? x) - (let ((x (cdr x))) - (if (pair? x) - (let ((x (cdr x)) - (lag (cdr lag))) - (and (not (eq? x lag)) (lp x lag))) - (not (null? x)))) - (not (null? x))))) - -(define (circular-list? x) - (let lp ((x x) (lag x)) - (and (pair? x) - (let ((x (cdr x))) - (and (pair? x) - (let ((x (cdr x)) - (lag (cdr lag))) - (or (eq? x lag) (lp x lag)))))))) - -(define (not-pair? x) (not (pair? x))) ; Inline me. - -;;; This is a legal definition which is fast and sloppy: -;;; (define null-list? not-pair?) -;;; but we'll provide a more careful one: -(define (null-list? l) - (cond ((pair? l) #f) - ((null? l) #t) - (else (error "null-list?: argument out of domain" l)))) - - -(define (list= = . lists) - (or (null? lists) ; special case - - (let lp1 ((list-a (car lists)) (others (cdr lists))) - (or (null? others) - (let ((list-b (car others)) - (others (cdr others))) - (if (eq? list-a list-b) ; EQ? => LIST= - (lp1 list-b others) - (let lp2 ((list-a list-a) (list-b list-b)) - (if (null-list? list-a) - (and (null-list? list-b) - (lp1 list-b others)) - (and (not (null-list? list-b)) - (= (car list-a) (car list-b)) - (lp2 (cdr list-a) (cdr list-b))))))))))) - - - -;;; R4RS, so commented out. -;(define (length x) ; LENGTH may diverge or -; (let lp ((x x) (len 0)) ; raise an error if X is -; (if (pair? x) ; a circular list. This version -; (lp (cdr x) (+ len 1)) ; diverges. -; len))) - -(define (length+ x) ; Returns #f if X is circular. - (let lp ((x x) (lag x) (len 0)) - (if (pair? x) - (let ((x (cdr x)) - (len (+ len 1))) - (if (pair? x) - (let ((x (cdr x)) - (lag (cdr lag)) - (len (+ len 1))) - (and (not (eq? x lag)) (lp x lag len))) - len)) - len))) - -(define (zip list1 . more-lists) (apply map list list1 more-lists)) - - -;;; Selectors -;;;;;;;;;;;;; - -;;; R4RS non-primitives: -;(define (caar x) (car (car x))) -;(define (cadr x) (car (cdr x))) -;(define (cdar x) (cdr (car x))) -;(define (cddr x) (cdr (cdr x))) -; -;(define (caaar x) (caar (car x))) -;(define (caadr x) (caar (cdr x))) -;(define (cadar x) (cadr (car x))) -;(define (caddr x) (cadr (cdr x))) -;(define (cdaar x) (cdar (car x))) -;(define (cdadr x) (cdar (cdr x))) -;(define (cddar x) (cddr (car x))) -;(define (cdddr x) (cddr (cdr x))) -; -;(define (caaaar x) (caaar (car x))) -;(define (caaadr x) (caaar (cdr x))) -;(define (caadar x) (caadr (car x))) -;(define (caaddr x) (caadr (cdr x))) -;(define (cadaar x) (cadar (car x))) -;(define (cadadr x) (cadar (cdr x))) -;(define (caddar x) (caddr (car x))) -;(define (cadddr x) (caddr (cdr x))) -;(define (cdaaar x) (cdaar (car x))) -;(define (cdaadr x) (cdaar (cdr x))) -;(define (cdadar x) (cdadr (car x))) -;(define (cdaddr x) (cdadr (cdr x))) -;(define (cddaar x) (cddar (car x))) -;(define (cddadr x) (cddar (cdr x))) -;(define (cdddar x) (cdddr (car x))) -;(define (cddddr x) (cdddr (cdr x))) - - -(define first car) -(define second cadr) -(define third caddr) -(define fourth cadddr) -(define (fifth x) (car (cddddr x))) -(define (sixth x) (cadr (cddddr x))) -(define (seventh x) (caddr (cddddr x))) -(define (eighth x) (cadddr (cddddr x))) -(define (ninth x) (car (cddddr (cddddr x)))) -(define (tenth x) (cadr (cddddr (cddddr x)))) - -(define (car+cdr pair) (values (car pair) (cdr pair))) - -;;; take & drop - -(define (take lis k) - (check-arg integer? k take) - (let recur ((lis lis) (k k)) - (if (zero? k) '() - (cons (car lis) - (recur (cdr lis) (- k 1)))))) - -(define (drop lis k) - (check-arg integer? k drop) - (let iter ((lis lis) (k k)) - (if (zero? k) lis (iter (cdr lis) (- k 1))))) - -(define (take! lis k) - (check-arg integer? k take!) - (if (zero? k) '() - (begin (set-cdr! (drop lis (- k 1)) '()) - lis))) - -;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list, -;;; off by K, then chasing down the list until the lead pointer falls off -;;; the end. - -(define (take-right lis k) - (check-arg integer? k take-right) - (let lp ((lag lis) (lead (drop lis k))) - (if (pair? lead) - (lp (cdr lag) (cdr lead)) - lag))) - -(define (drop-right lis k) - (check-arg integer? k drop-right) - (let recur ((lag lis) (lead (drop lis k))) - (if (pair? lead) - (cons (car lag) (recur (cdr lag) (cdr lead))) - '()))) - -;;; In this function, LEAD is actually K+1 ahead of LAG. This lets -;;; us stop LAG one step early, in time to smash its cdr to (). -(define (drop-right! lis k) - (check-arg integer? k drop-right!) - (let ((lead (drop lis k))) - (if (pair? lead) - - (let lp ((lag lis) (lead (cdr lead))) ; Standard case - (if (pair? lead) - (lp (cdr lag) (cdr lead)) - (begin (set-cdr! lag '()) - lis))) - - '()))) ; Special case dropping everything -- no cons to side-effect. - -;(define (list-ref lis i) (car (drop lis i))) ; R4RS - -;;; These use the APL convention, whereby negative indices mean -;;; "from the right." I liked them, but they didn't win over the -;;; SRFI reviewers. -;;; K >= 0: Take and drop K elts from the front of the list. -;;; K <= 0: Take and drop -K elts from the end of the list. - -;(define (take lis k) -; (check-arg integer? k take) -; (if (negative? k) -; (list-tail lis (+ k (length lis))) -; (let recur ((lis lis) (k k)) -; (if (zero? k) '() -; (cons (car lis) -; (recur (cdr lis) (- k 1))))))) -; -;(define (drop lis k) -; (check-arg integer? k drop) -; (if (negative? k) -; (let recur ((lis lis) (nelts (+ k (length lis)))) -; (if (zero? nelts) '() -; (cons (car lis) -; (recur (cdr lis) (- nelts 1))))) -; (list-tail lis k))) -; -; -;(define (take! lis k) -; (check-arg integer? k take!) -; (cond ((zero? k) '()) -; ((positive? k) -; (set-cdr! (list-tail lis (- k 1)) '()) -; lis) -; (else (list-tail lis (+ k (length lis)))))) -; -;(define (drop! lis k) -; (check-arg integer? k drop!) -; (if (negative? k) -; (let ((nelts (+ k (length lis)))) -; (if (zero? nelts) '() -; (begin (set-cdr! (list-tail lis (- nelts 1)) '()) -; lis))) -; (list-tail lis k))) - -(define (split-at x k) - (check-arg integer? k split-at) - (let recur ((lis x) (k k)) - (if (zero? k) (values '() lis) - (receive (prefix suffix) (recur (cdr lis) (- k 1)) - (values (cons (car lis) prefix) suffix))))) - -(define (split-at! x k) - (check-arg integer? k split-at!) - (if (zero? k) (values '() x) - (let* ((prev (drop x (- k 1))) - (suffix (cdr prev))) - (set-cdr! prev '()) - (values x suffix)))) - - -(define (last lis) (car (last-pair lis))) - -(define (last-pair lis) - (check-arg pair? lis last-pair) - (let lp ((lis lis)) - (let ((tail (cdr lis))) - (if (pair? tail) (lp tail) lis)))) - - -;;; Unzippers -- 1 through 5 -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (unzip1 lis) (map car lis)) - -(define (unzip2 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle - (let ((elt (car lis))) ; dotted lists. - (receive (a b) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b))))))) - -(define (unzip3 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis lis) - (let ((elt (car lis))) - (receive (a b c) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b) - (cons (caddr elt) c))))))) - -(define (unzip4 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis lis lis) - (let ((elt (car lis))) - (receive (a b c d) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b) - (cons (caddr elt) c) - (cons (cadddr elt) d))))))) - -(define (unzip5 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis lis lis lis) - (let ((elt (car lis))) - (receive (a b c d e) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b) - (cons (caddr elt) c) - (cons (cadddr elt) d) - (cons (car (cddddr elt)) e))))))) - - -;;; append! append-reverse append-reverse! concatenate concatenate! -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (append! . lists) - ;; First, scan through lists looking for a non-empty one. - (let lp ((lists lists) (prev '())) - (if (not (pair? lists)) prev - (let ((first (car lists)) - (rest (cdr lists))) - (if (not (pair? first)) (lp rest first) - - ;; Now, do the splicing. - (let lp2 ((tail-cons (last-pair first)) - (rest rest)) - (if (pair? rest) - (let ((next (car rest)) - (rest (cdr rest))) - (set-cdr! tail-cons next) - (lp2 (if (pair? next) (last-pair next) tail-cons) - rest)) - first))))))) - -;;; APPEND is R4RS. -;(define (append . lists) -; (if (pair? lists) -; (let recur ((list1 (car lists)) (lists (cdr lists))) -; (if (pair? lists) -; (let ((tail (recur (car lists) (cdr lists)))) -; (fold-right cons tail list1)) ; Append LIST1 & TAIL. -; list1)) -; '())) - -;(define (append-reverse rev-head tail) (fold cons tail rev-head)) - -;(define (append-reverse! rev-head tail) -; (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair) -; tail -; rev-head)) - -;;; Hand-inline the FOLD and PAIR-FOLD ops for speed. - -(define (append-reverse rev-head tail) - (let lp ((rev-head rev-head) (tail tail)) - (if (null-list? rev-head) tail - (lp (cdr rev-head) (cons (car rev-head) tail))))) - -(define (append-reverse! rev-head tail) - (let lp ((rev-head rev-head) (tail tail)) - (if (null-list? rev-head) tail - (let ((next-rev (cdr rev-head))) - (set-cdr! rev-head tail) - (lp next-rev rev-head))))) - - -(define (concatenate lists) (reduce-right append '() lists)) -(define (concatenate! lists) (reduce-right append! '() lists)) - -;;; Fold/map internal utilities -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; These little internal utilities are used by the general -;;; fold & mapper funs for the n-ary cases . It'd be nice if they got inlined. -;;; One the other hand, the n-ary cases are painfully inefficient as it is. -;;; An aggressive implementation should simply re-write these functions -;;; for raw efficiency; I have written them for as much clarity, portability, -;;; and simplicity as can be achieved. -;;; -;;; I use the dreaded call/cc to do local aborts. A good compiler could -;;; handle this with extreme efficiency. An implementation that provides -;;; a one-shot, non-persistent continuation grabber could help the compiler -;;; out by using that in place of the call/cc's in these routines. -;;; -;;; These functions have funky definitions that are precisely tuned to -;;; the needs of the fold/map procs -- for example, to minimize the number -;;; of times the argument lists need to be examined. - -;;; Return (map cdr lists). -;;; However, if any element of LISTS is empty, just abort and return '(). -(define (%cdrs lists) - (call-with-current-continuation - (lambda (abort) - (let recur ((lists lists)) - (if (pair? lists) - (let ((lis (car lists))) - (if (null-list? lis) (abort '()) - (cons (cdr lis) (recur (cdr lists))))) - '()))))) - -(define (%cars+ lists last-elt) ; (append! (map car lists) (list last-elt)) - (let recur ((lists lists)) - (if (pair? lists) (cons (caar lists) (recur (cdr lists))) (list last-elt)))) - -;;; LISTS is a (not very long) non-empty list of lists. -;;; Return two lists: the cars & the cdrs of the lists. -;;; However, if any of the lists is empty, just abort and return [() ()]. - -(define (%cars+cdrs lists) - (call-with-current-continuation - (lambda (abort) - (let recur ((lists lists)) - (if (pair? lists) - (receive (list other-lists) (car+cdr lists) - (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out - (receive (a d) (car+cdr list) - (receive (cars cdrs) (recur other-lists) - (values (cons a cars) (cons d cdrs)))))) - (values '() '())))))) - -;;; Like %CARS+CDRS, but we pass in a final elt tacked onto the end of the -;;; cars list. What a hack. -(define (%cars+cdrs+ lists cars-final) - (call-with-current-continuation - (lambda (abort) - (let recur ((lists lists)) - (if (pair? lists) - (receive (list other-lists) (car+cdr lists) - (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out - (receive (a d) (car+cdr list) - (receive (cars cdrs) (recur other-lists) - (values (cons a cars) (cons d cdrs)))))) - (values (list cars-final) '())))))) - -;;; Like %CARS+CDRS, but blow up if any list is empty. -(define (%cars+cdrs/no-test lists) - (let recur ((lists lists)) - (if (pair? lists) - (receive (list other-lists) (car+cdr lists) - (receive (a d) (car+cdr list) - (receive (cars cdrs) (recur other-lists) - (values (cons a cars) (cons d cdrs))))) - (values '() '())))) - - -;;; count -;;;;;;;;; -(define (count pred list1 . lists) - (check-arg procedure? pred count) - (if (pair? lists) - - ;; N-ary case - (let lp ((list1 list1) (lists lists) (i 0)) - (if (null-list? list1) i - (receive (as ds) (%cars+cdrs lists) - (if (null? as) i - (lp (cdr list1) ds - (if (apply pred (car list1) as) (+ i 1) i)))))) - - ;; Fast path - (let lp ((lis list1) (i 0)) - (if (null-list? lis) i - (lp (cdr lis) (if (pred (car lis)) (+ i 1) i)))))) - - -;;; fold/unfold -;;;;;;;;;;;;;;; - -(define (unfold-right p f g seed . maybe-tail) - (check-arg procedure? p unfold-right) - (check-arg procedure? f unfold-right) - (check-arg procedure? g unfold-right) - (let lp ((seed seed) (ans (#\:optional maybe-tail '()))) - (if (p seed) ans - (lp (g seed) - (cons (f seed) ans))))) - - -(define (unfold p f g seed . maybe-tail-gen) - (check-arg procedure? p unfold) - (check-arg procedure? f unfold) - (check-arg procedure? g unfold) - (if (pair? maybe-tail-gen) - - (let ((tail-gen (car maybe-tail-gen))) - (if (pair? (cdr maybe-tail-gen)) - (apply error "Too many arguments" unfold p f g seed maybe-tail-gen) - - (let recur ((seed seed)) - (if (p seed) (tail-gen seed) - (cons (f seed) (recur (g seed))))))) - - (let recur ((seed seed)) - (if (p seed) '() - (cons (f seed) (recur (g seed))))))) - - -(define (fold kons knil lis1 . lists) - (check-arg procedure? kons fold) - (if (pair? lists) - (let lp ((lists (cons lis1 lists)) (ans knil)) ; N-ary case - (receive (cars+ans cdrs) (%cars+cdrs+ lists ans) - (if (null? cars+ans) ans ; Done. - (lp cdrs (apply kons cars+ans))))) - - (let lp ((lis lis1) (ans knil)) ; Fast path - (if (null-list? lis) ans - (lp (cdr lis) (kons (car lis) ans)))))) - - -(define (fold-right kons knil lis1 . lists) - (check-arg procedure? kons fold-right) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) ; N-ary case - (let ((cdrs (%cdrs lists))) - (if (null? cdrs) knil - (apply kons (%cars+ lists (recur cdrs)))))) - - (let recur ((lis lis1)) ; Fast path - (if (null-list? lis) knil - (let ((head (car lis))) - (kons head (recur (cdr lis)))))))) - - -(define (pair-fold-right f zero lis1 . lists) - (check-arg procedure? f pair-fold-right) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) ; N-ary case - (let ((cdrs (%cdrs lists))) - (if (null? cdrs) zero - (apply f (append! lists (list (recur cdrs))))))) - - (let recur ((lis lis1)) ; Fast path - (if (null-list? lis) zero (f lis (recur (cdr lis))))))) - -(define (pair-fold f zero lis1 . lists) - (check-arg procedure? f pair-fold) - (if (pair? lists) - (let lp ((lists (cons lis1 lists)) (ans zero)) ; N-ary case - (let ((tails (%cdrs lists))) - (if (null? tails) ans - (lp tails (apply f (append! lists (list ans))))))) - - (let lp ((lis lis1) (ans zero)) - (if (null-list? lis) ans - (let ((tail (cdr lis))) ; Grab the cdr now, - (lp tail (f lis ans))))))) ; in case F SET-CDR!s LIS. - - -;;; REDUCE and REDUCE-RIGHT only use RIDENTITY in the empty-list case. -;;; These cannot meaningfully be n-ary. - -(define (reduce f ridentity lis) - (check-arg procedure? f reduce) - (if (null-list? lis) ridentity - (fold f (car lis) (cdr lis)))) - -(define (reduce-right f ridentity lis) - (check-arg procedure? f reduce-right) - (if (null-list? lis) ridentity - (let recur ((head (car lis)) (lis (cdr lis))) - (if (pair? lis) - (f head (recur (car lis) (cdr lis))) - head)))) - - - -;;; Mappers: append-map append-map! pair-for-each map! filter-map map-in-order -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (append-map f lis1 . lists) - (really-append-map append-map append f lis1 lists)) -(define (append-map! f lis1 . lists) - (really-append-map append-map! append! f lis1 lists)) - -(define (really-append-map who appender f lis1 lists) - (check-arg procedure? f who) - (if (pair? lists) - (receive (cars cdrs) (%cars+cdrs (cons lis1 lists)) - (if (null? cars) '() - (let recur ((cars cars) (cdrs cdrs)) - (let ((vals (apply f cars))) - (receive (cars2 cdrs2) (%cars+cdrs cdrs) - (if (null? cars2) vals - (appender vals (recur cars2 cdrs2)))))))) - - ;; Fast path - (if (null-list? lis1) '() - (let recur ((elt (car lis1)) (rest (cdr lis1))) - (let ((vals (f elt))) - (if (null-list? rest) vals - (appender vals (recur (car rest) (cdr rest))))))))) - - -(define (pair-for-each proc lis1 . lists) - (check-arg procedure? proc pair-for-each) - (if (pair? lists) - - (let lp ((lists (cons lis1 lists))) - (let ((tails (%cdrs lists))) - (if (pair? tails) - (begin (apply proc lists) - (lp tails))))) - - ;; Fast path. - (let lp ((lis lis1)) - (if (not (null-list? lis)) - (let ((tail (cdr lis))) ; Grab the cdr now, - (proc lis) ; in case PROC SET-CDR!s LIS. - (lp tail)))))) - -;;; We stop when LIS1 runs out, not when any list runs out. -(define (map! f lis1 . lists) - (check-arg procedure? f map!) - (if (pair? lists) - (let lp ((lis1 lis1) (lists lists)) - (if (not (null-list? lis1)) - (receive (heads tails) (%cars+cdrs/no-test lists) - (set-car! lis1 (apply f (car lis1) heads)) - (lp (cdr lis1) tails)))) - - ;; Fast path. - (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1)) - lis1) - - -;;; Map F across L, and save up all the non-false results. -(define (filter-map f lis1 . lists) - (check-arg procedure? f filter-map) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) - (receive (cars cdrs) (%cars+cdrs lists) - (if (pair? cars) - (cond ((apply f cars) => (lambda (x) (cons x (recur cdrs)))) - (else (recur cdrs))) ; Tail call in this arm. - '()))) - - ;; Fast path. - (let recur ((lis lis1)) - (if (null-list? lis) lis - (let ((tail (recur (cdr lis)))) - (cond ((f (car lis)) => (lambda (x) (cons x tail))) - (else tail))))))) - - -;;; Map F across lists, guaranteeing to go left-to-right. -;;; NOTE: Some implementations of R5RS MAP are compliant with this spec; -;;; in which case this procedure may simply be defined as a synonym for MAP. - -(define (map-in-order f lis1 . lists) - (check-arg procedure? f map-in-order) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) - (receive (cars cdrs) (%cars+cdrs lists) - (if (pair? cars) - (let ((x (apply f cars))) ; Do head first, - (cons x (recur cdrs))) ; then tail. - '()))) - - ;; Fast path. - (let recur ((lis lis1)) - (if (null-list? lis) lis - (let ((tail (cdr lis)) - (x (f (car lis)))) ; Do head first, - (cons x (recur tail))))))) ; then tail. - - -;;; We extend MAP to handle arguments of unequal length. -(define map map-in-order) - - -;;; filter, remove, partition -;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; FILTER, REMOVE, PARTITION and their destructive counterparts do not -;;; disorder the elements of their argument. - -;; This FILTER shares the longest tail of L that has no deleted elements. -;; If Scheme had multi-continuation calls, they could be made more efficient. - -(define (filter pred lis) ; Sleazing with EQ? makes this - (check-arg procedure? pred filter) ; one faster. - (let recur ((lis lis)) - (if (null-list? lis) lis ; Use NOT-PAIR? to handle dotted lists. - (let ((head (car lis)) - (tail (cdr lis))) - (if (pred head) - (let ((new-tail (recur tail))) ; Replicate the RECUR call so - (if (eq? tail new-tail) lis - (cons head new-tail))) - (recur tail)))))) ; this one can be a tail call. - - -;;; Another version that shares longest tail. -;(define (filter pred lis) -; (receive (ans no-del?) -; ;; (recur l) returns L with (pred x) values filtered. -; ;; It also returns a flag NO-DEL? if the returned value -; ;; is EQ? to L, i.e. if it didn't have to delete anything. -; (let recur ((l l)) -; (if (null-list? l) (values l #t) -; (let ((x (car l)) -; (tl (cdr l))) -; (if (pred x) -; (receive (ans no-del?) (recur tl) -; (if no-del? -; (values l #t) -; (values (cons x ans) #f))) -; (receive (ans no-del?) (recur tl) ; Delete X. -; (values ans #f)))))) -; ans)) - - - -;(define (filter! pred lis) ; Things are much simpler -; (let recur ((lis lis)) ; if you are willing to -; (if (pair? lis) ; push N stack frames & do N -; (cond ((pred (car lis)) ; SET-CDR! writes, where N is -; (set-cdr! lis (recur (cdr lis))); the length of the answer. -; lis) -; (else (recur (cdr lis)))) -; lis))) - - -;;; This implementation of FILTER! -;;; - doesn't cons, and uses no stack; -;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are -;;; usually expensive on modern machines, and can be extremely expensive on -;;; modern Schemes (e.g., ones that have generational GC's). -;;; It just zips down contiguous runs of in and out elts in LIS doing the -;;; minimal number of SET-CDR!s to splice the tail of one run of ins to the -;;; beginning of the next. - -(define (filter! pred lis) - (check-arg procedure? pred filter!) - (let lp ((ans lis)) - (cond ((null-list? ans) ans) ; Scan looking for - ((not (pred (car ans))) (lp (cdr ans))) ; first cons of result. - - ;; ANS is the eventual answer. - ;; SCAN-IN: (CDR PREV) = LIS and (CAR PREV) satisfies PRED. - ;; Scan over a contiguous segment of the list that - ;; satisfies PRED. - ;; SCAN-OUT: (CAR PREV) satisfies PRED. Scan over a contiguous - ;; segment of the list that *doesn't* satisfy PRED. - ;; When the segment ends, patch in a link from PREV - ;; to the start of the next good segment, and jump to - ;; SCAN-IN. - (else (letrec ((scan-in (lambda (prev lis) - (if (pair? lis) - (if (pred (car lis)) - (scan-in lis (cdr lis)) - (scan-out prev (cdr lis)))))) - (scan-out (lambda (prev lis) - (let lp ((lis lis)) - (if (pair? lis) - (if (pred (car lis)) - (begin (set-cdr! prev lis) - (scan-in lis (cdr lis))) - (lp (cdr lis))) - (set-cdr! prev lis)))))) - (scan-in ans (cdr ans)) - ans))))) - - - -;;; Answers share common tail with LIS where possible; -;;; the technique is slightly subtle. - -(define (partition pred lis) - (check-arg procedure? pred partition) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle dotted lists. - (let ((elt (car lis)) - (tail (cdr lis))) - (receive (in out) (recur tail) - (if (pred elt) - (values (if (pair? out) (cons elt in) lis) out) - (values in (if (pair? in) (cons elt out) lis)))))))) - - - -;(define (partition! pred lis) ; Things are much simpler -; (let recur ((lis lis)) ; if you are willing to -; (if (null-list? lis) (values lis lis) ; push N stack frames & do N -; (let ((elt (car lis))) ; SET-CDR! writes, where N is -; (receive (in out) (recur (cdr lis)) ; the length of LIS. -; (cond ((pred elt) -; (set-cdr! lis in) -; (values lis out)) -; (else (set-cdr! lis out) -; (values in lis)))))))) - - -;;; This implementation of PARTITION! -;;; - doesn't cons, and uses no stack; -;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are -;;; usually expensive on modern machines, and can be extremely expensive on -;;; modern Schemes (e.g., ones that have generational GC's). -;;; It just zips down contiguous runs of in and out elts in LIS doing the -;;; minimal number of SET-CDR!s to splice these runs together into the result -;;; lists. - -(define (partition! pred lis) - (check-arg procedure? pred partition!) - (if (null-list? lis) (values lis lis) - - ;; This pair of loops zips down contiguous in & out runs of the - ;; list, splicing the runs together. The invariants are - ;; SCAN-IN: (cdr in-prev) = LIS. - ;; SCAN-OUT: (cdr out-prev) = LIS. - (letrec ((scan-in (lambda (in-prev out-prev lis) - (let lp ((in-prev in-prev) (lis lis)) - (if (pair? lis) - (if (pred (car lis)) - (lp lis (cdr lis)) - (begin (set-cdr! out-prev lis) - (scan-out in-prev lis (cdr lis)))) - (set-cdr! out-prev lis))))) ; Done. - - (scan-out (lambda (in-prev out-prev lis) - (let lp ((out-prev out-prev) (lis lis)) - (if (pair? lis) - (if (pred (car lis)) - (begin (set-cdr! in-prev lis) - (scan-in lis out-prev (cdr lis))) - (lp lis (cdr lis))) - (set-cdr! in-prev lis)))))) ; Done. - - ;; Crank up the scan&splice loops. - (if (pred (car lis)) - ;; LIS begins in-list. Search for out-list's first pair. - (let lp ((prev-l lis) (l (cdr lis))) - (cond ((not (pair? l)) (values lis l)) - ((pred (car l)) (lp l (cdr l))) - (else (scan-out prev-l l (cdr l)) - (values lis l)))) ; Done. - - ;; LIS begins out-list. Search for in-list's first pair. - (let lp ((prev-l lis) (l (cdr lis))) - (cond ((not (pair? l)) (values l lis)) - ((pred (car l)) - (scan-in l prev-l (cdr l)) - (values l lis)) ; Done. - (else (lp l (cdr l))))))))) - - -;;; Inline us, please. -(define (remove pred l) (filter (lambda (x) (not (pred x))) l)) -(define (remove! pred l) (filter! (lambda (x) (not (pred x))) l)) - - - -;;; Here's the taxonomy for the DELETE/ASSOC/MEMBER functions. -;;; (I don't actually think these are the world's most important -;;; functions -- the procedural FILTER/REMOVE/FIND/FIND-TAIL variants -;;; are far more general.) -;;; -;;; Function Action -;;; --------------------------------------------------------------------------- -;;; remove pred lis Delete by general predicate -;;; delete x lis [=] Delete by element comparison -;;; -;;; find pred lis Search by general predicate -;;; find-tail pred lis Search by general predicate -;;; member x lis [=] Search by element comparison -;;; -;;; assoc key lis [=] Search alist by key comparison -;;; alist-delete key alist [=] Alist-delete by key comparison - -(define (delete x lis . maybe-=) - (let ((= (#\:optional maybe-= equal?))) - (filter (lambda (y) (not (= x y))) lis))) - -(define (delete! x lis . maybe-=) - (let ((= (#\:optional maybe-= equal?))) - (filter! (lambda (y) (not (= x y))) lis))) - -;;; Extended from R4RS to take an optional comparison argument. -(define (member x lis . maybe-=) - (let ((= (#\:optional maybe-= equal?))) - (find-tail (lambda (y) (= x y)) lis))) - -;;; R4RS, hence we don't bother to define. -;;; The MEMBER and then FIND-TAIL call should definitely -;;; be inlined for MEMQ & MEMV. -;(define (memq x lis) (member x lis eq?)) -;(define (memv x lis) (member x lis eqv?)) - - -;;; right-duplicate deletion -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; delete-duplicates delete-duplicates! -;;; -;;; Beware -- these are N^2 algorithms. To efficiently remove duplicates -;;; in long lists, sort the list to bring duplicates together, then use a -;;; linear-time algorithm to kill the dups. Or use an algorithm based on -;;; element-marking. The former gives you O(n lg n), the latter is linear. - -(define (delete-duplicates lis . maybe-=) - (let ((elt= (#\:optional maybe-= equal?))) - (check-arg procedure? elt= delete-duplicates) - (let recur ((lis lis)) - (if (null-list? lis) lis - (let* ((x (car lis)) - (tail (cdr lis)) - (new-tail (recur (delete x tail elt=)))) - (if (eq? tail new-tail) lis (cons x new-tail))))))) - -(define (delete-duplicates! lis maybe-=) - (let ((elt= (#\:optional maybe-= equal?))) - (check-arg procedure? elt= delete-duplicates!) - (let recur ((lis lis)) - (if (null-list? lis) lis - (let* ((x (car lis)) - (tail (cdr lis)) - (new-tail (recur (delete! x tail elt=)))) - (if (eq? tail new-tail) lis (cons x new-tail))))))) - - -;;; alist stuff -;;;;;;;;;;;;;;; - -;;; Extended from R4RS to take an optional comparison argument. -(define (assoc x lis . maybe-=) - (let ((= (#\:optional maybe-= equal?))) - (find (lambda (entry) (= x (car entry))) lis))) - -(define (alist-cons key datum alist) (cons (cons key datum) alist)) - -(define (alist-copy alist) - (map (lambda (elt) (cons (car elt) (cdr elt))) - alist)) - -(define (alist-delete key alist . maybe-=) - (let ((= (#\:optional maybe-= equal?))) - (filter (lambda (elt) (not (= key (car elt)))) alist))) - -(define (alist-delete! key alist . maybe-=) - (let ((= (#\:optional maybe-= equal?))) - (filter! (lambda (elt) (not (= key (car elt)))) alist))) - - -;;; find find-tail take-while drop-while span break any every list-index -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (find pred list) - (cond ((find-tail pred list) => car) - (else #f))) - -(define (find-tail pred list) - (check-arg procedure? pred find-tail) - (let lp ((list list)) - (and (not (null-list? list)) - (if (pred (car list)) list - (lp (cdr list)))))) - -(define (take-while pred lis) - (check-arg procedure? pred take-while) - (let recur ((lis lis)) - (if (null-list? lis) '() - (let ((x (car lis))) - (if (pred x) - (cons x (recur (cdr lis))) - '()))))) - -(define (drop-while pred lis) - (check-arg procedure? pred drop-while) - (let lp ((lis lis)) - (if (null-list? lis) '() - (if (pred (car lis)) - (lp (cdr lis)) - lis)))) - -(define (take-while! pred lis) - (check-arg procedure? pred take-while!) - (if (or (null-list? lis) (not (pred (car lis)))) '() - (begin (let lp ((prev lis) (rest (cdr lis))) - (if (pair? rest) - (let ((x (car rest))) - (if (pred x) (lp rest (cdr rest)) - (set-cdr! prev '()))))) - lis))) - -(define (span pred lis) - (check-arg procedure? pred span) - (let recur ((lis lis)) - (if (null-list? lis) (values '() '()) - (let ((x (car lis))) - (if (pred x) - (receive (prefix suffix) (recur (cdr lis)) - (values (cons x prefix) suffix)) - (values '() lis)))))) - -(define (span! pred lis) - (check-arg procedure? pred span!) - (if (or (null-list? lis) (not (pred (car lis)))) (values '() lis) - (let ((suffix (let lp ((prev lis) (rest (cdr lis))) - (if (null-list? rest) rest - (let ((x (car rest))) - (if (pred x) (lp rest (cdr rest)) - (begin (set-cdr! prev '()) - rest))))))) - (values lis suffix)))) - - -(define (break pred lis) (span (lambda (x) (not (pred x))) lis)) -(define (break! pred lis) (span! (lambda (x) (not (pred x))) lis)) - -(define (any pred lis1 . lists) - (check-arg procedure? pred any) - (if (pair? lists) - - ;; N-ary case - (receive (heads tails) (%cars+cdrs (cons lis1 lists)) - (and (pair? heads) - (let lp ((heads heads) (tails tails)) - (receive (next-heads next-tails) (%cars+cdrs tails) - (if (pair? next-heads) - (or (apply pred heads) (lp next-heads next-tails)) - (apply pred heads)))))) ; Last PRED app is tail call. - - ;; Fast path - (and (not (null-list? lis1)) - (let lp ((head (car lis1)) (tail (cdr lis1))) - (if (null-list? tail) - (pred head) ; Last PRED app is tail call. - (or (pred head) (lp (car tail) (cdr tail)))))))) - - -;(define (every pred list) ; Simple definition. -; (let lp ((list list)) ; Doesn't return the last PRED value. -; (or (not (pair? list)) -; (and (pred (car list)) -; (lp (cdr list)))))) - -(define (every pred lis1 . lists) - (check-arg procedure? pred every) - (if (pair? lists) - - ;; N-ary case - (receive (heads tails) (%cars+cdrs (cons lis1 lists)) - (or (not (pair? heads)) - (let lp ((heads heads) (tails tails)) - (receive (next-heads next-tails) (%cars+cdrs tails) - (if (pair? next-heads) - (and (apply pred heads) (lp next-heads next-tails)) - (apply pred heads)))))) ; Last PRED app is tail call. - - ;; Fast path - (or (null-list? lis1) - (let lp ((head (car lis1)) (tail (cdr lis1))) - (if (null-list? tail) - (pred head) ; Last PRED app is tail call. - (and (pred head) (lp (car tail) (cdr tail)))))))) - -(define (list-index pred lis1 . lists) - (check-arg procedure? pred list-index) - (if (pair? lists) - - ;; N-ary case - (let lp ((lists (cons lis1 lists)) (n 0)) - (receive (heads tails) (%cars+cdrs lists) - (and (pair? heads) - (if (apply pred heads) n - (lp tails (+ n 1)))))) - - ;; Fast path - (let lp ((lis lis1) (n 0)) - (and (not (null-list? lis)) - (if (pred (car lis)) n (lp (cdr lis) (+ n 1))))))) - -;;; Reverse -;;;;;;;;;;; - -;R4RS, so not defined here. -;(define (reverse lis) (fold cons '() lis)) - -;(define (reverse! lis) -; (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair) '() lis)) - -(define (reverse! lis) - (let lp ((lis lis) (ans '())) - (if (null-list? lis) ans - (let ((tail (cdr lis))) - (set-cdr! lis ans) - (lp tail lis))))) - -;;; Lists-as-sets -;;;;;;;;;;;;;;;;; - -;;; This is carefully tuned code; do not modify casually. -;;; - It is careful to share storage when possible; -;;; - Side-effecting code tries not to perform redundant writes. -;;; - It tries to avoid linear-time scans in special cases where constant-time -;;; computations can be performed. -;;; - It relies on similar properties from the other list-lib procs it calls. -;;; For example, it uses the fact that the implementations of MEMBER and -;;; FILTER in this source code share longest common tails between args -;;; and results to get structure sharing in the lset procedures. - -(define (%lset2<= = lis1 lis2) (every (lambda (x) (member x lis2 =)) lis1)) - -(define (lset<= = . lists) - (check-arg procedure? = lset<=) - (or (not (pair? lists)) ; 0-ary case - (let lp ((s1 (car lists)) (rest (cdr lists))) - (or (not (pair? rest)) - (let ((s2 (car rest)) (rest (cdr rest))) - (and (or (eq? s2 s1) ; Fast path - (%lset2<= = s1 s2)) ; Real test - (lp s2 rest))))))) - -(define (lset= = . lists) - (check-arg procedure? = lset=) - (or (not (pair? lists)) ; 0-ary case - (let lp ((s1 (car lists)) (rest (cdr lists))) - (or (not (pair? rest)) - (let ((s2 (car rest)) - (rest (cdr rest))) - (and (or (eq? s1 s2) ; Fast path - (and (%lset2<= = s1 s2) (%lset2<= = s2 s1))) ; Real test - (lp s2 rest))))))) - - -(define (lset-adjoin = lis . elts) - (check-arg procedure? = lset-adjoin) - (fold (lambda (elt ans) (if (member elt ans =) ans (cons elt ans))) - lis elts)) - - -(define (lset-union = . lists) - (check-arg procedure? = lset-union) - (reduce (lambda (lis ans) ; Compute ANS + LIS. - (cond ((null? lis) ans) ; Don't copy any lists - ((null? ans) lis) ; if we don't have to. - ((eq? lis ans) ans) - (else - (fold (lambda (elt ans) (if (any (lambda (x) (= x elt)) ans) - ans - (cons elt ans))) - ans lis)))) - '() lists)) - -(define (lset-union! = . lists) - (check-arg procedure? = lset-union!) - (reduce (lambda (lis ans) ; Splice new elts of LIS onto the front of ANS. - (cond ((null? lis) ans) ; Don't copy any lists - ((null? ans) lis) ; if we don't have to. - ((eq? lis ans) ans) - (else - (pair-fold (lambda (pair ans) - (let ((elt (car pair))) - (if (any (lambda (x) (= x elt)) ans) - ans - (begin (set-cdr! pair ans) pair)))) - ans lis)))) - '() lists)) - - -(define (lset-intersection = lis1 . lists) - (check-arg procedure? = lset-intersection) - (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. - (cond ((any null-list? lists) '()) ; Short cut - ((null? lists) lis1) ; Short cut - (else (filter (lambda (x) - (every (lambda (lis) (member x lis =)) lists)) - lis1))))) - -(define (lset-intersection! = lis1 . lists) - (check-arg procedure? = lset-intersection!) - (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. - (cond ((any null-list? lists) '()) ; Short cut - ((null? lists) lis1) ; Short cut - (else (filter! (lambda (x) - (every (lambda (lis) (member x lis =)) lists)) - lis1))))) - - -(define (lset-difference = lis1 . lists) - (check-arg procedure? = lset-difference) - (let ((lists (filter pair? lists))) ; Throw out empty lists. - (cond ((null? lists) lis1) ; Short cut - ((memq lis1 lists) '()) ; Short cut - (else (filter (lambda (x) - (every (lambda (lis) (not (member x lis =))) - lists)) - lis1))))) - -(define (lset-difference! = lis1 . lists) - (check-arg procedure? = lset-difference!) - (let ((lists (filter pair? lists))) ; Throw out empty lists. - (cond ((null? lists) lis1) ; Short cut - ((memq lis1 lists) '()) ; Short cut - (else (filter! (lambda (x) - (every (lambda (lis) (not (member x lis =))) - lists)) - lis1))))) - - -(define (lset-xor = . lists) - (check-arg procedure? = lset-xor) - (reduce (lambda (b a) ; Compute A xor B: - ;; Note that this code relies on the constant-time - ;; short-cuts provided by LSET-DIFF+INTERSECTION, - ;; LSET-DIFFERENCE & APPEND to provide constant-time short - ;; cuts for the cases A = (), B = (), and A eq? B. It takes - ;; a careful case analysis to see it, but it's carefully - ;; built in. - - ;; Compute a-b and a^b, then compute b-(a^b) and - ;; cons it onto the front of a-b. - (receive (a-b a-int-b) (lset-diff+intersection = a b) - (cond ((null? a-b) (lset-difference = b a)) - ((null? a-int-b) (append b a)) - (else (fold (lambda (xb ans) - (if (member xb a-int-b =) ans (cons xb ans))) - a-b - b))))) - '() lists)) - - -(define (lset-xor! = . lists) - (check-arg procedure? = lset-xor!) - (reduce (lambda (b a) ; Compute A xor B: - ;; Note that this code relies on the constant-time - ;; short-cuts provided by LSET-DIFF+INTERSECTION, - ;; LSET-DIFFERENCE & APPEND to provide constant-time short - ;; cuts for the cases A = (), B = (), and A eq? B. It takes - ;; a careful case analysis to see it, but it's carefully - ;; built in. - - ;; Compute a-b and a^b, then compute b-(a^b) and - ;; cons it onto the front of a-b. - (receive (a-b a-int-b) (lset-diff+intersection! = a b) - (cond ((null? a-b) (lset-difference! = b a)) - ((null? a-int-b) (append! b a)) - (else (pair-fold (lambda (b-pair ans) - (if (member (car b-pair) a-int-b =) ans - (begin (set-cdr! b-pair ans) b-pair))) - a-b - b))))) - '() lists)) - - -(define (lset-diff+intersection = lis1 . lists) - (check-arg procedure? = lset-diff+intersection) - (cond ((every null-list? lists) (values lis1 '())) ; Short cut - ((memq lis1 lists) (values '() lis1)) ; Short cut - (else (partition (lambda (elt) - (not (any (lambda (lis) (member elt lis =)) - lists))) - lis1)))) - -(define (lset-diff+intersection! = lis1 . lists) - (check-arg procedure? = lset-diff+intersection!) - (cond ((every null-list? lists) (values lis1 '())) ; Short cut - ((memq lis1 lists) (values '() lis1)) ; Short cut - (else (partition! (lambda (elt) - (not (any (lambda (lis) (member elt lis =)) - lists))) - lis1)))) -;;; Copyright (C) John Cowan 2013. All Rights Reserved. - -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to -;;; deal in the Software without restriction, including without limitation the -;;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -;;; sell copies of the Software, and to permit persons to whom the Software is -;;; furnished to do so, subject to the following conditions: - -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. - -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(define-library (srfi 111) - (export box box? unbox set-box!) - (import (scheme base)) - (begin - (define-record-type - (box value) - box? - (value unbox set-box!)))) -;; Copyright (C) Taylan Ulrich Bayırlı/Kammer (2015). All Rights Reserved. - -;; Permission is hereby granted, free of charge, to any person obtaining -;; a copy of this software and associated documentation files (the -;; "Software"), to deal in the Software without restriction, including -;; without limitation the rights to use, copy, modify, merge, publish, -;; distribute, sublicense, and/or sell copies of the Software, and to -;; permit persons to whom the Software is furnished to do so, subject to -;; the following conditions: - -;; The above copyright notice and this permission notice shall be -;; included in all copies or substantial portions of the Software. - -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE -;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION -;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION -;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -(define-library (srfi 17) - (export set! setter getter-with-setter) - (import - (rename (scheme base) (set! %set!)) - (srfi 1)) - (begin - - (define-syntax set! - (syntax-rules () - ((_ (getter arg ...) val) - ((setter getter) arg ... val)) - ((_ var val) - (%set! var val)))) - - (define setter - (let ((setters `((,car . ,set-car!) - (,cdr . ,set-cdr!) - (,caar . ,(lambda (p v) (set-car! (car p) v))) - (,cadr . ,(lambda (p v) (set-car! (cdr p) v))) - (,cdar . ,(lambda (p v) (set-cdr! (car p) v))) - (,cddr . ,(lambda (p v) (set-cdr! (cdr p) v))) - (,list-ref . ,list-set!) - (,vector-ref . ,vector-set!) - (,string-ref . ,string-set!) - (,bytevector-u8-ref . ,bytevector-u8-set!)))) - (letrec ((setter - (lambda (proc) - (let ((probe (assv proc setters))) - (if probe - (cdr probe) - (error "No setter for " proc))))) - (set-setter! - (lambda (proc setter) - (set! setters (cons (cons proc setter) setters))))) - (set-setter! setter set-setter!) - setter))) - - (define (getter-with-setter get set) - (let ((proc (lambda args (apply get args)))) - (set! (setter proc) set) - proc)) - - )) -;; Copyright (C) Taylan Ulrich Bayırlı/Kammer (2015). All Rights Reserved. - -;; Permission is hereby granted, free of charge, to any person obtaining -;; a copy of this software and associated documentation files (the -;; "Software"), to deal in the Software without restriction, including -;; without limitation the rights to use, copy, modify, merge, publish, -;; distribute, sublicense, and/or sell copies of the Software, and to -;; permit persons to whom the Software is furnished to do so, subject to -;; the following conditions: - -;; The above copyright notice and this permission notice shall be -;; included in all copies or substantial portions of the Software. - -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE -;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION -;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION -;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -;;; The SRFI claims that having the same variable appear multiple times is an -;;; error in let* and so also in and-let*. In fact let* allows rebinding the -;;; same variable, so we also allow it here. - -(define-library (srfi 2) - (export and-let*) - (import (scheme base)) - (begin - (define-syntax and-let* - (syntax-rules () - - ;; Handle zero-clauses special-case. - ((_ () . body) - (begin #t . body)) - - ;; Reduce clauses down to one regardless of body. - ((_ ((var expr) rest . rest*) . body) - (let ((var expr)) - (and var (and-let* (rest . rest*) . body)))) - ((_ ((expr) rest . rest*) . body) - (and expr (and-let* (rest . rest*) . body))) - ((_ (var rest . rest*) . body) - (begin - (let ((var #f)) #f) ;(identifier? var) - (and var (and-let* (rest . rest*) . body)))) - - ;; Handle 1-clause cases without a body. - ((_ ((var expr))) - expr) - ((_ ((expr))) - expr) - ((_ (var)) - (begin - (let ((var #f)) #f) ;(identifier? var) - var)) - - ;; Handle 1-clause cases with a body. - ((_ ((var expr)) . body) - (let ((var expr)) - (and var (begin . body)))) - ((_ ((expr)) . body) - (and expr (begin . body))) - ((_ (var) . body) - (begin - (let ((var #f)) #f) ;(identifier? var) - (and var (begin . body)))))))) -;;; Copyright (C) André van Tonder (2004). All Rights Reserved. - -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to -;;; deal in the Software without restriction, including without limitation the -;;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -;;; sell copies of the Software, and to permit persons to whom the Software is -;;; furnished to do so, subject to the following conditions: - -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. - -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -;============================================================================================ -; IMPLEMENTATION: -; -; Andre van Tonder, 2004. -; -;============================================================================================ - -(define-syntax define-record-type - (syntax-rules () - ((define-record-type . body) - (parse-declaration #f . body)))) - -(define-syntax define-record-scheme - (syntax-rules () - ((define-record-scheme . body) - (parse-declaration #t . body)))) - -(define-syntax parse-declaration - (syntax-rules () - ((parse-declaration is-scheme? (name super ...) constructor-clause predicate field-clause ...) - (build-record 0 constructor-clause (super ...) (field-clause ...) name predicate is-scheme?)) - ((parse-declaration is-scheme? (name super ...) constructor-clause) - (parse-declaration is-scheme? (name super ...) constructor-clause #f)) - ((parse-declaration is-scheme? (name super ...)) - (parse-declaration is-scheme? (name super ...) #f #f)) - ((parse-declaration is-scheme? name . rest) - (parse-declaration is-scheme? (name) . rest)))) - -(define-syntax record-update! - (syntax-rules () - ((record-update! record name (label exp) ...) - (meta - `(let ((r record)) - ((meta ,(name ("setter") label)) r exp) - ... - r))))) - -(define-syntax record-update - (syntax-rules () - ((record-update record name (label exp) ...) - (name ("is-scheme?") - (meta - `(let ((new ((meta ,(name ("copier"))) record))) - (record-update! new name (label exp) ...))) - (record-compose (name record) (name (label exp) ...)))))) - -(define-syntax record-compose - (syntax-rules () - ((record-compose (export-name (label exp) ...)) - (export-name (label exp) ...)) - ((record-compose (import-name record) ... (export-name (label exp) ...)) - (help-compose 1 (import-name record) ... (export-name (label exp) ...))))) - -(define-syntax help-compose - (syntax-rules () - ((help-compose 1 (import-name record) import ... (export-name (label exp) ...)) - (meta - `(help-compose 2 - (meta ,(intersection - (meta ,(export-name ("labels"))) - (meta ,(remove-from (meta ,(import-name ("labels"))) - (label ...) - if-free=)) - if-free=)) - (import-name record) - import ... - (export-name (label exp) ...)))) - ((help-compose 2 (copy-label ...) (import-name record) import ... (export-name . bindings)) - (meta - `(let ((r record)) - (record-compose import ... - (export-name (copy-label ((meta ,(import-name ("getter") copy-label)) r)) - ... - . bindings))))))) - -(define-syntax build-record - (syntax-rules () - ((build-record 0 (constructor . pos-labels) . rest) ; extract positional labels from constructor clause - (build-record 1 (constructor . pos-labels) pos-labels . rest)) ; - ((build-record 0 constructor . rest) ; - (build-record 1 (constructor . #f) () . rest)) ; - ((build-record 1 constructor-clause (pos-label ...) (super ...) - ((label . accessors) ...) . rest) - (meta - `(build-record 2 - constructor-clause - (meta ,(union (meta ,(super ("labels"))) ; compute union of labels from supers, - ... ; constructor clause and field clauses - (pos-label ...) - (label ...) - top:if-free=)) - ((label . accessors) ...) - (meta ,(union (meta ,(super ("supers"))) ; compute transitive union of supers - ... - top:if-free=)) - . rest))) - ((build-record 2 (constructor . pos-labels) labels . rest) ; insert default constructor labels if not given - (syntax-if pos-labels - (build-record 3 (constructor . pos-labels) labels . rest) - (build-record 3 (constructor . labels) labels . rest))) - ((build-record 3 constructor-clause labels ((label . accessors) ...) . rest) - (meta - `(build-record 4 - (meta ,(remove-from labels ; separate the labels that do not appear in a - (label ...) ; field clause for next step - top:if-free=)) - ((label . accessors) ...) - constructor-clause - labels - . rest))) - ((build-record 4 - (undeclared-label ...) - (field-clause ...) - (constructor . pos-labels) - labels - supers - name - predicate - is-scheme?) - (meta - `(build-record 5 ; generate identifiers for constructor, predicate - is-scheme? ; getters and setters as needed - name - supers - supers - labels - (meta ,(to-identifier constructor)) - (meta ,(add-temporaries pos-labels)) ; needed for constructor below - (meta ,(to-identifier predicate)) - (meta ,(augment-field field-clause)) - ... - (undeclared-label (meta ,(generate-identifier)) - (meta ,(generate-identifier))) - ...))) - ((build-record 5 - is-scheme? - name - (super ...) - supers - (label ...) - constructor - ((pos-label pos-temp) ...) - predicate - (field-label getter setter) - ...) - - (begin - (syntax-if is-scheme? - - (begin - (define-generic (predicate x) (lambda (x) #f)) - (define-generic (getter x)) - ... - (define-generic (setter x v)) - ... - (define-generic (copy x))) - - (begin - (srfi-9:define-record-type internal-name - (maker field-label ...) - predicate - (field-label getter setter) ...) - - (define constructor - (lambda (pos-temp ...) - (populate 1 maker (field-label ...) (pos-label pos-temp) ...))) - - (extend-predicates supers predicate) - (extend-accessors supers field-label predicate getter setter) - ... - - (define (copy x) - (maker (getter x) ...)) - (extend-copiers supers copy predicate) - - (define-method (show (r predicate)) - (list 'name - (list 'field-label (getter r)) - ...)))) - - (define-syntax name - (syntax-rules (field-label ...) - ((name ("is-scheme?") sk fk) (syntax-if is-scheme? sk fk)) - ((name ("predicate") k) (syntax-apply k predicate)) - ((name ("supers") k) (syntax-apply k (super ... name))) - ((name ("labels") k) (syntax-apply k (label ...))) - ((name ("pos-labels") k) (syntax-apply k (pos-label ...))) - ((name ("getter") field-label k) (syntax-apply k getter)) - ... - ((name ("getter") other k) (syntax-apply k #f)) - ((name ("setter") field-label k) (syntax-apply k setter)) - ... - ((name ("setter") other k) (syntax-apply k #f)) - ((name ("copier") k) (syntax-apply k copy)) - ((name . bindings) (populate 1 maker (field-label ...) . bindings)))))))) - - -(define-syntax to-identifier - (syntax-rules () - ((to-identifier #f k) (syntax-apply k generated-identifier)) - ((to-identifier id k) (syntax-apply k id)))) - -(define-syntax augment-field - (syntax-rules () - ((augment-field (label) k) (syntax-apply k (label generated-getter generated-setter))) - ((augment-field (label getter) k) (meta `(label (meta ,(to-identifier getter)) generated-setter) k)) - ((augment-field (label getter setter) k) (meta `(label (meta ,(to-identifier getter)) - (meta ,(to-identifier setter))) k)))) - -(define-syntax extend-predicates - (syntax-rules () - ((extend-predicates (super ...) predicate) - (begin - (meta - `(define-method (meta ,(super ("predicate"))) - (predicate) - (x) - any?)) - ...)))) - -(define-syntax extend-copiers - (syntax-rules () - ((extend-copiers (super ...) copy predicate) - (begin - (meta - `(define-method (meta ,(super ("copier"))) - (predicate) - (x) - copy)) - ...)))) - -(define-syntax extend-accessors - (syntax-rules () - ((extend-accessors (super ...) label predicate selector modifier) - (meta - `(begin - (syntax-if (meta ,(super ("getter") label)) - (define-method (meta ,(super ("getter") label)) - (predicate) - (x) - selector) - (begin)) - ... - (syntax-if (meta ,(super ("setter") label)) - (define-method (meta ,(super ("setter") label)) - (predicate any?) - (x v) - modifier) - (begin)) - ...))))) - -(define-syntax populate - (syntax-rules () - ((populate 1 maker labels . bindings) - (meta - `(populate 2 maker - (meta ,(order labels bindings (')))))) - ((populate 2 maker ((label exp) ...)) - (maker exp ...)))) - -(define-syntax order - (syntax-rules () - ((order (label ...) ((label* . binding) ...) default k) - (meta - `(if-empty? (meta ,(remove-from (label* ...) - (label ...) - if-free=)) - (order "emit" (label ...) ((label* . binding) ...) default k) - (syntax-error "Illegal labels in" ((label* . binding) ...) - "Legal labels are" (label ...))))) - ((order "emit" (label ...) bindings default k) - (meta - `((label . (meta ,(syntax-lookup label - bindings - if-free= - default))) - ...) - k)))) - - -;============================================================================================ -; Simple generic functions: - -(define-syntax define-generic - (syntax-rules () - ((define-generic (name arg ...)) - (define-generic (name arg ...) - (lambda (arg ...) (error "Inapplicable method:" 'name - "Arguments:" (show arg) ... )))) - ((define-generic (name arg ...) proc) - (define name (make-generic (arg ...) proc))))) - -(define-syntax define-method - (syntax-rules () - ((define-method (generic (arg pred?) ...) . body) - (define-method generic (pred? ...) (arg ...) (lambda (arg ...) . body))) - ((define-method generic (pred? ...) (arg ...) procedure) - (let ((next ((generic) 'get-proc)) - (proc procedure)) - (((generic) 'set-proc) - (lambda (arg ...) - (if (and (pred? arg) ...) - (proc arg ...) - (next arg ...)))))))) - -(define-syntax make-generic - (syntax-rules () - ((make-generic (arg arg+ ...) default-proc) - (let ((proc default-proc)) - (case-lambda - ((arg arg+ ...) - (proc arg arg+ ...)) - (() - (lambda (msg) - (case msg - ((get-proc) proc) - ((set-proc) (lambda (new) - (set! proc new))))))))))) - -(define-generic (show x) - (lambda (x) x)) - -(define (any? x) #t) - - -;============================================================================================ -; Syntax utilities: - -(define-syntax syntax-error - (syntax-rules ())) - -(define-syntax syntax-apply - (syntax-rules () - ((syntax-apply (f . args) exp ...) - (f exp ... . args)))) - -(define-syntax syntax-cons - (syntax-rules () - ((syntax-cons x rest k) - (syntax-apply k (x . rest))))) - -(define-syntax syntax-cons-after - (syntax-rules () - ((syntax-cons-after rest x k) - (syntax-apply k (x . rest))))) - -(define-syntax if-empty? - (syntax-rules () - ((if-empty? () sk fk) sk) - ((if-empty? (h . t) sk fk) fk))) - -(define-syntax add-temporaries - (syntax-rules () - ((add-temporaries lst k) (add-temporaries lst () k)) - ((add-temporaries () lst-temps k) (syntax-apply k lst-temps)) - ((add-temporaries (h . t) (done ...) k) (add-temporaries t (done ... (h temp)) k)))) - -(define-syntax if-free= - (syntax-rules () - ((if-free= x y kt kf) - (let-syntax - ((test (syntax-rules (x) - ((test x kt* kf*) kt*) - ((test z kt* kf*) kf*)))) - (test y kt kf))))) - -(define-syntax top:if-free= - (syntax-rules () - ((top:if-free= x y kt kf) - (begin - (define-syntax if-free=:test - (syntax-rules (x) - ((if-free=:test x kt* kf*) kt*) - ((if-free=:test z kt* kf*) kf*))) - (if-free=:test y kt kf))))) - -(define-syntax meta - (syntax-rules (meta quasiquote unquote) - ((meta `(meta ,(function argument ...)) k) - (meta `(argument ...) (syntax-apply-to function k))) - ((meta `(a . b) k) - (meta `a (descend-right b k))) - ((meta `whatever k) (syntax-apply k whatever)) - ((meta `arg) - (meta `arg (syntax-id))))) - -(define-syntax syntax-apply-to - (syntax-rules () - ((syntax-apply-to (argument ...) function k) - (function argument ... k)))) - -(define-syntax descend-right - (syntax-rules () - ((descend-right evaled b k) - (meta `b (syntax-cons-after evaled k))))) - -(define-syntax syntax-id - (syntax-rules () - ((syntax-id arg) arg))) - -(define-syntax remove-duplicates - (syntax-rules () - ((remove-duplicates lst compare? k) - (remove-duplicates lst () compare? k)) - ((remove-duplicates () done compare? k) - (syntax-apply k done)) - ((remove-duplicates (h . t) (d ...) compare? k) - (if-member? h (d ...) compare? - (remove-duplicates t (d ...) compare? k) - (remove-duplicates t (d ... h) compare? k))))) - -(define-syntax syntax-filter - (syntax-rules () - ((syntax-filter () (if-p? arg ...) k) - (syntax-apply k ())) - ((syntax-filter (h . t) (if-p? arg ...) k) - (if-p? h arg ... - (syntax-filter t (if-p? arg ...) (syntax-cons-after h k)) - (syntax-filter t (if-p? arg ...) k))))) - -(define-syntax if-member? - (syntax-rules () - ((if-member? x () compare? sk fk) - fk) - ((if-member? x (h . t) compare? sk fk) - (compare? x h - sk - (if-member? x t compare? sk fk))))) - -(define-syntax union - (syntax-rules () - ((union (x ...) ... compare? k) - (remove-duplicates (x ... ...) compare? k)))) - -(define-syntax intersection - (syntax-rules () - ((intersection list1 list2 compare? k) - (syntax-filter list1 (if-member? list2 compare?) k)))) - -(define-syntax remove-from - (syntax-rules () - ((remove-from list1 list2 compare? k) - (syntax-filter list1 (if-not-member? list2 compare?) k)))) - -(define-syntax if-not-member? - (syntax-rules () - ((if-not-member? x list compare? sk fk) - (if-member? x list compare? fk sk)))) - -(define-syntax generate-identifier - (syntax-rules () - ((generate-identifier k) (syntax-apply k generated-identifier)))) - -(define-syntax syntax-if - (syntax-rules () - ((syntax-if #f sk fk) fk) - ((syntax-if other sk fk) sk))) - -(define-syntax syntax-lookup - (syntax-rules () - ((syntax-lookup label () compare fail k) - (syntax-apply k fail)) - ((syntax-lookup label ((label* . value) . bindings) compare fail k) - (compare label label* - (syntax-apply k value) - (syntax-lookup label bindings compare fail k))))) -;;; array as-srfi-9-record -;;; 2001 Jussi Piitulainen - -;;; Untested. - -(define-record-type - array:srfi-9-record-type-descriptor - (array:make vec ind shp) - array:array? - (vec array:vector) - (ind array:index) - (shp array:shape)) -(define-library (srfi 60) - (export - ;; Bitwise Operations - logand - bitwise-and - logior - bitwise-ior - logxor - bitwise-xor - lognot - bitwise-not - bitwise-if - bitwise-merge - logtest - any-bits-set? - - ;; Integer Properties - logcount - bit-count - integer-length - log2-binary-factors - first-set-bit - - ;; Bit Within Word - logbit? - bit-set? - copy-bit - - ;; Field of Bits - bit-field - copy-bit-field - ash - arithmetic-shift - rotate-bit-field - reverse-bit-field - - ;; Bits as Booleans - integer->list - list->integer - booleans->integer - ) - (import (scheme base)) - (include "60.upstream.scm")) -;;; Copyright (C) Jussi Piitulainen (2001). All Rights Reserved. - -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to -;;; deal in the Software without restriction, including without limitation the -;;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -;;; sell copies of the Software, and to permit persons to whom the Software is -;;; furnished to do so, subject to the following conditions: - -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. - -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(define (array-ref a . xs) - (or (array:array? a) - (error "not an array")) - (let ((shape (array:shape a))) - (if (null? xs) - (array:check-indices "array-ref" xs shape) - (let ((x (car xs))) - (if (vector? x) - (array:check-index-vector "array-ref" x shape) - (if (integer? x) - (array:check-indices "array-ref" xs shape) - (if (array:array? x) - (array:check-index-actor "array-ref" x shape) - (error "not an index object")))))) - (vector-ref - (array:vector a) - (if (null? xs) - (vector-ref (array:index a) 0) - (let ((x (car xs))) - (if (vector? x) - (array:index/vector - (quotient (vector-length shape) 2) - (array:index a) - x) - (if (integer? x) - (array:vector-index (array:index a) xs) - (if (array:array? x) - (array:index/array - (quotient (vector-length shape) 2) - (array:index a) - (array:vector x) - (array:index x)) - (error "array-ref: bad index object"))))))))) - -(define (array-set! a x . xs) - (or (array:array? a) - (error "array-set!: not an array")) - (let ((shape (array:shape a))) - (if (null? xs) - (array:check-indices "array-set!" '() shape) - (if (vector? x) - (array:check-index-vector "array-set!" x shape) - (if (integer? x) - (array:check-indices.o "array-set!" (cons x xs) shape) - (if (array:array? x) - (array:check-index-actor "array-set!" x shape) - (error "not an index object"))))) - (if (null? xs) - (vector-set! (array:vector a) (vector-ref (array:index a) 0) x) - (if (vector? x) - (vector-set! (array:vector a) - (array:index/vector - (quotient (vector-length shape) 2) - (array:index a) - x) - (car xs)) - (if (integer? x) - (let ((v (array:vector a)) - (i (array:index a)) - (r (quotient (vector-length shape) 2))) - (do ((sum (* (vector-ref i 0) x) - (+ sum (* (vector-ref i k) (car ks)))) - (ks xs (cdr ks)) - (k 1 (+ k 1))) - ((= k r) - (vector-set! v (+ sum (vector-ref i k)) (car ks))))) - (if (array:array? x) - (vector-set! (array:vector a) - (array:index/array - (quotient (vector-length shape) 2) - (array:index a) - (array:vector x) - (array:index x)) - (car xs)) - (error (string-append - "array-set!: bad index object: " - (array:thing->string x))))))))) -(define-library (srfi 63) - (export - array? - equal? - array-rank - array-dimensions - make-array - make-shared-array - list->array - array->list - vector->array - array->vector - array-in-bounds? - array-ref - array-set! - a:floc128b - a:floc64b - a:floc32b - a:floc16b - a:flor128b - a:flor64b - a:flor32b - a:flor16b - a:fixz64b - a:fixz32b - a:fixz16b - a:fixz8b - a:fixn64b - a:fixn32b - a:fixn16b - a:fixn8b - a:bool - ) - (import (except (scheme base) equal?)) - (include "63.body.scm")) -;;; array -;;; 1997 - 2001 Jussi Piitulainen - -;;; --- Intro --- - -;;; This interface to arrays is based on Alan Bawden's array.scm of -;;; 1993 (earlier version in the Internet Repository and another -;;; version in SLIB). This is a complete rewrite, to be consistent -;;; with the rest of Scheme and to make arrays independent of lists. - -;;; Some modifications are due to discussion in srfi-25 mailing list. - -;;; (array? obj) -;;; (make-array shape [obj]) changed arguments -;;; (shape bound ...) new -;;; (array shape obj ...) new -;;; (array-rank array) changed name back -;;; (array-start array dimension) new -;;; (array-end array dimension) new -;;; (array-ref array k ...) -;;; (array-ref array index) new variant -;;; (array-set! array k ... obj) changed argument order -;;; (array-set! array index obj) new variant -;;; (share-array array shape proc) changed arguments - -;;; All other variables in this file have names in "array:". - -;;; Should there be a way to make arrays with initial values mapped -;;; from indices? Sure. The current "initial object" is lame. -;;; -;;; Removed (array-shape array) from here. There is a new version -;;; in arlib though. - -;;; --- Representation type dependencies --- - -;;; The mapping from array indices to the index to the underlying vector -;;; is whatever array:optimize returns. The file "opt" provides three -;;; representations: -;;; -;;; mbda) mapping is a procedure that allows an optional argument -;;; tter) mapping is two procedures that takes exactly the indices -;;; ctor) mapping is a vector of a constant term and coefficients -;;; -;;; Choose one in "opt" to make the optimizer. Then choose the matching -;;; implementation of array-ref and array-set!. -;;; -;;; These should be made macros to inline them. Or have a good compiler -;;; and plant the package as a module. - -;;; 1. Pick an optimizer. -;;; 2. Pick matching index representation. -;;; 3. Pick a record implementation; as-procedure is generic; syntax inlines. -;;; 3. This file is otherwise portable. - -;;; --- Portable R5RS (R4RS and multiple values) --- - -;;; (array? obj) -;;; returns #t if `obj' is an array and #t or #f otherwise. - -(define (array? obj) - (array:array? obj)) - -;;; (make-array shape) -;;; (make-array shape obj) -;;; makes array of `shape' with each cell containing `obj' initially. - -(define (make-array shape . rest) - (or (array:good-shape? shape) - (error "make-array: shape is not a shape")) - (apply array:make-array shape rest)) - -(define (array:make-array shape . rest) - (let ((size (array:size shape))) - (array:make - (if (pair? rest) - (apply (lambda (o) (make-vector size o)) rest) - (make-vector size)) - (if (= size 0) - (array:optimize-empty - (vector-ref (array:shape shape) 1)) - (array:optimize - (array:make-index shape) - (vector-ref (array:shape shape) 1))) - (array:shape->vector shape)))) - -;;; (shape bound ...) -;;; makes a shape. Bounds must be an even number of exact, pairwise -;;; non-decreasing integers. Note that any such array can be a shape. - -(define (shape . bounds) - (let ((v (list->vector bounds))) - (or (even? (vector-length v)) - (error (string-append "shape: uneven number of bounds: " - (array:list->string bounds)))) - (let ((shp (array:make - v - (if (pair? bounds) - (array:shape-index) - (array:empty-shape-index)) - (vector 0 (quotient (vector-length v) 2) - 0 2)))) - (or (array:good-shape? shp) - (error (string-append "shape: bounds are not pairwise " - "non-decreasing exact integers: " - (array:list->string bounds)))) - shp))) - -;;; (array shape obj ...) -;;; is analogous to `vector'. - -(define (array shape . elts) - (or (array:good-shape? shape) - (error (string-append "array: shape " (array:thing->string shape) - " is not a shape"))) - (let ((size (array:size shape))) - (let ((vector (list->vector elts))) - (or (= (vector-length vector) size) - (error (string-append "array: an array of shape " - (array:shape-vector->string - (array:vector shape)) - " has " - (number->string size) - " elements but got " - (number->string (vector-length vector)) - " values: " - (array:list->string elts)))) - (array:make - vector - (if (= size 0) - (array:optimize-empty - (vector-ref (array:shape shape) 1)) - (array:optimize - (array:make-index shape) - (vector-ref (array:shape shape) 1))) - (array:shape->vector shape))))) - -;;; (array-rank array) -;;; returns the number of dimensions of `array'. - -(define (array-rank array) - (quotient (vector-length (array:shape array)) 2)) - -;;; (array-start array k) -;;; returns the lower bound index of array along dimension k. This is -;;; the least valid index along that dimension if the dimension is not -;;; empty. - -(define (array-start array d) - (vector-ref (array:shape array) (+ d d))) - -;;; (array-end array k) -;;; returns the upper bound index of array along dimension k. This is -;;; not a valid index. If the dimension is empty, this is the same as -;;; the lower bound along it. - -(define (array-end array d) - (vector-ref (array:shape array) (+ d d 1))) - -;;; (share-array array shape proc) -;;; makes an array that shares elements of `array' at shape `shape'. -;;; The arguments to `proc' are indices of the result. The values of -;;; `proc' are indices of `array'. - -;;; Todo: in the error message, should recognise the mapping and show it. - -(define (share-array array subshape f) - (or (array:good-shape? subshape) - (error (string-append "share-array: shape " - (array:thing->string subshape) - " is not a shape"))) - (let ((subsize (array:size subshape))) - (or (array:good-share? subshape subsize f (array:shape array)) - (error (string-append "share-array: subshape " - (array:shape-vector->string - (array:vector subshape)) - " does not map into supershape " - (array:shape-vector->string - (array:shape array)) - " under mapping " - (array:map->string - f - (vector-ref (array:shape subshape) 1))))) - (let ((g (array:index array))) - (array:make - (array:vector array) - (if (= subsize 0) - (array:optimize-empty - (vector-ref (array:shape subshape) 1)) - (array:optimize - (lambda ks - (call-with-values - (lambda () (apply f ks)) - (lambda ks (array:vector-index g ks)))) - (vector-ref (array:shape subshape) 1))) - (array:shape->vector subshape))))) - -;;; --- Hrmph --- - -;;; (array:share/index! ...) -;;; reuses a user supplied index object when recognising the -;;; mapping. The mind balks at the very nasty side effect that -;;; exposes the implementation. So this is not in the spec. -;;; But letting index objects in at all creates a pressure -;;; to go the whole hog. Arf. - -;;; Use array:optimize-empty for an empty array to get a -;;; clearly invalid vector index. - -;;; Surely it's perverse to use an actor for index here? But -;;; the possibility is provided for completeness. - -(define (array:share/index! array subshape proc index) - (array:make - (array:vector array) - (if (= (array:size subshape) 0) - (array:optimize-empty - (quotient (vector-length (array:shape array)) 2)) - ((if (vector? index) - array:optimize/vector - array:optimize/actor) - (lambda (subindex) - (let ((superindex (proc subindex))) - (if (vector? superindex) - (array:index/vector - (quotient (vector-length (array:shape array)) 2) - (array:index array) - superindex) - (array:index/array - (quotient (vector-length (array:shape array)) 2) - (array:index array) - (array:vector superindex) - (array:index superindex))))) - index)) - (array:shape->vector subshape))) - -(define (array:optimize/vector f v) - (let ((r (vector-length v))) - (do ((k 0 (+ k 1))) - ((= k r)) - (vector-set! v k 0)) - (let ((n0 (f v)) - (cs (make-vector (+ r 1))) - (apply (array:applier-to-vector (+ r 1)))) - (vector-set! cs 0 n0) - (let wok ((k 0)) - (if (< k r) - (let ((k1 (+ k 1))) - (vector-set! v k 1) - (let ((nk (- (f v) n0))) - (vector-set! v k 0) - (vector-set! cs k1 nk) - (wok k1))))) - (apply (array:maker r) cs)))) - -(define (array:optimize/actor f a) - (let ((r (array-end a 0)) - (v (array:vector a)) - (i (array:index a))) - (do ((k 0 (+ k 1))) - ((= k r)) - (vector-set! v (array:actor-index i k) 0)) - (let ((n0 (f a)) - (cs (make-vector (+ r 1))) - (apply (array:applier-to-vector (+ r 1)))) - (vector-set! cs 0 n0) - (let wok ((k 0)) - (if (< k r) - (let ((k1 (+ k 1)) - (t (array:actor-index i k))) - (vector-set! v t 1) - (let ((nk (- (f a) n0))) - (vector-set! v t 0) - (vector-set! cs k1 nk) - (wok k1))))) - (apply (array:maker r) cs)))) - -;;; --- Internals --- - -(define (array:shape->vector shape) - (let ((idx (array:index shape)) - (shv (array:vector shape)) - (rnk (vector-ref (array:shape shape) 1))) - (let ((vec (make-vector (* rnk 2)))) - (do ((k 0 (+ k 1))) - ((= k rnk) - vec) - (vector-set! vec (+ k k) - (vector-ref shv (array:shape-vector-index idx k 0))) - (vector-set! vec (+ k k 1) - (vector-ref shv (array:shape-vector-index idx k 1))))))) - -;;; (array:size shape) -;;; returns the number of elements in arrays of shape `shape'. - -(define (array:size shape) - (let ((idx (array:index shape)) - (shv (array:vector shape)) - (rnk (vector-ref (array:shape shape) 1))) - (do ((k 0 (+ k 1)) - (s 1 (* s - (- (vector-ref shv (array:shape-vector-index idx k 1)) - (vector-ref shv (array:shape-vector-index idx k 0)))))) - ((= k rnk) s)))) - -;;; (array:make-index shape) -;;; returns an index function for arrays of shape `shape'. This is a -;;; runtime composition of several variable arity procedures, to be -;;; passed to array:optimize for recognition as an affine function of -;;; as many variables as there are dimensions in arrays of this shape. - -(define (array:make-index shape) - (let ((idx (array:index shape)) - (shv (array:vector shape)) - (rnk (vector-ref (array:shape shape) 1))) - (do ((f (lambda () 0) - (lambda (k . ks) - (+ (* s (- k (vector-ref - shv - (array:shape-vector-index idx (- j 1) 0)))) - (apply f ks)))) - (s 1 (* s (- (vector-ref - shv - (array:shape-vector-index idx (- j 1) 1)) - (vector-ref - shv - (array:shape-vector-index idx (- j 1) 0))))) - (j rnk (- j 1))) - ((= j 0) - f)))) - - -;;; --- Error checking --- - -;;; (array:good-shape? shape) -;;; returns true if `shape' is an array of the right shape and its -;;; elements are exact integers that pairwise bound intervals `[lo..hi)´. - -(define (array:good-shape? shape) - (and (array:array? shape) - (let ((u (array:shape shape)) - (v (array:vector shape)) - (x (array:index shape))) - (and (= (vector-length u) 4) - (= (vector-ref u 0) 0) - (= (vector-ref u 2) 0) - (= (vector-ref u 3) 2)) - (let ((p (vector-ref u 1))) - (do ((k 0 (+ k 1)) - (true #t (let ((lo (vector-ref - v - (array:shape-vector-index x k 0))) - (hi (vector-ref - v - (array:shape-vector-index x k 1)))) - (and true - (integer? lo) - (exact? lo) - (integer? hi) - (exact? hi) - (<= lo hi))))) - ((= k p) true)))))) - -;;; (array:good-share? subv subsize mapping superv) -;;; returns true if the extreme indices in the subshape vector map -;;; into the bounds in the supershape vector. - -;;; If some interval in `subv' is empty, then `subv' is empty and its -;;; image under `f' is empty and it is trivially alright. One must -;;; not call `f', though. - -(define (array:good-share? subshape subsize f super) - (or (zero? subsize) - (letrec - ((sub (array:vector subshape)) - (dex (array:index subshape)) - (ck (lambda (k ks) - (if (zero? k) - (call-with-values - (lambda () (apply f ks)) - (lambda qs (array:good-indices? qs super))) - (and (ck (- k 1) - (cons (vector-ref - sub - (array:shape-vector-index - dex - (- k 1) - 0)) - ks)) - (ck (- k 1) - (cons (- (vector-ref - sub - (array:shape-vector-index - dex - (- k 1) - 1)) - 1) - ks))))))) - (let ((rnk (vector-ref (array:shape subshape) 1))) - (or (array:unchecked-share-depth? rnk) - (ck rnk '())))))) - -;;; Check good-share on 10 dimensions at most. The trouble is, -;;; the cost of this check is exponential in the number of dimensions. - -(define (array:unchecked-share-depth? rank) - (if (> rank 10) - (begin - (display `(warning unchecked depth in share - ,rank subdimensions)) - (newline) - #t) - #f)) - -;;; (array:check-indices caller indices shape-vector) -;;; (array:check-indices.o caller indices shape-vector) -;;; (array:check-index-vector caller index-vector shape-vector) -;;; return if the index is in bounds, else signal error. -;;; -;;; Shape-vector is the internal representation, with -;;; b and e for dimension k at 2k and 2k + 1. - -(define (array:check-indices who ks shv) - (or (array:good-indices? ks shv) - (error (array:not-in who ks shv)))) - -(define (array:check-indices.o who ks shv) - (or (array:good-indices.o? ks shv) - (error (array:not-in who (reverse (cdr (reverse ks))) shv)))) - -(define (array:check-index-vector who ks shv) - (or (array:good-index-vector? ks shv) - (error (array:not-in who (vector->list ks) shv)))) - -(define (array:check-index-actor who ks shv) - (let ((shape (array:shape ks))) - (or (and (= (vector-length shape) 2) - (= (vector-ref shape 0) 0)) - (error "not an actor")) - (or (array:good-index-actor? - (vector-ref shape 1) - (array:vector ks) - (array:index ks) - shv) - (array:not-in who (do ((k (vector-ref shape 1) (- k 1)) - (m '() (cons (vector-ref - (array:vector ks) - (array:actor-index - (array:index ks) - (- k 1))) - m))) - ((= k 0) m)) - shv)))) - -(define (array:good-indices? ks shv) - (let ((d2 (vector-length shv))) - (do ((kp ks (if (pair? kp) - (cdr kp))) - (k 0 (+ k 2)) - (true #t (and true (pair? kp) - (array:good-index? (car kp) shv k)))) - ((= k d2) - (and true (null? kp)))))) - -(define (array:good-indices.o? ks.o shv) - (let ((d2 (vector-length shv))) - (do ((kp ks.o (if (pair? kp) - (cdr kp))) - (k 0 (+ k 2)) - (true #t (and true (pair? kp) - (array:good-index? (car kp) shv k)))) - ((= k d2) - (and true (pair? kp) (null? (cdr kp))))))) - -(define (array:good-index-vector? ks shv) - (let ((r2 (vector-length shv))) - (and (= (* 2 (vector-length ks)) r2) - (do ((j 0 (+ j 1)) - (k 0 (+ k 2)) - (true #t (and true - (array:good-index? (vector-ref ks j) shv k)))) - ((= k r2) true))))) - -(define (array:good-index-actor? r v i shv) - (and (= (* 2 r) (vector-length shv)) - (do ((j 0 (+ j 1)) - (k 0 (+ k 2)) - (true #t (and true - (array:good-index? (vector-ref - v - (array:actor-index i j)) - shv - k)))) - ((= j r) true)))) - -;;; (array:good-index? index shape-vector 2d) -;;; returns true if index is within bounds for dimension 2d/2. - -(define (array:good-index? w shv k) - (and (integer? w) - (exact? w) - (<= (vector-ref shv k) w) - (< w (vector-ref shv (+ k 1))))) - -(define (array:not-in who ks shv) - (let ((index (array:list->string ks)) - (bounds (array:shape-vector->string shv))) - (error (string-append who - ": index " index - " not in bounds " bounds)))) - -(define (array:list->string ks) - (do ((index "" (string-append index (array:thing->string (car ks)) " ")) - (ks ks (cdr ks))) - ((null? ks) index))) - -(define (array:shape-vector->string shv) - (do ((bounds "" (string-append bounds - "[" - (number->string (vector-ref shv t)) - ".." - (number->string (vector-ref shv (+ t 1))) - ")" - " ")) - (t 0 (+ t 2))) - ((= t (vector-length shv)) bounds))) - -(define (array:thing->string thing) - (cond - ((number? thing) (number->string thing)) - ((symbol? thing) (string-append "#" (symbol->string thing))) - ((char? thing) "#") - ((string? thing) "#") - ((list? thing) (string-append "#" (number->string (length thing)) - "")) - - ((pair? thing) "#") - ((array? thing) "#") - ((vector? thing) (string-append "#" (number->string - (vector-length thing)) - "")) - ((procedure? thing) "#") - (else - (case thing - ((()) "()") - ((#t) "#t") - ((#f) "#f") - (else - "#"))))) - -;;; And to grok an affine map, vector->vector type. Column k of arr -;;; will contain coefficients n0 ... nm of 1 k1 ... km for kth value. -;;; -;;; These are for the error message when share fails. - -(define (array:index-ref ind k) - (if (vector? ind) - (vector-ref ind k) - (vector-ref - (array:vector ind) - (array:actor-index (array:index ind) k)))) - -(define (array:index-set! ind k o) - (if (vector? ind) - (vector-set! ind k o) - (vector-set! - (array:vector ind) - (array:actor-index (array:index ind) k) - o))) - -(define (array:index-length ind) - (if (vector? ind) - (vector-length ind) - (vector-ref (array:shape ind) 1))) - -(define (array:map->string proc r) - (let* ((m (array:grok/arguments proc r)) - (s (vector-ref (array:shape m) 3))) - (do ((i "" (string-append i c "k" (number->string k))) - (c "" ", ") - (k 1 (+ k 1))) - ((< r k) - (do ((o "" (string-append o c (array:map-column->string m r k))) - (c "" ", ") - (k 0 (+ k 1))) - ((= k s) - (string-append i " => " o))))))) - -(define (array:map-column->string m r k) - (let ((v (array:vector m)) - (i (array:index m))) - (let ((n0 (vector-ref v (array:vector-index i (list 0 k))))) - (let wok ((j 1) - (e (if (= n0 0) "" (number->string n0)))) - (if (<= j r) - (let ((nj (vector-ref v (array:vector-index i (list j k))))) - (if (= nj 0) - (wok (+ j 1) e) - (let* ((nj (if (= nj 1) "" - (if (= nj -1) "-" - (string-append (number->string nj) - " ")))) - (njkj (string-append nj "k" (number->string j)))) - (if (string=? e "") - (wok (+ j 1) njkj) - (wok (+ j 1) (string-append e " + " njkj)))))) - (if (string=? e "") "0" e)))))) - -(define (array:grok/arguments proc r) - (array:grok/index! - (lambda (vec) - (call-with-values - (lambda () - (array:apply-to-vector r proc vec)) - vector)) - (make-vector r))) - -(define (array:grok/index! proc in) - (let ((m (array:index-length in))) - (do ((k 0 (+ k 1))) - ((= k m)) - (array:index-set! in k 0)) - (let* ((n0 (proc in)) - (n (array:index-length n0))) - (let ((arr (make-array (shape 0 (+ m 1) 0 n)))) ; (*) - (do ((k 0 (+ k 1))) - ((= k n)) - (array-set! arr 0 k (array:index-ref n0 k))) ; (**) - (do ((j 0 (+ j 1))) - ((= j m)) - (array:index-set! in j 1) - (let ((nj (proc in))) - (array:index-set! in j 0) - (do ((k 0 (+ k 1))) - ((= k n)) - (array-set! arr (+ j 1) k (- (array:index-ref nj k) ; (**) - (array:index-ref n0 k)))))) - arr)))) -;; (*) Should not use `make-array' and `shape' here -;; (**) Should not use `array-set!' here -;; Should use something internal to the library instead: either lower -;; level code (preferable but complex) or alternative names to these same. -;; Copyright (C) John David Stone (1999). All Rights Reserved. - -;; Made an R7RS library by Taylan Ulrich Bayırlı/Kammer, Copyright (C) 2014. - -;; Permission is hereby granted, free of charge, to any person obtaining a copy -;; of this software and associated documentation files (the "Software"), to deal -;; in the Software without restriction, including without limitation the rights -;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;; copies of the Software, and to permit persons to whom the Software is -;; furnished to do so, subject to the following conditions: - -;; The above copyright notice and this permission notice shall be included in -;; all copies or substantial portions of the Software. - -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -;; SOFTWARE. - -(define-library (srfi 8) - (export receive) - (import (scheme base)) - (begin - (define-syntax receive - (syntax-rules () - ((receive formals expression body ...) - (call-with-values (lambda () expression) - (lambda formals body ...))))))) -;;; Copyright (C) Jussi Piitulainen (2001). All Rights Reserved. - -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to -;;; deal in the Software without restriction, including without limitation the -;;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -;;; sell copies of the Software, and to permit persons to whom the Software is -;;; furnished to do so, subject to the following conditions: - -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. - -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(begin - (define array:opt-args '(ctor (4))) - (define (array:optimize f r) - (case r - ((0) (let ((n0 (f))) (array:0 n0))) - ((1) (let ((n0 (f 0))) (array:1 n0 (- (f 1) n0)))) - ((2) - (let ((n0 (f 0 0))) - (array:2 n0 (- (f 1 0) n0) (- (f 0 1) n0)))) - ((3) - (let ((n0 (f 0 0 0))) - (array:3 - n0 - (- (f 1 0 0) n0) - (- (f 0 1 0) n0) - (- (f 0 0 1) n0)))) - (else - (let ((v - (do ((k 0 (+ k 1)) (v '() (cons 0 v))) - ((= k r) v)))) - (let ((n0 (apply f v))) - (apply - array:n - n0 - (array:coefficients f n0 v v))))))) - (define (array:optimize-empty r) - (let ((x (make-vector (+ r 1) 0))) - (vector-set! x r -1) - x)) - (define (array:coefficients f n0 vs vp) - (case vp - ((()) '()) - (else - (set-car! vp 1) - (let ((n (- (apply f vs) n0))) - (set-car! vp 0) - (cons n (array:coefficients f n0 vs (cdr vp))))))) - (define (array:vector-index x ks) - (do ((sum 0 (+ sum (* (vector-ref x k) (car ks)))) - (ks ks (cdr ks)) - (k 0 (+ k 1))) - ((null? ks) (+ sum (vector-ref x k))))) - (define (array:shape-index) '#(2 1 0)) - (define (array:empty-shape-index) '#(0 0 -1)) - (define (array:shape-vector-index x r k) - (+ - (* (vector-ref x 0) r) - (* (vector-ref x 1) k) - (vector-ref x 2))) - (define (array:actor-index x k) - (+ (* (vector-ref x 0) k) (vector-ref x 1))) - (define (array:0 n0) (vector n0)) - (define (array:1 n0 n1) (vector n1 n0)) - (define (array:2 n0 n1 n2) (vector n1 n2 n0)) - (define (array:3 n0 n1 n2 n3) (vector n1 n2 n3 n0)) - (define (array:n n0 n1 n2 n3 n4 . ns) - (apply vector n1 n2 n3 n4 (append ns (list n0)))) - (define (array:maker r) - (case r - ((0) array:0) - ((1) array:1) - ((2) array:2) - ((3) array:3) - (else array:n))) - (define array:indexer/vector - (let ((em - (vector - (lambda (x i) (+ (vector-ref x 0))) - (lambda (x i) - (+ - (* (vector-ref x 0) (vector-ref i 0)) - (vector-ref x 1))) - (lambda (x i) - (+ - (* (vector-ref x 0) (vector-ref i 0)) - (* (vector-ref x 1) (vector-ref i 1)) - (vector-ref x 2))) - (lambda (x i) - (+ - (* (vector-ref x 0) (vector-ref i 0)) - (* (vector-ref x 1) (vector-ref i 1)) - (* (vector-ref x 2) (vector-ref i 2)) - (vector-ref x 3))) - (lambda (x i) - (+ - (* (vector-ref x 0) (vector-ref i 0)) - (* (vector-ref x 1) (vector-ref i 1)) - (* (vector-ref x 2) (vector-ref i 2)) - (* (vector-ref x 3) (vector-ref i 3)) - (vector-ref x 4))) - (lambda (x i) - (+ - (* (vector-ref x 0) (vector-ref i 0)) - (* (vector-ref x 1) (vector-ref i 1)) - (* (vector-ref x 2) (vector-ref i 2)) - (* (vector-ref x 3) (vector-ref i 3)) - (* (vector-ref x 4) (vector-ref i 4)) - (vector-ref x 5))) - (lambda (x i) - (+ - (* (vector-ref x 0) (vector-ref i 0)) - (* (vector-ref x 1) (vector-ref i 1)) - (* (vector-ref x 2) (vector-ref i 2)) - (* (vector-ref x 3) (vector-ref i 3)) - (* (vector-ref x 4) (vector-ref i 4)) - (* (vector-ref x 5) (vector-ref i 5)) - (vector-ref x 6))) - (lambda (x i) - (+ - (* (vector-ref x 0) (vector-ref i 0)) - (* (vector-ref x 1) (vector-ref i 1)) - (* (vector-ref x 2) (vector-ref i 2)) - (* (vector-ref x 3) (vector-ref i 3)) - (* (vector-ref x 4) (vector-ref i 4)) - (* (vector-ref x 5) (vector-ref i 5)) - (* (vector-ref x 6) (vector-ref i 6)) - (vector-ref x 7))) - (lambda (x i) - (+ - (* (vector-ref x 0) (vector-ref i 0)) - (* (vector-ref x 1) (vector-ref i 1)) - (* (vector-ref x 2) (vector-ref i 2)) - (* (vector-ref x 3) (vector-ref i 3)) - (* (vector-ref x 4) (vector-ref i 4)) - (* (vector-ref x 5) (vector-ref i 5)) - (* (vector-ref x 6) (vector-ref i 6)) - (* (vector-ref x 7) (vector-ref i 7)) - (vector-ref x 8))) - (lambda (x i) - (+ - (* (vector-ref x 0) (vector-ref i 0)) - (* (vector-ref x 1) (vector-ref i 1)) - (* (vector-ref x 2) (vector-ref i 2)) - (* (vector-ref x 3) (vector-ref i 3)) - (* (vector-ref x 4) (vector-ref i 4)) - (* (vector-ref x 5) (vector-ref i 5)) - (* (vector-ref x 6) (vector-ref i 6)) - (* (vector-ref x 7) (vector-ref i 7)) - (* (vector-ref x 8) (vector-ref i 8)) - (vector-ref x 9))))) - (it - (lambda (w) - (lambda (x i) - (+ - (* (vector-ref x 0) (vector-ref i 0)) - (* (vector-ref x 1) (vector-ref i 1)) - (* (vector-ref x 2) (vector-ref i 2)) - (* (vector-ref x 3) (vector-ref i 3)) - (* (vector-ref x 4) (vector-ref i 4)) - (* (vector-ref x 5) (vector-ref i 5)) - (* (vector-ref x 6) (vector-ref i 6)) - (* (vector-ref x 7) (vector-ref i 7)) - (* (vector-ref x 8) (vector-ref i 8)) - (* (vector-ref x 9) (vector-ref i 9)) - (do ((xi - 0 - (+ - (* (vector-ref x u) (vector-ref i u)) - xi)) - (u (- w 1) (- u 1))) - ((< u 10) xi)) - (vector-ref x w)))))) - (lambda (r) (if (< r 10) (vector-ref em r) (it r))))) - (define array:indexer/array - (let ((em - (vector - (lambda (x v i) (+ (vector-ref x 0))) - (lambda (x v i) - (+ - (* - (vector-ref x 0) - (vector-ref v (array:actor-index i 0))) - (vector-ref x 1))) - (lambda (x v i) - (+ - (* - (vector-ref x 0) - (vector-ref v (array:actor-index i 0))) - (* - (vector-ref x 1) - (vector-ref v (array:actor-index i 1))) - (vector-ref x 2))) - (lambda (x v i) - (+ - (* - (vector-ref x 0) - (vector-ref v (array:actor-index i 0))) - (* - (vector-ref x 1) - (vector-ref v (array:actor-index i 1))) - (* - (vector-ref x 2) - (vector-ref v (array:actor-index i 2))) - (vector-ref x 3))) - (lambda (x v i) - (+ - (* - (vector-ref x 0) - (vector-ref v (array:actor-index i 0))) - (* - (vector-ref x 1) - (vector-ref v (array:actor-index i 1))) - (* - (vector-ref x 2) - (vector-ref v (array:actor-index i 2))) - (* - (vector-ref x 3) - (vector-ref v (array:actor-index i 3))) - (vector-ref x 4))) - (lambda (x v i) - (+ - (* - (vector-ref x 0) - (vector-ref v (array:actor-index i 0))) - (* - (vector-ref x 1) - (vector-ref v (array:actor-index i 1))) - (* - (vector-ref x 2) - (vector-ref v (array:actor-index i 2))) - (* - (vector-ref x 3) - (vector-ref v (array:actor-index i 3))) - (* - (vector-ref x 4) - (vector-ref v (array:actor-index i 4))) - (vector-ref x 5))) - (lambda (x v i) - (+ - (* - (vector-ref x 0) - (vector-ref v (array:actor-index i 0))) - (* - (vector-ref x 1) - (vector-ref v (array:actor-index i 1))) - (* - (vector-ref x 2) - (vector-ref v (array:actor-index i 2))) - (* - (vector-ref x 3) - (vector-ref v (array:actor-index i 3))) - (* - (vector-ref x 4) - (vector-ref v (array:actor-index i 4))) - (* - (vector-ref x 5) - (vector-ref v (array:actor-index i 5))) - (vector-ref x 6))) - (lambda (x v i) - (+ - (* - (vector-ref x 0) - (vector-ref v (array:actor-index i 0))) - (* - (vector-ref x 1) - (vector-ref v (array:actor-index i 1))) - (* - (vector-ref x 2) - (vector-ref v (array:actor-index i 2))) - (* - (vector-ref x 3) - (vector-ref v (array:actor-index i 3))) - (* - (vector-ref x 4) - (vector-ref v (array:actor-index i 4))) - (* - (vector-ref x 5) - (vector-ref v (array:actor-index i 5))) - (* - (vector-ref x 6) - (vector-ref v (array:actor-index i 6))) - (vector-ref x 7))) - (lambda (x v i) - (+ - (* - (vector-ref x 0) - (vector-ref v (array:actor-index i 0))) - (* - (vector-ref x 1) - (vector-ref v (array:actor-index i 1))) - (* - (vector-ref x 2) - (vector-ref v (array:actor-index i 2))) - (* - (vector-ref x 3) - (vector-ref v (array:actor-index i 3))) - (* - (vector-ref x 4) - (vector-ref v (array:actor-index i 4))) - (* - (vector-ref x 5) - (vector-ref v (array:actor-index i 5))) - (* - (vector-ref x 6) - (vector-ref v (array:actor-index i 6))) - (* - (vector-ref x 7) - (vector-ref v (array:actor-index i 7))) - (vector-ref x 8))) - (lambda (x v i) - (+ - (* - (vector-ref x 0) - (vector-ref v (array:actor-index i 0))) - (* - (vector-ref x 1) - (vector-ref v (array:actor-index i 1))) - (* - (vector-ref x 2) - (vector-ref v (array:actor-index i 2))) - (* - (vector-ref x 3) - (vector-ref v (array:actor-index i 3))) - (* - (vector-ref x 4) - (vector-ref v (array:actor-index i 4))) - (* - (vector-ref x 5) - (vector-ref v (array:actor-index i 5))) - (* - (vector-ref x 6) - (vector-ref v (array:actor-index i 6))) - (* - (vector-ref x 7) - (vector-ref v (array:actor-index i 7))) - (* - (vector-ref x 8) - (vector-ref v (array:actor-index i 8))) - (vector-ref x 9))))) - (it - (lambda (w) - (lambda (x v i) - (+ - (* - (vector-ref x 0) - (vector-ref v (array:actor-index i 0))) - (* - (vector-ref x 1) - (vector-ref v (array:actor-index i 1))) - (* - (vector-ref x 2) - (vector-ref v (array:actor-index i 2))) - (* - (vector-ref x 3) - (vector-ref v (array:actor-index i 3))) - (* - (vector-ref x 4) - (vector-ref v (array:actor-index i 4))) - (* - (vector-ref x 5) - (vector-ref v (array:actor-index i 5))) - (* - (vector-ref x 6) - (vector-ref v (array:actor-index i 6))) - (* - (vector-ref x 7) - (vector-ref v (array:actor-index i 7))) - (* - (vector-ref x 8) - (vector-ref v (array:actor-index i 8))) - (* - (vector-ref x 9) - (vector-ref v (array:actor-index i 9))) - (do ((xi - 0 - (+ - (* - (vector-ref x u) - (vector-ref - v - (array:actor-index i u))) - xi)) - (u (- w 1) (- u 1))) - ((< u 10) xi)) - (vector-ref x w)))))) - (lambda (r) (if (< r 10) (vector-ref em r) (it r))))) - (define array:applier-to-vector - (let ((em - (vector - (lambda (p v) (p)) - (lambda (p v) (p (vector-ref v 0))) - (lambda (p v) - (p (vector-ref v 0) (vector-ref v 1))) - (lambda (p v) - (p - (vector-ref v 0) - (vector-ref v 1) - (vector-ref v 2))) - (lambda (p v) - (p - (vector-ref v 0) - (vector-ref v 1) - (vector-ref v 2) - (vector-ref v 3))) - (lambda (p v) - (p - (vector-ref v 0) - (vector-ref v 1) - (vector-ref v 2) - (vector-ref v 3) - (vector-ref v 4))) - (lambda (p v) - (p - (vector-ref v 0) - (vector-ref v 1) - (vector-ref v 2) - (vector-ref v 3) - (vector-ref v 4) - (vector-ref v 5))) - (lambda (p v) - (p - (vector-ref v 0) - (vector-ref v 1) - (vector-ref v 2) - (vector-ref v 3) - (vector-ref v 4) - (vector-ref v 5) - (vector-ref v 6))) - (lambda (p v) - (p - (vector-ref v 0) - (vector-ref v 1) - (vector-ref v 2) - (vector-ref v 3) - (vector-ref v 4) - (vector-ref v 5) - (vector-ref v 6) - (vector-ref v 7))) - (lambda (p v) - (p - (vector-ref v 0) - (vector-ref v 1) - (vector-ref v 2) - (vector-ref v 3) - (vector-ref v 4) - (vector-ref v 5) - (vector-ref v 6) - (vector-ref v 7) - (vector-ref v 8))))) - (it - (lambda (r) - (lambda (p v) - (apply - p - (vector-ref v 0) - (vector-ref v 1) - (vector-ref v 2) - (vector-ref v 3) - (vector-ref v 4) - (vector-ref v 5) - (vector-ref v 6) - (vector-ref v 7) - (vector-ref v 8) - (vector-ref v 9) - (do ((k r (- k 1)) - (r - '() - (cons (vector-ref v (- k 1)) r))) - ((= k 10) r))))))) - (lambda (r) (if (< r 10) (vector-ref em r) (it r))))) - (define array:applier-to-actor - (let ((em - (vector - (lambda (p a) (p)) - (lambda (p a) (p (array-ref a 0))) - (lambda (p a) - (p (array-ref a 0) (array-ref a 1))) - (lambda (p a) - (p - (array-ref a 0) - (array-ref a 1) - (array-ref a 2))) - (lambda (p a) - (p - (array-ref a 0) - (array-ref a 1) - (array-ref a 2) - (array-ref a 3))) - (lambda (p a) - (p - (array-ref a 0) - (array-ref a 1) - (array-ref a 2) - (array-ref a 3) - (array-ref a 4))) - (lambda (p a) - (p - (array-ref a 0) - (array-ref a 1) - (array-ref a 2) - (array-ref a 3) - (array-ref a 4) - (array-ref a 5))) - (lambda (p a) - (p - (array-ref a 0) - (array-ref a 1) - (array-ref a 2) - (array-ref a 3) - (array-ref a 4) - (array-ref a 5) - (array-ref a 6))) - (lambda (p a) - (p - (array-ref a 0) - (array-ref a 1) - (array-ref a 2) - (array-ref a 3) - (array-ref a 4) - (array-ref a 5) - (array-ref a 6) - (array-ref a 7))) - (lambda (p a) - (p - (array-ref a 0) - (array-ref a 1) - (array-ref a 2) - (array-ref a 3) - (array-ref a 4) - (array-ref a 5) - (array-ref a 6) - (array-ref a 7) - (array-ref a 8))))) - (it - (lambda (r) - (lambda (p a) - (apply - a - (array-ref a 0) - (array-ref a 1) - (array-ref a 2) - (array-ref a 3) - (array-ref a 4) - (array-ref a 5) - (array-ref a 6) - (array-ref a 7) - (array-ref a 8) - (array-ref a 9) - (do ((k r (- k 1)) - (r '() (cons (array-ref a (- k 1)) r))) - ((= k 10) r))))))) - (lambda (r) - "These are high level, hiding implementation at call site." - (if (< r 10) (vector-ref em r) (it r))))) - (define array:applier-to-backing-vector - (let ((em - (vector - (lambda (p ai av) (p)) - (lambda (p ai av) - (p (vector-ref av (array:actor-index ai 0)))) - (lambda (p ai av) - (p - (vector-ref av (array:actor-index ai 0)) - (vector-ref av (array:actor-index ai 1)))) - (lambda (p ai av) - (p - (vector-ref av (array:actor-index ai 0)) - (vector-ref av (array:actor-index ai 1)) - (vector-ref av (array:actor-index ai 2)))) - (lambda (p ai av) - (p - (vector-ref av (array:actor-index ai 0)) - (vector-ref av (array:actor-index ai 1)) - (vector-ref av (array:actor-index ai 2)) - (vector-ref av (array:actor-index ai 3)))) - (lambda (p ai av) - (p - (vector-ref av (array:actor-index ai 0)) - (vector-ref av (array:actor-index ai 1)) - (vector-ref av (array:actor-index ai 2)) - (vector-ref av (array:actor-index ai 3)) - (vector-ref av (array:actor-index ai 4)))) - (lambda (p ai av) - (p - (vector-ref av (array:actor-index ai 0)) - (vector-ref av (array:actor-index ai 1)) - (vector-ref av (array:actor-index ai 2)) - (vector-ref av (array:actor-index ai 3)) - (vector-ref av (array:actor-index ai 4)) - (vector-ref av (array:actor-index ai 5)))) - (lambda (p ai av) - (p - (vector-ref av (array:actor-index ai 0)) - (vector-ref av (array:actor-index ai 1)) - (vector-ref av (array:actor-index ai 2)) - (vector-ref av (array:actor-index ai 3)) - (vector-ref av (array:actor-index ai 4)) - (vector-ref av (array:actor-index ai 5)) - (vector-ref av (array:actor-index ai 6)))) - (lambda (p ai av) - (p - (vector-ref av (array:actor-index ai 0)) - (vector-ref av (array:actor-index ai 1)) - (vector-ref av (array:actor-index ai 2)) - (vector-ref av (array:actor-index ai 3)) - (vector-ref av (array:actor-index ai 4)) - (vector-ref av (array:actor-index ai 5)) - (vector-ref av (array:actor-index ai 6)) - (vector-ref av (array:actor-index ai 7)))) - (lambda (p ai av) - (p - (vector-ref av (array:actor-index ai 0)) - (vector-ref av (array:actor-index ai 1)) - (vector-ref av (array:actor-index ai 2)) - (vector-ref av (array:actor-index ai 3)) - (vector-ref av (array:actor-index ai 4)) - (vector-ref av (array:actor-index ai 5)) - (vector-ref av (array:actor-index ai 6)) - (vector-ref av (array:actor-index ai 7)) - (vector-ref av (array:actor-index ai 8)))))) - (it - (lambda (r) - (lambda (p ai av) - (apply - p - (vector-ref av (array:actor-index ai 0)) - (vector-ref av (array:actor-index ai 1)) - (vector-ref av (array:actor-index ai 2)) - (vector-ref av (array:actor-index ai 3)) - (vector-ref av (array:actor-index ai 4)) - (vector-ref av (array:actor-index ai 5)) - (vector-ref av (array:actor-index ai 6)) - (vector-ref av (array:actor-index ai 7)) - (vector-ref av (array:actor-index ai 8)) - (vector-ref av (array:actor-index ai 9)) - (do ((k r (- k 1)) - (r - '() - (cons - (vector-ref - av - (array:actor-index ai (- k 1))) - r))) - ((= k 10) r))))))) - (lambda (r) - "These are low level, exposing implementation at call site." - (if (< r 10) (vector-ref em r) (it r))))) - (define (array:index/vector r x v) - ((array:indexer/vector r) x v)) - (define (array:index/array r x av ai) - ((array:indexer/array r) x av ai)) - (define (array:apply-to-vector r p v) - ((array:applier-to-vector r) p v)) - (define (array:apply-to-actor r p a) - ((array:applier-to-actor r) p a))) -(define-library (srfi 25) - (export - array? - make-array - shape - array - array-rank - array-start - array-end - array-ref - array-set! - share-array - ) - (import - (scheme base) - (scheme write)) - (include "25.as-srfi-9-record.upstream.scm") - (include "25.ix-ctor.upstream.scm") - (include "25.op-ctor.upstream.scm") - (include "25.main.upstream.scm")) -(define-library (srfi 26) - (export cut cute) - (import (scheme base)) - (include "26.upstream.scm")) -;;;;"array.scm" Arrays for Scheme -; Copyright (C) 2001, 2003 Aubrey Jaffer -; -;Permission to copy this software, to modify it, to redistribute it, -;to distribute modified versions, and to use it for any purpose is -;granted, subject to the following restrictions and understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warranty or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -;;@code{(require 'array)} or @code{(require 'srfi-63)} -;;@ftindex array - -(require 'record) - -(define array:rtd - (make-record-type "array" - '(dimensions - scales ;list of dimension scales - offset ;exact integer - store ;data - ))) - -(define array:dimensions - (let ((dimensions (record-accessor array:rtd 'dimensions))) - (lambda (array) - (cond ((vector? array) (list (vector-length array))) - ((string? array) (list (string-length array))) - (else (dimensions array)))))) - -(define array:scales - (let ((scales (record-accessor array:rtd 'scales))) - (lambda (obj) - (cond ((string? obj) '(1)) - ((vector? obj) '(1)) - (else (scales obj)))))) - -(define array:store - (let ((store (record-accessor array:rtd 'store))) - (lambda (obj) - (cond ((string? obj) obj) - ((vector? obj) obj) - (else (store obj)))))) - -(define array:offset - (let ((offset (record-accessor array:rtd 'offset))) - (lambda (obj) - (cond ((string? obj) 0) - ((vector? obj) 0) - (else (offset obj)))))) - -(define array:construct - (record-constructor array:rtd '(dimensions scales offset store))) - -;;@args obj -;;Returns @code{#t} if the @1 is an array, and @code{#f} if not. -(define array? - (let ((array:array? (record-predicate array:rtd))) - (lambda (obj) (or (string? obj) (vector? obj) (array:array? obj))))) - -;;@noindent -;;@emph{Note:} Arrays are not disjoint from other Scheme types. -;;Vectors and possibly strings also satisfy @code{array?}. -;;A disjoint array predicate can be written: -;; -;;@example -;;(define (strict-array? obj) -;; (and (array? obj) (not (string? obj)) (not (vector? obj)))) -;;@end example - -;;@body -;;Returns @code{#t} if @1 and @2 have the same rank and dimensions and the -;;corresponding elements of @1 and @2 are @code{equal?}. - -;;@body -;;@0 recursively compares the contents of pairs, vectors, strings, and -;;@emph{arrays}, applying @code{eqv?} on other objects such as numbers -;;and symbols. A rule of thumb is that objects are generally @0 if -;;they print the same. @0 may fail to terminate if its arguments are -;;circular data structures. -;; -;;@example -;;(equal? 'a 'a) @result{} #t -;;(equal? '(a) '(a)) @result{} #t -;;(equal? '(a (b) c) -;; '(a (b) c)) @result{} #t -;;(equal? "abc" "abc") @result{} #t -;;(equal? 2 2) @result{} #t -;;(equal? (make-vector 5 'a) -;; (make-vector 5 'a)) @result{} #t -;;(equal? (make-array (A:fixN32b 4) 5 3) -;; (make-array (A:fixN32b 4) 5 3)) @result{} #t -;;(equal? (make-array '#(foo) 3 3) -;; (make-array '#(foo) 3 3)) @result{} #t -;;(equal? (lambda (x) x) -;; (lambda (y) y)) @result{} @emph{unspecified} -;;@end example -(define (equal? obj1 obj2) - (cond ((eqv? obj1 obj2) #t) - ((or (pair? obj1) (pair? obj2)) - (and (pair? obj1) (pair? obj2) - (equal? (car obj1) (car obj2)) - (equal? (cdr obj1) (cdr obj2)))) - ((or (string? obj1) (string? obj2)) - (and (string? obj1) (string? obj2) - (string=? obj1 obj2))) - ((or (vector? obj1) (vector? obj2)) - (and (vector? obj1) (vector? obj2) - (equal? (vector-length obj1) (vector-length obj2)) - (do ((idx (+ -1 (vector-length obj1)) (+ -1 idx))) - ((or (negative? idx) - (not (equal? (vector-ref obj1 idx) - (vector-ref obj2 idx)))) - (negative? idx))))) - ((or (array? obj1) (array? obj2)) - (and (array? obj1) (array? obj2) - (equal? (array:dimensions obj1) (array:dimensions obj2)) - (equal? (array:store obj1) (array:store obj2)))) - (else #f))) - -;;@body -;;Returns the number of dimensions of @1. If @1 is not an array, 0 is -;;returned. -(define (array-rank obj) - (if (array? obj) (length (array:dimensions obj)) 0)) - -;;@args array -;;Returns a list of dimensions. -;; -;;@example -;;(array-dimensions (make-array '#() 3 5)) -;; @result{} (3 5) -;;@end example -(define array-dimensions array:dimensions) - -;;@args prototype k1 @dots{} -;; -;;Creates and returns an array of type @1 with dimensions @2, @dots{} -;;and filled with elements from @1. @1 must be an array, vector, or -;;string. The implementation-dependent type of the returned array -;;will be the same as the type of @1; except if that would be a vector -;;or string with rank not equal to one, in which case some variety of -;;array will be returned. -;; -;;If the @1 has no elements, then the initial contents of the returned -;;array are unspecified. Otherwise, the returned array will be filled -;;with the element at the origin of @1. -(define (make-array prototype . dimensions) - (define tcnt (apply * dimensions)) - (let ((store - (if (string? prototype) - (case (string-length prototype) - ((0) (make-string tcnt)) - (else (make-string tcnt - (string-ref prototype 0)))) - (let ((pdims (array:dimensions prototype))) - (case (apply * pdims) - ((0) (make-vector tcnt)) - (else (make-vector tcnt - (apply array-ref prototype - (map (lambda (x) 0) pdims))))))))) - (define (loop dims scales) - (if (null? dims) - (array:construct dimensions (cdr scales) 0 store) - (loop (cdr dims) (cons (* (car dims) (car scales)) scales)))) - (loop (reverse dimensions) '(1)))) -;;@args prototype k1 @dots{} -;;@0 is an alias for @code{make-array}. -(define create-array make-array) - -;;@args array mapper k1 @dots{} -;;@0 can be used to create shared subarrays of other -;;arrays. The @var{mapper} is a function that translates coordinates in -;;the new array into coordinates in the old array. A @var{mapper} must be -;;linear, and its range must stay within the bounds of the old array, but -;;it can be otherwise arbitrary. A simple example: -;; -;;@example -;;(define fred (make-array '#(#f) 8 8)) -;;(define freds-diagonal -;; (make-shared-array fred (lambda (i) (list i i)) 8)) -;;(array-set! freds-diagonal 'foo 3) -;;(array-ref fred 3 3) -;; @result{} FOO -;;(define freds-center -;; (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) -;; 2 2)) -;;(array-ref freds-center 0 0) -;; @result{} FOO -;;@end example -(define (make-shared-array array mapper . dimensions) - (define odl (array:scales array)) - (define rank (length dimensions)) - (define shape - (map (lambda (dim) (if (list? dim) dim (list 0 (+ -1 dim)))) dimensions)) - (do ((idx (+ -1 rank) (+ -1 idx)) - (uvt (append (cdr (vector->list (make-vector rank 0))) '(1)) - (append (cdr uvt) '(0))) - (uvts '() (cons uvt uvts))) - ((negative? idx) - (let ((ker0 (apply + (map * odl (apply mapper uvt))))) - (array:construct - (map (lambda (dim) (+ 1 (- (cadr dim) (car dim)))) shape) - (map (lambda (uvt) (- (apply + (map * odl (apply mapper uvt))) ker0)) - uvts) - (apply + - (array:offset array) - (map * odl (apply mapper (map car shape)))) - (array:store array)))))) - -;;@args rank proto list -;;@3 must be a rank-nested list consisting of all the elements, in -;;row-major order, of the array to be created. -;; -;;@0 returns an array of rank @1 and type @2 consisting of all the -;;elements, in row-major order, of @3. When @1 is 0, @3 is the lone -;;array element; not necessarily a list. -;; -;;@example -;;(list->array 2 '#() '((1 2) (3 4))) -;; @result{} #2A((1 2) (3 4)) -;;(list->array 0 '#() 3) -;; @result{} #0A 3 -;;@end example -(define (list->array rank proto lst) - (define dimensions - (do ((shp '() (cons (length row) shp)) - (row lst (car lst)) - (rnk (+ -1 rank) (+ -1 rnk))) - ((negative? rnk) (reverse shp)))) - (let ((nra (apply make-array proto dimensions))) - (define (l2ra dims idxs row) - (cond ((null? dims) - (apply array-set! nra row (reverse idxs))) - ((if (not (eqv? (car dims) (length row))) - (slib:error 'list->array - 'non-rectangular 'array dims dimensions)) - (do ((idx 0 (+ 1 idx)) - (row row (cdr row))) - ((>= idx (car dims))) - (l2ra (cdr dims) (cons idx idxs) (car row)))))) - (l2ra dimensions '() lst) - nra)) - -;;@args array -;;Returns a rank-nested list consisting of all the elements, in -;;row-major order, of @1. In the case of a rank-0 array, @0 returns -;;the single element. -;; -;;@example -;;(array->list #2A((ho ho ho) (ho oh oh))) -;; @result{} ((ho ho ho) (ho oh oh)) -;;(array->list #0A ho) -;; @result{} ho -;;@end example -(define (array->list ra) - (define (ra2l dims idxs) - (if (null? dims) - (apply array-ref ra (reverse idxs)) - (do ((lst '() (cons (ra2l (cdr dims) (cons idx idxs)) lst)) - (idx (+ -1 (car dims)) (+ -1 idx))) - ((negative? idx) lst)))) - (ra2l (array-dimensions ra) '())) - -;;@args vect proto dim1 @dots{} -;;@1 must be a vector of length equal to the product of exact -;;nonnegative integers @3, @dots{}. -;; -;;@0 returns an array of type @2 consisting of all the elements, in -;;row-major order, of @1. In the case of a rank-0 array, @1 has a -;;single element. -;; -;;@example -;;(vector->array #(1 2 3 4) #() 2 2) -;; @result{} #2A((1 2) (3 4)) -;;(vector->array '#(3) '#()) -;; @result{} #0A 3 -;;@end example -(define (vector->array vect prototype . dimensions) - (define vdx (vector-length vect)) - (if (not (eqv? vdx (apply * dimensions))) - (slib:error 'vector->array vdx '<> (cons '* dimensions))) - (let ((ra (apply make-array prototype dimensions))) - (define (v2ra dims idxs) - (cond ((null? dims) - (set! vdx (+ -1 vdx)) - (apply array-set! ra (vector-ref vect vdx) (reverse idxs))) - (else - (do ((idx (+ -1 (car dims)) (+ -1 idx))) - ((negative? idx) vect) - (v2ra (cdr dims) (cons idx idxs)))))) - (v2ra dimensions '()) - ra)) - -;;@args array -;;Returns a new vector consisting of all the elements of @1 in -;;row-major order. -;; -;;@example -;;(array->vector #2A ((1 2)( 3 4))) -;; @result{} #(1 2 3 4) -;;(array->vector #0A ho) -;; @result{} #(ho) -;;@end example -(define (array->vector ra) - (define dims (array-dimensions ra)) - (let* ((vdx (apply * dims)) - (vect (make-vector vdx))) - (define (ra2v dims idxs) - (if (null? dims) - (let ((val (apply array-ref ra (reverse idxs)))) - (set! vdx (+ -1 vdx)) - (vector-set! vect vdx val) - vect) - (do ((idx (+ -1 (car dims)) (+ -1 idx))) - ((negative? idx) vect) - (ra2v (cdr dims) (cons idx idxs))))) - (ra2v dims '()))) - -(define (array:in-bounds? array indices) - (do ((bnds (array:dimensions array) (cdr bnds)) - (idxs indices (cdr idxs))) - ((or (null? bnds) - (null? idxs) - (not (integer? (car idxs))) - (not (< -1 (car idxs) (car bnds)))) - (and (null? bnds) (null? idxs))))) - -;;@args array index1 @dots{} -;;Returns @code{#t} if its arguments would be acceptable to -;;@code{array-ref}. -(define (array-in-bounds? array . indices) - (array:in-bounds? array indices)) - -;;@args array k1 @dots{} -;;Returns the (@2, @dots{}) element of @1. -(define (array-ref array . indices) - (define store (array:store array)) - (or (array:in-bounds? array indices) - (slib:error 'array-ref 'bad-indices indices)) - ((if (string? store) string-ref vector-ref) - store (apply + (array:offset array) (map * (array:scales array) indices)))) - -;;@args array obj k1 @dots{} -;;Stores @2 in the (@3, @dots{}) element of @1. The value returned -;;by @0 is unspecified. -(define (array-set! array obj . indices) - (define store (array:store array)) - (or (array:in-bounds? array indices) - (slib:error 'array-set! 'bad-indices indices)) - ((if (string? store) string-set! vector-set!) - store (apply + (array:offset array) (map * (array:scales array) indices)) - obj)) - -;;@noindent -;;These functions return a prototypical uniform-array enclosing the -;;optional argument (which must be of the correct type). If the -;;uniform-array type is supported by the implementation, then it is -;;returned; defaulting to the next larger precision type; resorting -;;finally to vector. - -(define (make-prototype-checker name pred? creator) - (lambda args - (case (length args) - ((1) (if (pred? (car args)) - (creator (car args)) - (slib:error name 'incompatible 'type (car args)))) - ((0) (creator)) - (else (slib:error name 'wrong 'number 'of 'args args))))) - -(define (integer-bytes?? n) - (lambda (obj) - (and (integer? obj) - (exact? obj) - (or (negative? n) (not (negative? obj))) - (do ((num obj (quotient num 256)) - (n (+ -1 (abs n)) (+ -1 n))) - ((or (zero? num) (negative? n)) - (zero? num)))))) - -;;@args z -;;@args -;;Returns an inexact 128.bit flonum complex uniform-array prototype. -(define A:floC128b (make-prototype-checker 'A:floC128b complex? vector)) -;;@args z -;;@args -;;Returns an inexact 64.bit flonum complex uniform-array prototype. -(define A:floC64b (make-prototype-checker 'A:floC64b complex? vector)) -;;@args z -;;@args -;;Returns an inexact 32.bit flonum complex uniform-array prototype. -(define A:floC32b (make-prototype-checker 'A:floC32b complex? vector)) -;;@args z -;;@args -;;Returns an inexact 16.bit flonum complex uniform-array prototype. -(define A:floC16b (make-prototype-checker 'A:floC16b complex? vector)) - -;;@args z -;;@args -;;Returns an inexact 128.bit flonum real uniform-array prototype. -(define A:floR128b (make-prototype-checker 'A:floR128b real? vector)) -;;@args z -;;@args -;;Returns an inexact 64.bit flonum real uniform-array prototype. -(define A:floR64b (make-prototype-checker 'A:floR64b real? vector)) -;;@args z -;;@args -;;Returns an inexact 32.bit flonum real uniform-array prototype. -(define A:floR32b (make-prototype-checker 'A:floR32b real? vector)) -;;@args z -;;@args -;;Returns an inexact 16.bit flonum real uniform-array prototype. -(define A:floR16b (make-prototype-checker 'A:floR16b real? vector)) - -;;@args z -;;@args -;;Returns an exact 128.bit decimal flonum rational uniform-array prototype. -(define A:floR128b (make-prototype-checker 'A:floR128b real? vector)) -;;@args z -;;@args -;;Returns an exact 64.bit decimal flonum rational uniform-array prototype. -(define A:floR64b (make-prototype-checker 'A:floR64b real? vector)) -;;@args z -;;@args -;;Returns an exact 32.bit decimal flonum rational uniform-array prototype. -(define A:floR32b (make-prototype-checker 'A:floR32b real? vector)) - -;;@args n -;;@args -;;Returns an exact binary fixnum uniform-array prototype with at least -;;64 bits of precision. -(define A:fixZ64b (make-prototype-checker 'A:fixZ64b (integer-bytes?? -8) vector)) -;;@args n -;;@args -;;Returns an exact binary fixnum uniform-array prototype with at least -;;32 bits of precision. -(define A:fixZ32b (make-prototype-checker 'A:fixZ32b (integer-bytes?? -4) vector)) -;;@args n -;;@args -;;Returns an exact binary fixnum uniform-array prototype with at least -;;16 bits of precision. -(define A:fixZ16b (make-prototype-checker 'A:fixZ16b (integer-bytes?? -2) vector)) -;;@args n -;;@args -;;Returns an exact binary fixnum uniform-array prototype with at least -;;8 bits of precision. -(define A:fixZ8b (make-prototype-checker 'A:fixZ8b (integer-bytes?? -1) vector)) - -;;@args k -;;@args -;;Returns an exact non-negative binary fixnum uniform-array prototype with at -;;least 64 bits of precision. -(define A:fixN64b (make-prototype-checker 'A:fixN64b (integer-bytes?? 8) vector)) -;;@args k -;;@args -;;Returns an exact non-negative binary fixnum uniform-array prototype with at -;;least 32 bits of precision. -(define A:fixN32b (make-prototype-checker 'A:fixN32b (integer-bytes?? 4) vector)) -;;@args k -;;@args -;;Returns an exact non-negative binary fixnum uniform-array prototype with at -;;least 16 bits of precision. -(define A:fixN16b (make-prototype-checker 'A:fixN16b (integer-bytes?? 2) vector)) -;;@args k -;;@args -;;Returns an exact non-negative binary fixnum uniform-array prototype with at -;;least 8 bits of precision. -(define A:fixN8b (make-prototype-checker 'A:fixN8b (integer-bytes?? 1) vector)) - -;;@args bool -;;@args -;;Returns a boolean uniform-array prototype. -(define A:bool (make-prototype-checker 'A:bool boolean? vector)) -; REFERENCE IMPLEMENTATION FOR SRFI-26 "CUT" -; ========================================== -; -; Sebastian.Egner@philips.com, 5-Jun-2002. -; adapted from the posting by Al Petrofsky -; placed in the public domain -; -; The code to handle the variable argument case was originally -; proposed by Michael Sperber and has been adapted to the new -; syntax of the macro using an explicit rest-slot symbol. The -; code to evaluate the non-slots for cute has been proposed by -; Dale Jordan. The code to allow a slot for the procedure position -; and to process the macro using an internal macro is based on -; a suggestion by Al Petrofsky. The code found below is, with -; exception of this header and some changes in variable names, -; entirely written by Al Petrofsky. -; -; compliance: -; Scheme R5RS (including macros). -; -; loading this file into Scheme 48 0.57: -; ,load cut.scm -; -; history of this file: -; SE, 6-Feb-2002: initial version as 'curry' with ". <>" notation -; SE, 14-Feb-2002: revised for <___> -; SE, 27-Feb-2002: revised for 'cut' -; SE, 03-Jun-2002: revised for proc-slot, cute -; SE, 04-Jun-2002: rewritten with internal transformer (no "loop" pattern) -; SE, 05-Jun-2002: replace my code by Al's; substituted "constant" etc. -; to match the convention in the SRFI-document - -; (srfi-26-internal-cut slot-names combination . se) -; transformer used internally -; slot-names : the internal names of the slots -; combination : procedure being specialized, followed by its arguments -; se : slots-or-exprs, the qualifiers of the macro - -(define-syntax srfi-26-internal-cut - (syntax-rules (<> <___>) - - ;; construct fixed- or variable-arity procedure: - ;; (begin proc) throws an error if proc is not an - ((srfi-26-internal-cut (slot-name ...) (proc arg ...)) - (lambda (slot-name ...) ((begin proc) arg ...))) - ((srfi-26-internal-cut (slot-name ...) (proc arg ...) <___>) - (lambda (slot-name ... . rest-slot) (apply proc arg ... rest-slot))) - - ;; process one slot-or-expr - ((srfi-26-internal-cut (slot-name ...) (position ...) <> . se) - (srfi-26-internal-cut (slot-name ... x) (position ... x) . se)) - ((srfi-26-internal-cut (slot-name ...) (position ...) nse . se) - (srfi-26-internal-cut (slot-name ...) (position ... nse) . se)))) - -; (srfi-26-internal-cute slot-names nse-bindings combination . se) -; transformer used internally -; slot-names : the internal names of the slots -; nse-bindings : let-style bindings for the non-slot expressions. -; combination : procedure being specialized, followed by its arguments -; se : slots-or-exprs, the qualifiers of the macro - -(define-syntax srfi-26-internal-cute - (syntax-rules (<> <___>) - - ;; If there are no slot-or-exprs to process, then: - ;; construct a fixed-arity procedure, - ((srfi-26-internal-cute - (slot-name ...) nse-bindings (proc arg ...)) - (let nse-bindings (lambda (slot-name ...) (proc arg ...)))) - ;; or a variable-arity procedure - ((srfi-26-internal-cute - (slot-name ...) nse-bindings (proc arg ...) <___>) - (let nse-bindings (lambda (slot-name ... . x) (apply proc arg ... x)))) - - ;; otherwise, process one slot: - ((srfi-26-internal-cute - (slot-name ...) nse-bindings (position ...) <> . se) - (srfi-26-internal-cute - (slot-name ... x) nse-bindings (position ... x) . se)) - ;; or one non-slot expression - ((srfi-26-internal-cute - slot-names nse-bindings (position ...) nse . se) - (srfi-26-internal-cute - slot-names ((x nse) . nse-bindings) (position ... x) . se)))) - -; exported syntax - -(define-syntax cut - (syntax-rules () - ((cut . slots-or-exprs) - (srfi-26-internal-cut () () . slots-or-exprs)))) - -(define-syntax cute - (syntax-rules () - ((cute . slots-or-exprs) - (srfi-26-internal-cute () () () . slots-or-exprs)))) -;;;; "logical.scm", bit access and operations for integers for Scheme -;;; Copyright (C) 1991, 1993, 2001, 2003, 2005 Aubrey Jaffer -; -;Permission to copy this software, to modify it, to redistribute it, -;to distribute modified versions, and to use it for any purpose is -;granted, subject to the following restrictions and understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warranty or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -(define logical:boole-xor - '#(#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) - #(1 0 3 2 5 4 7 6 9 8 11 10 13 12 15 14) - #(2 3 0 1 6 7 4 5 10 11 8 9 14 15 12 13) - #(3 2 1 0 7 6 5 4 11 10 9 8 15 14 13 12) - #(4 5 6 7 0 1 2 3 12 13 14 15 8 9 10 11) - #(5 4 7 6 1 0 3 2 13 12 15 14 9 8 11 10) - #(6 7 4 5 2 3 0 1 14 15 12 13 10 11 8 9) - #(7 6 5 4 3 2 1 0 15 14 13 12 11 10 9 8) - #(8 9 10 11 12 13 14 15 0 1 2 3 4 5 6 7) - #(9 8 11 10 13 12 15 14 1 0 3 2 5 4 7 6) - #(10 11 8 9 14 15 12 13 2 3 0 1 6 7 4 5) - #(11 10 9 8 15 14 13 12 3 2 1 0 7 6 5 4) - #(12 13 14 15 8 9 10 11 4 5 6 7 0 1 2 3) - #(13 12 15 14 9 8 11 10 5 4 7 6 1 0 3 2) - #(14 15 12 13 10 11 8 9 6 7 4 5 2 3 0 1) - #(15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0))) - -(define logical:boole-and - '#(#(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) - #(0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1) - #(0 0 2 2 0 0 2 2 0 0 2 2 0 0 2 2) - #(0 1 2 3 0 1 2 3 0 1 2 3 0 1 2 3) - #(0 0 0 0 4 4 4 4 0 0 0 0 4 4 4 4) - #(0 1 0 1 4 5 4 5 0 1 0 1 4 5 4 5) - #(0 0 2 2 4 4 6 6 0 0 2 2 4 4 6 6) - #(0 1 2 3 4 5 6 7 0 1 2 3 4 5 6 7) - #(0 0 0 0 0 0 0 0 8 8 8 8 8 8 8 8) - #(0 1 0 1 0 1 0 1 8 9 8 9 8 9 8 9) - #(0 0 2 2 0 0 2 2 8 8 10 10 8 8 10 10) - #(0 1 2 3 0 1 2 3 8 9 10 11 8 9 10 11) - #(0 0 0 0 4 4 4 4 8 8 8 8 12 12 12 12) - #(0 1 0 1 4 5 4 5 8 9 8 9 12 13 12 13) - #(0 0 2 2 4 4 6 6 8 8 10 10 12 12 14 14) - #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15))) - -(define (logical:ash-4 x) - (if (negative? x) - (+ -1 (quotient (+ 1 x) 16)) - (quotient x 16))) - -(define (logical:reduce op4 ident) - (lambda args - (do ((res ident (op4 res (car rgs) 1 0)) - (rgs args (cdr rgs))) - ((null? rgs) res)))) - -;@ -(define logand - (letrec - ((lgand - (lambda (n2 n1 scl acc) - (cond ((= n1 n2) (+ acc (* scl n1))) - ((zero? n2) acc) - ((zero? n1) acc) - (else (lgand (logical:ash-4 n2) - (logical:ash-4 n1) - (* 16 scl) - (+ (* (vector-ref (vector-ref logical:boole-and - (modulo n1 16)) - (modulo n2 16)) - scl) - acc))))))) - (logical:reduce lgand -1))) -;@ -(define logior - (letrec - ((lgior - (lambda (n2 n1 scl acc) - (cond ((= n1 n2) (+ acc (* scl n1))) - ((zero? n2) (+ acc (* scl n1))) - ((zero? n1) (+ acc (* scl n2))) - (else (lgior (logical:ash-4 n2) - (logical:ash-4 n1) - (* 16 scl) - (+ (* (- 15 (vector-ref - (vector-ref logical:boole-and - (- 15 (modulo n1 16))) - (- 15 (modulo n2 16)))) - scl) - acc))))))) - (logical:reduce lgior 0))) -;@ -(define logxor - (letrec - ((lgxor - (lambda (n2 n1 scl acc) - (cond ((= n1 n2) acc) - ((zero? n2) (+ acc (* scl n1))) - ((zero? n1) (+ acc (* scl n2))) - (else (lgxor (logical:ash-4 n2) - (logical:ash-4 n1) - (* 16 scl) - (+ (* (vector-ref (vector-ref logical:boole-xor - (modulo n1 16)) - (modulo n2 16)) - scl) - acc))))))) - (logical:reduce lgxor 0))) -;@ -(define (lognot n) (- -1 n)) -;@ -(define (logtest n1 n2) - (not (zero? (logand n1 n2)))) -;@ -(define (logbit? index n) - (logtest (expt 2 index) n)) -;@ -(define (copy-bit index to bool) - (if bool - (logior to (arithmetic-shift 1 index)) - (logand to (lognot (arithmetic-shift 1 index))))) -;@ -(define (bitwise-if mask n0 n1) - (logior (logand mask n0) - (logand (lognot mask) n1))) -;@ -(define (bit-field n start end) - (logand (lognot (ash -1 (- end start))) - (arithmetic-shift n (- start)))) -;@ -(define (copy-bit-field to from start end) - (bitwise-if (arithmetic-shift (lognot (ash -1 (- end start))) start) - (arithmetic-shift from start) - to)) -;@ -(define (rotate-bit-field n count start end) - (define width (- end start)) - (set! count (modulo count width)) - (let ((mask (lognot (ash -1 width)))) - (define zn (logand mask (arithmetic-shift n (- start)))) - (logior (arithmetic-shift - (logior (logand mask (arithmetic-shift zn count)) - (arithmetic-shift zn (- count width))) - start) - (logand (lognot (ash mask start)) n)))) -;@ -(define (arithmetic-shift n count) - (if (negative? count) - (let ((k (expt 2 (- count)))) - (if (negative? n) - (+ -1 (quotient (+ 1 n) k)) - (quotient n k))) - (* (expt 2 count) n))) -;@ -(define integer-length - (letrec ((intlen (lambda (n tot) - (case n - ((0 -1) (+ 0 tot)) - ((1 -2) (+ 1 tot)) - ((2 3 -3 -4) (+ 2 tot)) - ((4 5 6 7 -5 -6 -7 -8) (+ 3 tot)) - (else (intlen (logical:ash-4 n) (+ 4 tot))))))) - (lambda (n) (intlen n 0)))) -;@ -(define logcount - (letrec ((logcnt (lambda (n tot) - (if (zero? n) - tot - (logcnt (quotient n 16) - (+ (vector-ref - '#(0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4) - (modulo n 16)) - tot)))))) - (lambda (n) - (cond ((negative? n) (logcnt (lognot n) 0)) - ((positive? n) (logcnt n 0)) - (else 0))))) -;@ -(define (log2-binary-factors n) - (+ -1 (integer-length (logand n (- n))))) - -(define (bit-reverse k n) - (do ((m (if (negative? n) (lognot n) n) (arithmetic-shift m -1)) - (k (+ -1 k) (+ -1 k)) - (rvs 0 (logior (arithmetic-shift rvs 1) (logand 1 m)))) - ((negative? k) (if (negative? n) (lognot rvs) rvs)))) -;@ -(define (reverse-bit-field n start end) - (define width (- end start)) - (let ((mask (lognot (ash -1 width)))) - (define zn (logand mask (arithmetic-shift n (- start)))) - (logior (arithmetic-shift (bit-reverse width zn) start) - (logand (lognot (ash mask start)) n)))) -;@ -(define (integer->list k . len) - (if (null? len) - (do ((k k (arithmetic-shift k -1)) - (lst '() (cons (odd? k) lst))) - ((<= k 0) lst)) - (do ((idx (+ -1 (car len)) (+ -1 idx)) - (k k (arithmetic-shift k -1)) - (lst '() (cons (odd? k) lst))) - ((negative? idx) lst)))) -;@ -(define (list->integer bools) - (do ((bs bools (cdr bs)) - (acc 0 (+ acc acc (if (car bs) 1 0)))) - ((null? bs) acc))) -(define (booleans->integer . bools) - (list->integer bools)) - -;;;;@ SRFI-60 aliases -(define ash arithmetic-shift) -(define bitwise-ior logior) -(define bitwise-xor logxor) -(define bitwise-and logand) -(define bitwise-not lognot) -(define bit-count logcount) -(define bit-set? logbit?) -(define any-bits-set? logtest) -(define first-set-bit log2-binary-factors) -(define bitwise-merge bitwise-if) - -;;; Legacy -;;(define (logical:rotate k count len) (rotate-bit-field k count 0 len)) -;;(define (logical:ones deg) (lognot (ash -1 deg))) -;;(define integer-expt expt) ; legacy name -; 54-BIT INTEGER IMPLEMENTATION OF THE "MRG32K3A"-GENERATOR -; ========================================================= -; -; Sebastian.Egner@philips.com, Mar-2002. -; -; This file is an implementation of Pierre L'Ecuyer's MRG32k3a -; pseudo random number generator. Please refer to 'mrg32k3a.scm' -; for more information. -; -; compliance: -; Scheme R5RS with integers covering at least {-2^53..2^53-1}. -; -; history of this file: -; SE, 18-Mar-2002: initial version -; SE, 22-Mar-2002: comments adjusted, range added -; SE, 25-Mar-2002: pack/unpack just return their argument - -; the actual generator - -(define (mrg32k3a-random-m1 state) - (let ((x11 (vector-ref state 0)) - (x12 (vector-ref state 1)) - (x13 (vector-ref state 2)) - (x21 (vector-ref state 3)) - (x22 (vector-ref state 4)) - (x23 (vector-ref state 5))) - (let ((x10 (modulo (- (* 1403580 x12) (* 810728 x13)) 4294967087)) - (x20 (modulo (- (* 527612 x21) (* 1370589 x23)) 4294944443))) - (vector-set! state 0 x10) - (vector-set! state 1 x11) - (vector-set! state 2 x12) - (vector-set! state 3 x20) - (vector-set! state 4 x21) - (vector-set! state 5 x22) - (modulo (- x10 x20) 4294967087)))) - -; interface to the generic parts of the generator - -(define (mrg32k3a-pack-state unpacked-state) - unpacked-state) - -(define (mrg32k3a-unpack-state state) - state) - -(define (mrg32k3a-random-range) ; m1 - 4294967087) - -(define (mrg32k3a-random-integer state range) ; rejection method - (let* ((q (quotient 4294967087 range)) - (qn (* q range))) - (do ((x (mrg32k3a-random-m1 state) (mrg32k3a-random-m1 state))) - ((< x qn) (quotient x q))))) - -(define (mrg32k3a-random-real state) ; normalization is 1/(m1+1) - (* 0.0000000002328306549295728 (+ 1.0 (mrg32k3a-random-m1 state)))) - -;;; Copyright (C) 2004 Taylor Campbell. All rights reserved. - -;;; Made an R7RS library by Taylan Ulrich Bayırlı/Kammer, Copyright (C) 2014. - -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to -;;; deal in the Software without restriction, including without limitation the -;;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -;;; sell copies of the Software, and to permit persons to whom the Software is -;;; furnished to do so, subject to the following conditions: - -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. - -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(define-library (srfi 61) - (export cond) - (import (except (scheme base) cond)) - (begin - - (define-syntax cond - (syntax-rules (=> else) - - ((cond (else else1 else2 ...)) - ;; The (if #t (begin ...)) wrapper ensures that there may be no - ;; internal definitions in the body of the clause. R5RS mandates - ;; this in text (by referring to each subform of the clauses as - ;; ) but not in its reference implementation of `cond', - ;; which just expands to (begin ...) with no (if #t ...) wrapper. - (if #t (begin else1 else2 ...))) - - ((cond (test => receiver) more-clause ...) - (let ((t test)) - (cond/maybe-more t - (receiver t) - more-clause ...))) - - ((cond (generator guard => receiver) more-clause ...) - (call-with-values (lambda () generator) - (lambda t - (cond/maybe-more (apply guard t) - (apply receiver t) - more-clause ...)))) - - ((cond (test) more-clause ...) - (let ((t test)) - (cond/maybe-more t t more-clause ...))) - - ((cond (test body1 body2 ...) more-clause ...) - (cond/maybe-more test - (begin body1 body2 ...) - more-clause ...)))) - - (define-syntax cond/maybe-more - (syntax-rules () - ((cond/maybe-more test consequent) - (if test - consequent)) - ((cond/maybe-more test consequent clause ...) - (if test - consequent - (cond clause ...))))) - - )) -; GENERIC PART OF MRG32k3a-GENERATOR FOR SRFI-27 -; ============================================== -; -; Sebastian.Egner@philips.com, 2002. -; -; This is the generic R5RS-part of the implementation of the MRG32k3a -; generator to be used in SRFI-27. It is based on a separate implementation -; of the core generator (presumably in native code) and on code to -; provide essential functionality not available in R5RS (see below). -; -; compliance: -; Scheme R5RS with integer covering at least {-2^53..2^53-1}. -; In addition, -; SRFI-23: error -; -; history of this file: -; SE, 22-Mar-2002: refactored from earlier versions -; SE, 25-Mar-2002: pack/unpack need not allocate -; SE, 27-Mar-2002: changed interface to core generator -; SE, 10-Apr-2002: updated spec of mrg32k3a-random-integer - -; Generator -; ========= -; -; Pierre L'Ecuyer's MRG32k3a generator is a Combined Multiple Recursive -; Generator. It produces the sequence {(x[1,n] - x[2,n]) mod m1 : n} -; defined by the two recursive generators -; -; x[1,n] = ( a12 x[1,n-2] + a13 x[1,n-3]) mod m1, -; x[2,n] = (a21 x[2,n-1] + a23 x[2,n-3]) mod m2, -; -; where the constants are -; m1 = 4294967087 = 2^32 - 209 modulus of 1st component -; m2 = 4294944443 = 2^32 - 22853 modulus of 2nd component -; a12 = 1403580 recursion coefficients -; a13 = -810728 -; a21 = 527612 -; a23 = -1370589 -; -; The generator passes all tests of G. Marsaglia's Diehard testsuite. -; Its period is (m1^3 - 1)(m2^3 - 1)/2 which is nearly 2^191. -; L'Ecuyer reports: "This generator is well-behaved in all dimensions -; up to at least 45: ..." [with respect to the spectral test, SE]. -; -; The period is maximal for all values of the seed as long as the -; state of both recursive generators is not entirely zero. -; -; As the successor state is a linear combination of previous -; states, it is possible to advance the generator by more than one -; iteration by applying a linear transformation. The following -; publication provides detailed information on how to do that: -; -; [1] P. L'Ecuyer, R. Simard, E. J. Chen, W. D. Kelton: -; An Object-Oriented Random-Number Package With Many Long -; Streams and Substreams. 2001. -; To appear in Operations Research. -; -; Arithmetics -; =========== -; -; The MRG32k3a generator produces values in {0..2^32-209-1}. All -; subexpressions of the actual generator fit into {-2^53..2^53-1}. -; The code below assumes that Scheme's "integer" covers this range. -; In addition, it is assumed that floating point literals can be -; read and there is some arithmetics with inexact numbers. -; -; However, for advancing the state of the generator by more than -; one step at a time, the full range {0..2^32-209-1} is needed. - - -; Required: Backbone Generator -; ============================ -; -; At this point in the code, the following procedures are assumed -; to be defined to execute the core generator: -; -; (mrg32k3a-pack-state unpacked-state) -> packed-state -; (mrg32k3a-unpack-state packed-state) -> unpacked-state -; pack/unpack a state of the generator. The core generator works -; on packed states, passed as an explicit argument, only. This -; allows native code implementations to store their state in a -; suitable form. Unpacked states are #(x10 x11 x12 x20 x21 x22) -; with integer x_ij. Pack/unpack need not allocate new objects -; in case packed and unpacked states are identical. -; -; (mrg32k3a-random-range) -> m-max -; (mrg32k3a-random-integer packed-state range) -> x in {0..range-1} -; advance the state of the generator and return the next random -; range-limited integer. -; Note that the state is not necessarily advanced by just one -; step because we use the rejection method to avoid any problems -; with distribution anomalies. -; The range argument must be an exact integer in {1..m-max}. -; It can be assumed that range is a fixnum if the Scheme system -; has such a number representation. -; -; (mrg32k3a-random-real packed-state) -> x in (0,1) -; advance the state of the generator and return the next random -; real number between zero and one (both excluded). The type of -; the result should be a flonum if possible. - -; Required: Record Data Type -; ========================== -; -; At this point in the code, the following procedures are assumed -; to be defined to create and access a new record data type: -; -; (\:random-source-make a0 a1 a2 a3 a4 a5) -> s -; constructs a new random source object s consisting of the -; objects a0 .. a5 in this order. -; -; (\:random-source? obj) -> bool -; tests if a Scheme object is a :random-source. -; -; (\:random-source-state-ref s) -> a0 -; (\:random-source-state-set! s) -> a1 -; (\:random-source-randomize! s) -> a2 -; (\:random-source-pseudo-randomize! s) -> a3 -; (\:random-source-make-integers s) -> a4 -; (\:random-source-make-reals s) -> a5 -; retrieve the values in the fields of the object s. - -; Required: Current Time as an Integer -; ==================================== -; -; At this point in the code, the following procedure is assumed -; to be defined to obtain a value that is likely to be different -; for each invokation of the Scheme system: -; -; (\:random-source-current-time) -> x -; an integer that depends on the system clock. It is desired -; that the integer changes as fast as possible. - - -; Accessing the State -; =================== - -(define (mrg32k3a-state-ref packed-state) - (cons 'lecuyer-mrg32k3a - (vector->list (mrg32k3a-unpack-state packed-state)))) - -(define (mrg32k3a-state-set external-state) - - (define (check-value x m) - (if (and (integer? x) - (exact? x) - (<= 0 x (- m 1))) - #t - (error "illegal value" x))) - - (if (and (list? external-state) - (= (length external-state) 7) - (eq? (car external-state) 'lecuyer-mrg32k3a)) - (let ((s (cdr external-state))) - (check-value (list-ref s 0) mrg32k3a-m1) - (check-value (list-ref s 1) mrg32k3a-m1) - (check-value (list-ref s 2) mrg32k3a-m1) - (check-value (list-ref s 3) mrg32k3a-m2) - (check-value (list-ref s 4) mrg32k3a-m2) - (check-value (list-ref s 5) mrg32k3a-m2) - (if (or (zero? (+ (list-ref s 0) (list-ref s 1) (list-ref s 2))) - (zero? (+ (list-ref s 3) (list-ref s 4) (list-ref s 5)))) - (error "illegal degenerate state" external-state)) - (mrg32k3a-pack-state (list->vector s))) - (error "malformed state" external-state))) - - -; Pseudo-Randomization -; ==================== -; -; Reference [1] above shows how to obtain many long streams and -; substream from the backbone generator. -; -; The idea is that the generator is a linear operation on the state. -; Hence, we can express this operation as a 3x3-matrix acting on the -; three most recent states. Raising the matrix to the k-th power, we -; obtain the operation to advance the state by k steps at once. The -; virtual streams and substreams are now simply parts of the entire -; periodic sequence (which has period around 2^191). -; -; For the implementation it is necessary to compute with matrices in -; the ring (Z/(m1*m1)*Z)^(3x3). By the Chinese-Remainder Theorem, this -; is isomorphic to ((Z/m1*Z) x (Z/m2*Z))^(3x3). We represent such a pair -; of matrices -; [ [[x00 x01 x02], -; [x10 x11 x12], -; [x20 x21 x22]], mod m1 -; [[y00 y01 y02], -; [y10 y11 y12], -; [y20 y21 y22]] mod m2] -; as a vector of length 18 of the integers as writen above: -; #(x00 x01 x02 x10 x11 x12 x20 x21 x22 -; y00 y01 y02 y10 y11 y12 y20 y21 y22) -; -; As the implementation should only use the range {-2^53..2^53-1}, the -; fundamental operation (x*y) mod m, where x, y, m are nearly 2^32, -; is computed by breaking up x and y as x = x1*w + x0 and y = y1*w + y0 -; where w = 2^16. In this case, all operations fit the range because -; w^2 mod m is a small number. If proper multiprecision integers are -; available this is not necessary, but pseudo-randomize! is an expected -; to be called only occasionally so we do not provide this implementation. - -(define mrg32k3a-m1 4294967087) ; modulus of component 1 -(define mrg32k3a-m2 4294944443) ; modulus of component 2 - -(define mrg32k3a-initial-state ; 0 3 6 9 12 15 of A^16, see below - '#( 1062452522 - 2961816100 - 342112271 - 2854655037 - 3321940838 - 3542344109)) - -(define mrg32k3a-generators #f) ; computed when needed - -(define (mrg32k3a-pseudo-randomize-state i j) - - (define (product A B) ; A*B in ((Z/m1*Z) x (Z/m2*Z))^(3x3) - - (define w 65536) ; wordsize to split {0..2^32-1} - (define w-sqr1 209) ; w^2 mod m1 - (define w-sqr2 22853) ; w^2 mod m2 - - (define (lc i0 i1 i2 j0 j1 j2 m w-sqr) ; linear combination - (let ((a0h (quotient (vector-ref A i0) w)) - (a0l (modulo (vector-ref A i0) w)) - (a1h (quotient (vector-ref A i1) w)) - (a1l (modulo (vector-ref A i1) w)) - (a2h (quotient (vector-ref A i2) w)) - (a2l (modulo (vector-ref A i2) w)) - (b0h (quotient (vector-ref B j0) w)) - (b0l (modulo (vector-ref B j0) w)) - (b1h (quotient (vector-ref B j1) w)) - (b1l (modulo (vector-ref B j1) w)) - (b2h (quotient (vector-ref B j2) w)) - (b2l (modulo (vector-ref B j2) w))) - (modulo - (+ (* (+ (* a0h b0h) - (* a1h b1h) - (* a2h b2h)) - w-sqr) - (* (+ (* a0h b0l) - (* a0l b0h) - (* a1h b1l) - (* a1l b1h) - (* a2h b2l) - (* a2l b2h)) - w) - (* a0l b0l) - (* a1l b1l) - (* a2l b2l)) - m))) - - (vector - (lc 0 1 2 0 3 6 mrg32k3a-m1 w-sqr1) ; (A*B)_00 mod m1 - (lc 0 1 2 1 4 7 mrg32k3a-m1 w-sqr1) ; (A*B)_01 - (lc 0 1 2 2 5 8 mrg32k3a-m1 w-sqr1) - (lc 3 4 5 0 3 6 mrg32k3a-m1 w-sqr1) ; (A*B)_10 - (lc 3 4 5 1 4 7 mrg32k3a-m1 w-sqr1) - (lc 3 4 5 2 5 8 mrg32k3a-m1 w-sqr1) - (lc 6 7 8 0 3 6 mrg32k3a-m1 w-sqr1) - (lc 6 7 8 1 4 7 mrg32k3a-m1 w-sqr1) - (lc 6 7 8 2 5 8 mrg32k3a-m1 w-sqr1) - (lc 9 10 11 9 12 15 mrg32k3a-m2 w-sqr2) ; (A*B)_00 mod m2 - (lc 9 10 11 10 13 16 mrg32k3a-m2 w-sqr2) - (lc 9 10 11 11 14 17 mrg32k3a-m2 w-sqr2) - (lc 12 13 14 9 12 15 mrg32k3a-m2 w-sqr2) - (lc 12 13 14 10 13 16 mrg32k3a-m2 w-sqr2) - (lc 12 13 14 11 14 17 mrg32k3a-m2 w-sqr2) - (lc 15 16 17 9 12 15 mrg32k3a-m2 w-sqr2) - (lc 15 16 17 10 13 16 mrg32k3a-m2 w-sqr2) - (lc 15 16 17 11 14 17 mrg32k3a-m2 w-sqr2))) - - (define (power A e) ; A^e - (cond - ((zero? e) - '#(1 0 0 0 1 0 0 0 1 1 0 0 0 1 0 0 0 1)) - ((= e 1) - A) - ((even? e) - (power (product A A) (quotient e 2))) - (else - (product (power A (- e 1)) A)))) - - (define (power-power A b) ; A^(2^b) - (if (zero? b) - A - (power-power (product A A) (- b 1)))) - - (define A ; the MRG32k3a recursion - '#( 0 1403580 4294156359 - 1 0 0 - 0 1 0 - 527612 0 4293573854 - 1 0 0 - 0 1 0)) - - ; check arguments - (if (not (and (integer? i) - (exact? i) - (integer? j) - (exact? j))) - (error "i j must be exact integer" i j)) - - ; precompute A^(2^127) and A^(2^76) only once - - (if (not mrg32k3a-generators) - (set! mrg32k3a-generators - (list (power-power A 127) - (power-power A 76) - (power A 16)))) - - ; compute M = A^(16 + i*2^127 + j*2^76) - (let ((M (product - (list-ref mrg32k3a-generators 2) - (product - (power (list-ref mrg32k3a-generators 0) - (modulo i (expt 2 28))) - (power (list-ref mrg32k3a-generators 1) - (modulo j (expt 2 28))))))) - (mrg32k3a-pack-state - (vector - (vector-ref M 0) - (vector-ref M 3) - (vector-ref M 6) - (vector-ref M 9) - (vector-ref M 12) - (vector-ref M 15))))) - -; True Randomization -; ================== -; -; The value obtained from the system time is feed into a very -; simple pseudo random number generator. This in turn is used -; to obtain numbers to randomize the state of the MRG32k3a -; generator, avoiding period degeneration. - -(define (mrg32k3a-randomize-state state) - ;; G. Marsaglia's simple 16-bit generator with carry - (let* ((m 65536) - (x (modulo (random-source-current-time) m))) - (define (random-m) - (let ((y (modulo x m))) - (set! x (+ (* 30903 y) (quotient x m))) - y)) - (define (random n) ; m < n < m^2 - (modulo (+ (* (random-m) m) (random-m)) n)) - - ; modify the state - (let ((m1 mrg32k3a-m1) - (m2 mrg32k3a-m2) - (s (mrg32k3a-unpack-state state))) - (mrg32k3a-pack-state - (vector - (+ 1 (modulo (+ (vector-ref s 0) (random (- m1 1))) (- m1 1))) - (modulo (+ (vector-ref s 1) (random m1)) m1) - (modulo (+ (vector-ref s 2) (random m1)) m1) - (+ 1 (modulo (+ (vector-ref s 3) (random (- m2 1))) (- m2 1))) - (modulo (+ (vector-ref s 4) (random m2)) m2) - (modulo (+ (vector-ref s 5) (random m2)) m2)))))) - - -; Large Integers -; ============== -; -; To produce large integer random deviates, for n > m-max, we first -; construct large random numbers in the range {0..m-max^k-1} for some -; k such that m-max^k >= n and then use the rejection method to choose -; uniformly from the range {0..n-1}. - -(define mrg32k3a-m-max - (mrg32k3a-random-range)) - -(define (mrg32k3a-random-power state k) ; n = m-max^k, k >= 1 - (if (= k 1) - (mrg32k3a-random-integer state mrg32k3a-m-max) - (+ (* (mrg32k3a-random-power state (- k 1)) mrg32k3a-m-max) - (mrg32k3a-random-integer state mrg32k3a-m-max)))) - -(define (mrg32k3a-random-large state n) ; n > m-max - (do ((k 2 (+ k 1)) - (mk (* mrg32k3a-m-max mrg32k3a-m-max) (* mk mrg32k3a-m-max))) - ((>= mk n) - (let* ((mk-by-n (quotient mk n)) - (a (* mk-by-n n))) - (do ((x (mrg32k3a-random-power state k) - (mrg32k3a-random-power state k))) - ((< x a) (quotient x mk-by-n))))))) - - -; Multiple Precision Reals -; ======================== -; -; To produce multiple precision reals we produce a large integer value -; and convert it into a real value. This value is then normalized. -; The precision goal is unit <= 1/(m^k + 1), or 1/unit - 1 <= m^k. -; If you know more about the floating point number types of the -; Scheme system, this can be improved. - -(define (mrg32k3a-random-real-mp state unit) - (do ((k 1 (+ k 1)) - (u (- (/ 1 unit) 1) (/ u mrg32k3a-m1))) - ((<= u 1) - (/ (exact->inexact (+ (mrg32k3a-random-power state k) 1)) - (exact->inexact (+ (expt mrg32k3a-m-max k) 1)))))) - - -; Provide the Interface as Specified in the SRFI -; ============================================== -; -; An object of type random-source is a record containing the procedures -; as components. The actual state of the generator is stored in the -; binding-time environment of make-random-source. - -(define (make-random-source) - (let ((state (mrg32k3a-pack-state ; make a new copy - (list->vector (vector->list mrg32k3a-initial-state))))) - (\:random-source-make - (lambda () - (mrg32k3a-state-ref state)) - (lambda (new-state) - (set! state (mrg32k3a-state-set new-state))) - (lambda () - (set! state (mrg32k3a-randomize-state state))) - (lambda (i j) - (set! state (mrg32k3a-pseudo-randomize-state i j))) - (lambda () - (lambda (n) - (cond - ((not (and (integer? n) (exact? n) (positive? n))) - (error "range must be exact positive integer" n)) - ((<= n mrg32k3a-m-max) - (mrg32k3a-random-integer state n)) - (else - (mrg32k3a-random-large state n))))) - (lambda args - (cond - ((null? args) - (lambda () - (mrg32k3a-random-real state))) - ((null? (cdr args)) - (let ((unit (car args))) - (cond - ((not (and (real? unit) (< 0 unit 1))) - (error "unit must be real in (0,1)" unit)) - ((<= (- (/ 1 unit) 1) mrg32k3a-m1) - (lambda () - (mrg32k3a-random-real state))) - (else - (lambda () - (mrg32k3a-random-real-mp state unit)))))) - (else - (error "illegal arguments" args))))))) - -(define random-source? - \:random-source?) - -(define (random-source-state-ref s) - ((\:random-source-state-ref s))) - -(define (random-source-state-set! s state) - ((\:random-source-state-set! s) state)) - -(define (random-source-randomize! s) - ((\:random-source-randomize! s))) - -(define (random-source-pseudo-randomize! s i j) - ((\:random-source-pseudo-randomize! s) i j)) - -; --- - -(define (random-source-make-integers s) - ((\:random-source-make-integers s))) - -(define (random-source-make-reals s . unit) - (apply (\:random-source-make-reals s) unit)) - -; --- - -(define default-random-source - (make-random-source)) - -(define random-integer - (random-source-make-integers default-random-source)) - -(define random-real - (random-source-make-reals default-random-source)) -(define-library (srfi 27) - (export - random-integer - random-real - default-random-source - make-random-source - random-source? - random-source-state-ref - random-source-state-set! - random-source-randomize! - random-source-pseudo-randomize! - random-source-make-integers - random-source-make-reals - ) - (import - (scheme base) - (scheme time)) - (begin - - (define-record-type \:random-source - (\\:random-source-make - state-ref - state-set! - randomize! - pseudo-randomize! - make-integers - make-reals) - \:random-source? - (state-ref \:random-source-state-ref) - (state-set! \:random-source-state-set!) - (randomize! \:random-source-randomize!) - (pseudo-randomize! \:random-source-pseudo-randomize!) - (make-integers \:random-source-make-integers) - (make-reals \:random-source-make-reals)) - - (define (\\:random-source-current-time) - (current-jiffy)) - - (define exact->inexact inexact) - - ) - (include "27.mrg32k3a-a.upstream.scm") - (include "27.mrg32k3a.upstream.scm")) -;; Copyright (C) Scott G. Miller (2002). All Rights Reserved. - -;; Made an R7RS library by Taylan Ulrich Bayırlı/Kammer, Copyright (C) 2014. - -;; Permission is hereby granted, free of charge, to any person obtaining a copy -;; of this software and associated documentation files (the "Software"), to deal -;; in the Software without restriction, including without limitation the rights -;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;; copies of the Software, and to permit persons to whom the Software is -;; furnished to do so, subject to the following conditions: - -;; The above copyright notice and this permission notice shall be included in -;; all copies or substantial portions of the Software. - -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -;; SOFTWARE. - -(define-library (srfi 28) - (export format) - (import - (scheme base) - (scheme write)) - (begin - (define format - (lambda (format-string . objects) - (let ((buffer (open-output-string))) - (let loop ((format-list (string->list format-string)) - (objects objects)) - (cond ((null? format-list) (get-output-string buffer)) - ((char=? (car format-list) #\~) - (if (null? (cdr format-list)) - (error 'format "Incomplete escape sequence") - (case (cadr format-list) - ((#\a) - (if (null? objects) - (error 'format "No value for escape sequence") - (begin - (display (car objects) buffer) - (loop (cddr format-list) (cdr objects))))) - ((#\s) - (if (null? objects) - (error 'format "No value for escape sequence") - (begin - (write (car objects) buffer) - (loop (cddr format-list) (cdr objects))))) - ((#\%) - (newline buffer) - (loop (cddr format-list) objects)) - ((#\~) - (write-char #\~ buffer) - (loop (cddr format-list) objects)) - (else - (error 'format "Unrecognized escape sequence"))))) - (else (write-char (car format-list) buffer) - (loop (cdr format-list) objects))))))))) -;; Copyright (C) Taylan Ulrich Bayırlı/Kammer (2015). All Rights Reserved. - -;; Permission is hereby granted, free of charge, to any person obtaining -;; a copy of this software and associated documentation files (the -;; "Software"), to deal in the Software without restriction, including -;; without limitation the rights to use, copy, modify, merge, publish, -;; distribute, sublicense, and/or sell copies of the Software, and to -;; permit persons to whom the Software is furnished to do so, subject to -;; the following conditions: - -;; The above copyright notice and this permission notice shall be -;; included in all copies or substantial portions of the Software. - -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE -;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION -;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION -;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -(define-library (srfi 31) - (export rec) - (import (scheme base)) - (begin - (define-syntax rec - (syntax-rules () - ((rec (name . args) body ...) - (letrec ((name (lambda args body ...))) - name)) - ((rec name expr) - (letrec ((name expr)) - name)))))) -;; Copyright (C) Richard Kelsey, Michael Sperber (2002). All Rights Reserved. -;; -;; Permission is hereby granted, free of charge, to any person obtaining a copy -;; of this software and associated documentation files (the "Software"), to deal -;; in the Software without restriction, including without limitation the rights -;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;; copies of the Software, and to permit persons to whom the Software is -;; furnished to do so, subject to the following conditions: -;; -;; The above copyright notice and this permission notice shall be included in -;; all copies or substantial portions of the Software. -;; -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -;; SOFTWARE. - -(define-record-type - (really-make-condition-type name supertype fields all-fields) - condition-type? - (name condition-type-name) - (supertype condition-type-supertype) - (fields condition-type-fields) - (all-fields condition-type-all-fields)) - -(define (make-condition-type name supertype fields) - (if (not (symbol? name)) - (error "make-condition-type: name is not a symbol" - name)) - (if (not (condition-type? supertype)) - (error "make-condition-type: supertype is not a condition type" - supertype)) - (if (not - (null? (lset-intersection eq? - (condition-type-all-fields supertype) - fields))) - (error "duplicate field name" )) - (really-make-condition-type name - supertype - fields - (append (condition-type-all-fields supertype) - fields))) - -(define-syntax define-condition-type - (syntax-rules () - ((define-condition-type ?name ?supertype ?predicate - (?field1 ?accessor1) ...) - (begin - (define ?name - (make-condition-type '?name - ?supertype - '(?field1 ...))) - (define (?predicate thing) - (and (condition? thing) - (condition-has-type? thing ?name))) - (define (?accessor1 condition) - (condition-ref (extract-condition condition ?name) - '?field1)) - ...)))) - -(define (condition-subtype? subtype supertype) - (let recur ((subtype subtype)) - (cond ((not subtype) #f) - ((eq? subtype supertype) #t) - (else - (recur (condition-type-supertype subtype)))))) - -(define (condition-type-field-supertype condition-type field) - (let loop ((condition-type condition-type)) - (cond ((not condition-type) #f) - ((memq field (condition-type-fields condition-type)) - condition-type) - (else - (loop (condition-type-supertype condition-type)))))) - -; The type-field-alist is of the form -; (( ( . ) ...) ...) -(define-record-type - (really-make-condition type-field-alist) - condition? - (type-field-alist condition-type-field-alist)) - -(define (make-condition type . field-plist) - (let ((alist (let label ((plist field-plist)) - (if (null? plist) - '() - (cons (cons (car plist) - (cadr plist)) - (label (cddr plist))))))) - (if (not (lset= eq? - (condition-type-all-fields type) - (map car alist))) - (error "condition fields don't match condition type")) - (really-make-condition (list (cons type alist))))) - -(define (condition-has-type? condition type) - (any (lambda (has-type) - (condition-subtype? has-type type)) - (condition-types condition))) - -(define (condition-ref condition field) - (type-field-alist-ref (condition-type-field-alist condition) - field)) - -(define (type-field-alist-ref type-field-alist field) - (let loop ((type-field-alist type-field-alist)) - (cond ((null? type-field-alist) - (error "type-field-alist-ref: field not found" - type-field-alist field)) - ((assq field (cdr (car type-field-alist))) - => cdr) - (else - (loop (cdr type-field-alist)))))) - -(define (make-compound-condition condition-1 . conditions) - (really-make-condition - (apply append (map condition-type-field-alist - (cons condition-1 conditions))))) - -(define (extract-condition condition type) - (let ((entry (find (lambda (entry) - (condition-subtype? (car entry) type)) - (condition-type-field-alist condition)))) - (if (not entry) - (error "extract-condition: invalid condition type" - condition type)) - (really-make-condition - (list (cons type - (map (lambda (field) - (assq field (cdr entry))) - (condition-type-all-fields type))))))) - -(define-syntax condition - (syntax-rules () - ((condition (?type1 (?field1 ?value1) ...) ...) - (type-field-alist->condition - (list - (cons ?type1 - (list (cons '?field1 ?value1) ...)) - ...))))) - -(define (type-field-alist->condition type-field-alist) - (really-make-condition - (map (lambda (entry) - (cons (car entry) - (map (lambda (field) - (or (assq field (cdr entry)) - (cons field - (type-field-alist-ref type-field-alist field)))) - (condition-type-all-fields (car entry))))) - type-field-alist))) - -(define (condition-types condition) - (map car (condition-type-field-alist condition))) - -(define (check-condition-type-field-alist the-type-field-alist) - (let loop ((type-field-alist the-type-field-alist)) - (if (not (null? type-field-alist)) - (let* ((entry (car type-field-alist)) - (type (car entry)) - (field-alist (cdr entry)) - (fields (map car field-alist)) - (all-fields (condition-type-all-fields type))) - (for-each (lambda (missing-field) - (let ((supertype - (condition-type-field-supertype type missing-field))) - (if (not - (any (lambda (entry) - (let ((type (car entry))) - (condition-subtype? type supertype))) - the-type-field-alist)) - (error "missing field in condition construction" - type - missing-field)))) - (lset-difference eq? all-fields fields)) - (loop (cdr type-field-alist)))))) - -(define &condition (really-make-condition-type '&condition - #f - '() - '())) - -(define-condition-type &message &condition - message-condition? - (message condition-message)) - -(define-condition-type &serious &condition - serious-condition?) - -(define-condition-type &error &serious - error?) -(define-library (srfi 35) - (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 - &serious - &error - ) - (import - (scheme base) - (srfi 1)) - (include "35.body.scm")) -(define-library (srfi 64) - (import - (srfi 64 test-runner) - (srfi 64 test-runner-simple) - (srfi 64 execution)) - (export - ;; Execution - test-begin test-end test-group test-group-with-cleanup - - test-skip test-expect-fail - test-match-name test-match-nth - test-match-all test-match-any - - test-assert test-eqv test-eq test-equal test-approximate - test-error test-read-eval-string - - test-apply test-with-runner - - test-exit - - ;; Test runner - test-runner-null test-runner? test-runner-reset - - test-result-alist test-result-alist! - test-result-ref test-result-set! - test-result-remove test-result-clear - - test-runner-pass-count - test-runner-fail-count - test-runner-xpass-count - test-runner-xfail-count - test-runner-skip-count - - test-runner-test-name - - test-runner-group-path - test-runner-group-stack - - test-runner-aux-value test-runner-aux-value! - - test-result-kind test-passed? - - test-runner-on-test-begin test-runner-on-test-begin! - test-runner-on-test-end test-runner-on-test-end! - test-runner-on-group-begin test-runner-on-group-begin! - test-runner-on-group-end test-runner-on-group-end! - test-runner-on-final test-runner-on-final! - test-runner-on-bad-count test-runner-on-bad-count! - test-runner-on-bad-end-name test-runner-on-bad-end-name! - - test-runner-factory test-runner-create - test-runner-current test-runner-get - - ;; Simple test runner - test-runner-simple - test-on-group-begin-simple test-on-group-end-simple test-on-final-simple - test-on-test-begin-simple test-on-test-end-simple - test-on-bad-count-simple test-on-bad-end-name-simple - )) -;; Copyright (C) Richard Kelsey, Michael Sperber (2002). All Rights Reserved. -;; -;; Permission is hereby granted, free of charge, to any person obtaining a copy -;; of this software and associated documentation files (the "Software"), to deal -;; in the Software without restriction, including without limitation the rights -;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;; copies of the Software, and to permit persons to whom the Software is -;; furnished to do so, subject to the following conditions: -;; -;; The above copyright notice and this permission notice shall be included in -;; all copies or substantial portions of the Software. -;; -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -;; SOFTWARE. - -(define-record-type condition-type - (really-make-condition-type name supertype fields all-fields) - condition-type? - (name condition-type-name) - (supertype condition-type-supertype) - (fields condition-type-fields) - (all-fields condition-type-all-fields)) - -(define (make-condition-type name supertype fields) - (if (not (symbol? name)) - (error "make-condition-type: name is not a symbol" - name)) - (if (not (condition-type? supertype)) - (error "make-condition-type: supertype is not a condition type" - supertype)) - (if (not - (null? (lset-intersection eq? - (condition-type-all-fields supertype) - fields))) - (error "duplicate field name" )) - (really-make-condition-type name - supertype - fields - (append (condition-type-all-fields supertype) - fields))) - -(define-syntax define-condition-type - (syntax-rules () - ((define-condition-type ?name ?supertype ?predicate - (?field1 ?accessor1) ...) - (begin - (define ?name - (make-condition-type '?name - ?supertype - '(?field1 ...))) - (define (?predicate thing) - (and (condition? thing) - (condition-has-type? thing ?name))) - (define (?accessor1 condition) - (condition-ref (extract-condition condition ?name) - '?field1)) - ...)))) - -(define (condition-subtype? subtype supertype) - (let recur ((subtype subtype)) - (cond ((not subtype) #f) - ((eq? subtype supertype) #t) - (else - (recur (condition-type-supertype subtype)))))) - -(define (condition-type-field-supertype condition-type field) - (let loop ((condition-type condition-type)) - (cond ((not condition-type) #f) - ((memq field (condition-type-fields condition-type)) - condition-type) - (else - (loop (condition-type-supertype condition-type)))))) - -; The type-field-alist is of the form -; (( ( . ) ...) ...) -(define-record-type condition - (really-make-condition type-field-alist) - condition? - (type-field-alist condition-type-field-alist)) - -(define (make-condition type . field-plist) - (let ((alist (let label ((plist field-plist)) - (if (null? plist) - '() - (cons (cons (car plist) - (cadr plist)) - (label (cddr plist))))))) - (if (not (lset= eq? - (condition-type-all-fields type) - (map car alist))) - (error "condition fields don't match condition type")) - (really-make-condition (list (cons type alist))))) - -(define (condition-has-type? condition type) - (any (lambda (has-type) - (condition-subtype? has-type type)) - (condition-types condition))) - -(define (condition-ref condition field) - (type-field-alist-ref (condition-type-field-alist condition) - field)) - -(define (type-field-alist-ref type-field-alist field) - (let loop ((type-field-alist type-field-alist)) - (cond ((null? type-field-alist) - (error "type-field-alist-ref: field not found" - type-field-alist field)) - ((assq field (cdr (car type-field-alist))) - => cdr) - (else - (loop (cdr type-field-alist)))))) - -(define (make-compound-condition condition-1 . conditions) - (really-make-condition - (apply append (map condition-type-field-alist - (cons condition-1 conditions))))) - -(define (extract-condition condition type) - (let ((entry (find (lambda (entry) - (condition-subtype? (car entry) type)) - (condition-type-field-alist condition)))) - (if (not entry) - (error "extract-condition: invalid condition type" - condition type)) - (really-make-condition - (list (cons type - (map (lambda (field) - (assq field (cdr entry))) - (condition-type-all-fields type))))))) - -(define-syntax condition - (syntax-rules () - ((condition (?type1 (?field1 ?value1) ...) ...) - (type-field-alist->condition - (list - (cons ?type1 - (list (cons '?field1 ?value1) ...)) - ...))))) - -(define (type-field-alist->condition type-field-alist) - (really-make-condition - (map (lambda (entry) - (cons (car entry) - (map (lambda (field) - (or (assq field (cdr entry)) - (cons field - (type-field-alist-ref type-field-alist field)))) - (condition-type-all-fields (car entry))))) - type-field-alist))) - -(define (condition-types condition) - (map car (condition-type-field-alist condition))) - -(define (check-condition-type-field-alist the-type-field-alist) - (let loop ((type-field-alist the-type-field-alist)) - (if (not (null? type-field-alist)) - (let* ((entry (car type-field-alist)) - (type (car entry)) - (field-alist (cdr entry)) - (fields (map car field-alist)) - (all-fields (condition-type-all-fields type))) - (for-each (lambda (missing-field) - (let ((supertype - (condition-type-field-supertype type missing-field))) - (if (not - (any (lambda (entry) - (let ((type (car entry))) - (condition-subtype? type supertype))) - the-type-field-alist)) - (error "missing field in condition construction" - type - missing-field)))) - (lset-difference eq? all-fields fields)) - (loop (cdr type-field-alist)))))) - -(define &condition (really-make-condition-type '&condition - #f - '() - '())) - -(define-condition-type &message &condition - message-condition? - (message condition-message)) - -(define-condition-type &serious &condition - serious-condition?) - -(define-condition-type &error &serious - error?) -;;; args-fold.scm - a program argument processor -;;; -;;; Copyright (c) 2002 Anthony Carrico -;;; Copyright (c) 2014 Taylan Ulrich Bayırlı/Kammer -;;; -;;; All rights reserved. -;;; -;;; Redistribution and use in source and binary forms, with or without -;;; modification, are permitted provided that the following conditions -;;; are met: -;;; 1. Redistributions of source code must retain the above copyright -;;; notice, this list of conditions and the following disclaimer. -;;; 2. Redistributions in binary form must reproduce the above copyright -;;; notice, this list of conditions and the following disclaimer in the -;;; documentation and/or other materials provided with the distribution. -;;; 3. The name of the authors may not be used to endorse or promote products -;;; derived from this software without specific prior written permission. -;;; -;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR -;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES -;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. -;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, -;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT -;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF -;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(define-record-type