From 4922f3a4437f7ea8495f32aea0aa329830bd2d8b Mon Sep 17 00:00:00 2001 From: Taylan Kammer Date: Sun, 30 Mar 2025 20:10:10 +0200 Subject: moar cleanup --- src/main.zig | 2 +- src/test/all.zig | 8 + src/test/bench.zig | 15 + src/test/data/parser-test-1.scm | 197 + src/test/data/parser-test-2.scm | 19 + src/test/data/parser-torture.scm | 132358 ++++++++++++++++++++++++++++++++++++ src/test/data/string.txt | 1 + src/test/parse.zig | 162 + src/test/strings.zig | 30 + src/test/values.zig | 247 + src/zisp.zig | 428 +- src/zisp/io/Parser.zig | 27 +- src/zisp/io/unparser.zig | 7 +- src/zisp/lib/list.zig | 4 +- src/zisp/value.zig | 12 +- src/zisp/value/boole.zig | 11 +- src/zisp/value/eof.zig | 28 - src/zisp/value/misc.zig | 23 + src/zisp/value/nil.zig | 28 - src/zisp/value/ptr.zig | 2 +- test-data/parser-test-1.scm | 197 - test-data/parser-test-2.scm | 19 - test-data/parser-torture.scm | 132358 ------------------------------------ test-data/string.txt | 1 - 24 files changed, 133098 insertions(+), 133086 deletions(-) create mode 100644 src/test/all.zig create mode 100644 src/test/bench.zig create mode 100644 src/test/data/parser-test-1.scm create mode 100644 src/test/data/parser-test-2.scm create mode 100644 src/test/data/parser-torture.scm create mode 100644 src/test/data/string.txt create mode 100644 src/test/parse.zig create mode 100644 src/test/strings.zig create mode 100644 src/test/values.zig delete mode 100644 src/zisp/value/eof.zig create mode 100644 src/zisp/value/misc.zig delete mode 100644 src/zisp/value/nil.zig delete mode 100644 test-data/parser-test-1.scm delete mode 100644 test-data/parser-test-2.scm delete mode 100644 test-data/parser-torture.scm delete mode 100644 test-data/string.txt diff --git a/src/main.zig b/src/main.zig index 769a906..9e86d03 100644 --- a/src/main.zig +++ b/src/main.zig @@ -8,7 +8,7 @@ pub fn main() !void { while (true) { try writer.writeAll("> "); const datum = zisp.io.parser.parse(reader); - if (datum.eq(zisp.value.eof.eof)) { + if (datum.eq(zisp.value.eof)) { try writer.writeAll("\n"); return; } diff --git a/src/test/all.zig b/src/test/all.zig new file mode 100644 index 0000000..d985f46 --- /dev/null +++ b/src/test/all.zig @@ -0,0 +1,8 @@ +pub const values = @import("values.zig"); +pub const strings = @import("strings.zig"); + +pub const parse = @import("parse.zig"); + +test { + @import("std").testing.refAllDecls(@This()); +} diff --git a/src/test/bench.zig b/src/test/bench.zig new file mode 100644 index 0000000..a6203a3 --- /dev/null +++ b/src/test/bench.zig @@ -0,0 +1,15 @@ +const std = @import("std"); + +fn benchmark(name: []const u8, iters: usize, func: fn () anyerror!void) !void { + var timer = try std.time.Timer.start(); + for (0..iters) |i| { + _ = i; + try func(); + } + const ns: f64 = @floatFromInt(timer.lap()); + const secs = ns / 1_000_000_000; + std.debug.print( + "bench {s} x {}: {d:.3}s\n", + .{ name, iters, secs }, + ); +} diff --git a/src/test/data/parser-test-1.scm b/src/test/data/parser-test-1.scm new file mode 100644 index 0000000..87c41b5 --- /dev/null +++ b/src/test/data/parser-test-1.scm @@ -0,0 +1,197 @@ +;;; 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 + +(drt + (%mkbsd size align unwrap getter setter meta) + bsd? + (size bsize) + (align balign) + (unwrap bunwrp) + (getter bgettr) + (setter bsettr) + (meta bmeta)) + +(define mkbsd + (clmbda + ((size align unwrap getter setter) + (%mkbsd + size align unwrap getter setter #f)) + ((size align unwrap getter setter meta) + (%mkbsd + size align unwrap getter setter meta)))) + +(define bdsz + (clmbda + ((dscr) (bdsz dscr #f #f)) + ((dscr bvec offset) + (let ((size (bsize dscr))) + (if (proc? size) + (size #f bvec offset) + size))))) + +(define (bdsz/s bvec offset dscr) + (let ((size (bsize dscr))) + (if (proc? size) + (size #t bvec offset) + size))) + + +;;; Bstrs + +(drt + (mkbstr bvec offset dscr) + bstr? + (bvec bsbvec) + (offset bsofst) + (dscr bsdscr)) + +(define bstr + (clmbda ((dscr) (%bstr dscr #f #f)) + ((dscr values) (%bstr dscr #t values)))) + +(define (%bstr dscr init? values) + (let ((bvec (mkbvec + (bdsz dscr)))) + (when init? + (bspst! bvec 0 dscr values)) + (mkbstr bvec 0 dscr))) + +(define (bssize bstr) + (bdsz (bsdscr bstr) + (bsbvec bstr) + (bsofst bstr))) + +(dsr (bsunwp ...) + (let ((bstr )) + (let ((bvec (bsbvec bstr)) + (offset (bsofst bstr)) + (dscr (bsdscr bstr))) + (bsunwp bvec offset dscr ...)))) + +(defsyn bsnwp* + (synrul () + ((_ ) + (values )) + ((_ ...) + (let ((bvec ) + (offset ) + (dscr )) + (let ((unwrap (bunwrp dscr))) + (when (not unwrap) + (error "cannot" dscr)) + (letvls (((bvec* ofst* dscr*) + (unwrap #f bvec offset ))) + (bsnwp* + bvec* ofst* dscr* ...))))))) + +(defsyr (bsref ...) + (letvls (((bvec offset dscr) + (bsunwp ...))) + (bspref bvec offset dscr))) + +(defsyr (bsref* + ...) + (letvls (((bvec offset dscr) + (bsnwp* + ...))) + (bspref bvec offset dscr))) + +(define (bspref bvec offset dscr) + (let ((getter (bdgtr dscr))) + (if getter + (getter #f bvec offset) + (mkbstr bvec offset dscr)))) + +(defsyr (bsst! ... ) + (letvls (((bvec offset dscr) + (bsunwp ...))) + (bsps! bvec offset dscr ))) + +(defsyr (bsst!* + ... ) + (letvls (((bvec offset dscr) + (bsnwp* + ...))) + (bspst! bvec offset dscr ))) + +(define (bspst! bvec offset dscr value) + (let ((setter (bdstr dscr))) + (if setter + (setter #f bvec offset value) + (if (bvec? value) + (bvecop bvec offset value 0 + (bdsz + dscr bvec offset)) + (error "cannot" + value dscr))))) + +(define (bsrf/d bstr . indxs) + (letvls (((bvec offset dscr) + (bsunwp bstr))) + (let loop ((bvec bvec) + (offset offset) + (dscr dscr) + (indxs indxs)) + (if (null? indxs) + (bspref bvec offset dscr) + (letvls (((bvec* ofst* dscr*) + (bsnwp* + bvec offset dscr (car indxs)))) + (loop bvec* + ofst* + dscr* + (cdr indxs))))))) + +(define (bst!/d bstr . args) + (letvls (((bvec offset dscr) + (bsunwp bstr))) + (let loop ((bvec bvec) + (offset offset) + (dscr dscr) + (args args)) + (if (null? (cdr args)) + (bset! bvec offset dscr (car args)) + (letvls (((bvec* ofst* dscr*) + (bsnwp* + bvec offset dscr (car args)))) + (loop bvec* + ofst* + dscr* + (cdr args))))))) + +(defsyn + bnwp/s + bref/s + bset/s + dba) + +(cexp + (guile (incfp "bstrs")) + (syncas (incld "base")) + (else)) + +;;; base.scm ends here diff --git a/src/test/data/parser-test-2.scm b/src/test/data/parser-test-2.scm new file mode 100644 index 0000000..484c61e --- /dev/null +++ b/src/test/data/parser-test-2.scm @@ -0,0 +1,19 @@ +(a b c + (x y z + (a b c + (x y z + (a b c + (x y z + (a b c + (x y z + (a b c + (x y z + (a b c + (x y z + (a b c + (x y z + (a b c + (x y z + (a b c + (x y z + (a b c))))))))))))))))))) diff --git a/src/test/data/parser-torture.scm b/src/test/data/parser-torture.scm new file mode 100644 index 0000000..d475379 --- /dev/null +++ b/src/test/data/parser-torture.scm @@ -0,0 +1,132358 @@ +;;; 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