;;; 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