mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
0bd7497b61
* module/rnrs/base.scm (vector-map vector-for-each): Rewrite to not be slow. * NEWS: Update.
362 lines
12 KiB
Scheme
362 lines
12 KiB
Scheme
;;; base.scm --- The R6RS base library
|
||
|
||
;; Copyright (C) 2010, 2011, 2019, 2021 Free Software Foundation, Inc.
|
||
;;
|
||
;; This library is free software; you can redistribute it and/or
|
||
;; modify it under the terms of the GNU Lesser General Public
|
||
;; License as published by the Free Software Foundation; either
|
||
;; version 3 of the License, or (at your option) any later version.
|
||
;;
|
||
;; This library 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
|
||
;; Lesser General Public License for more details.
|
||
;;
|
||
;; You should have received a copy of the GNU Lesser General Public
|
||
;; License along with this library; if not, write to the Free Software
|
||
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||
|
||
|
||
(library (rnrs base (6))
|
||
(export boolean? symbol? char? vector? null? pair? number? string? procedure?
|
||
|
||
define define-syntax syntax-rules lambda let let* let-values
|
||
let*-values letrec letrec* begin
|
||
|
||
quote lambda if set! cond case else => _ ...
|
||
|
||
or and not
|
||
|
||
eqv? equal? eq?
|
||
|
||
+ - * / max min abs numerator denominator gcd lcm floor ceiling
|
||
truncate round rationalize real-part imag-part make-rectangular angle
|
||
div mod div-and-mod div0 mod0 div0-and-mod0
|
||
|
||
expt exact-integer-sqrt sqrt exp log sin cos tan asin acos atan
|
||
make-polar magnitude angle
|
||
|
||
complex? real? rational? integer? exact? inexact? real-valued?
|
||
rational-valued? integer-valued? zero? positive? negative? odd? even?
|
||
nan? finite? infinite?
|
||
|
||
exact inexact = < > <= >=
|
||
|
||
number->string string->number
|
||
|
||
boolean=?
|
||
|
||
cons car cdr caar cadr cdar cddr caaar caadr cadar cdaar caddr cdadr
|
||
cddar cdddr caaaar caaadr caadar cadaar cdaaar cddaar cdadar cdaadr
|
||
cadadr caaddr caddar cadddr cdaddr cddadr cdddar cddddr
|
||
|
||
list? list length append reverse list-tail list-ref map for-each
|
||
|
||
symbol->string string->symbol symbol=?
|
||
|
||
char->integer integer->char char=? char<? char>? char<=? char>=?
|
||
|
||
make-string string string-length string-ref string=? string<? string>?
|
||
string<=? string>=? substring string-append string->list list->string
|
||
string-for-each string-copy
|
||
|
||
vector? make-vector vector vector-length vector-ref vector-set!
|
||
vector->list list->vector vector-fill! vector-map vector-for-each
|
||
|
||
error assertion-violation assert
|
||
|
||
call-with-current-continuation call/cc call-with-values dynamic-wind
|
||
values apply
|
||
|
||
quasiquote unquote unquote-splicing
|
||
|
||
let-syntax letrec-syntax
|
||
|
||
syntax-rules identifier-syntax)
|
||
(import (rename (except (guile) error raise map string-for-each)
|
||
(log log-internal)
|
||
(euclidean-quotient div)
|
||
(euclidean-remainder mod)
|
||
(euclidean/ div-and-mod)
|
||
(centered-quotient div0)
|
||
(centered-remainder mod0)
|
||
(centered/ div0-and-mod0)
|
||
(inf? infinite?)
|
||
(exact->inexact inexact)
|
||
(inexact->exact exact))
|
||
(srfi srfi-11))
|
||
|
||
(define string-for-each
|
||
(case-lambda
|
||
((proc string)
|
||
(let ((end (string-length string)))
|
||
(let loop ((i 0))
|
||
(unless (= i end)
|
||
(proc (string-ref string i))
|
||
(loop (+ i 1))))))
|
||
((proc string1 string2)
|
||
(let ((end1 (string-length string1))
|
||
(end2 (string-length string2)))
|
||
(unless (= end1 end2)
|
||
(assertion-violation 'string-for-each
|
||
"string arguments must all have the same length"
|
||
string1 string2))
|
||
(let loop ((i 0))
|
||
(unless (= i end1)
|
||
(proc (string-ref string1 i)
|
||
(string-ref string2 i))
|
||
(loop (+ i 1))))))
|
||
((proc string . strings)
|
||
(let ((end (string-length string))
|
||
(ends (map string-length strings)))
|
||
(for-each (lambda (x)
|
||
(unless (= end x)
|
||
(apply assertion-violation
|
||
'string-for-each
|
||
"string arguments must all have the same length"
|
||
string strings)))
|
||
ends)
|
||
(let loop ((i 0))
|
||
(unless (= i end)
|
||
(apply proc
|
||
(string-ref string i)
|
||
(map (lambda (s) (string-ref s i)) strings))
|
||
(loop (+ i 1))))))))
|
||
|
||
(define map
|
||
(case-lambda
|
||
((f l)
|
||
(let map1 ((hare l) (tortoise l) (move? #f) (out '()))
|
||
(if (pair? hare)
|
||
(if move?
|
||
(if (eq? tortoise hare)
|
||
(scm-error 'wrong-type-arg "map" "Circular list: ~S"
|
||
(list l) #f)
|
||
(map1 (cdr hare) (cdr tortoise) #f
|
||
(cons (f (car hare)) out)))
|
||
(map1 (cdr hare) tortoise #t
|
||
(cons (f (car hare)) out)))
|
||
(if (null? hare)
|
||
(reverse out)
|
||
(scm-error 'wrong-type-arg "map" "Not a list: ~S"
|
||
(list l) #f)))))
|
||
|
||
((f l1 l2)
|
||
(let map2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f) (out '()))
|
||
(cond
|
||
((pair? h1)
|
||
(cond
|
||
((not (pair? h2))
|
||
(scm-error 'wrong-type-arg "map"
|
||
(if (list? h2)
|
||
"List of wrong length: ~S"
|
||
"Not a list: ~S")
|
||
(list l2) #f))
|
||
((not move?)
|
||
(map2 (cdr h1) (cdr h2) t1 t2 #t
|
||
(cons (f (car h1) (car h2)) out)))
|
||
((eq? t1 h1)
|
||
(scm-error 'wrong-type-arg "map" "Circular list: ~S"
|
||
(list l1) #f))
|
||
((eq? t2 h2)
|
||
(scm-error 'wrong-type-arg "map" "Circular list: ~S"
|
||
(list l2) #f))
|
||
(else
|
||
(map2 (cdr h1) (cdr h2) (cdr t1) (cdr t2) #f
|
||
(cons (f (car h1) (car h2)) out)))))
|
||
|
||
((and (null? h1) (null? h2))
|
||
(reverse out))
|
||
|
||
((null? h1)
|
||
(scm-error 'wrong-type-arg "map"
|
||
(if (list? h2)
|
||
"List of wrong length: ~S"
|
||
"Not a list: ~S")
|
||
(list l2) #f))
|
||
(else
|
||
(scm-error 'wrong-type-arg "map"
|
||
"Not a list: ~S"
|
||
(list l1) #f)))))
|
||
|
||
((f l1 . rest)
|
||
(let ((len (length l1)))
|
||
(let mapn ((rest rest))
|
||
(or (null? rest)
|
||
(if (= (length (car rest)) len)
|
||
(mapn (cdr rest))
|
||
(scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
|
||
(list (car rest)) #f)))))
|
||
(let mapn ((l1 l1) (rest rest) (out '()))
|
||
(if (null? l1)
|
||
(reverse out)
|
||
(mapn (cdr l1) (map cdr rest)
|
||
(cons (apply f (car l1) (map car rest)) out)))))))
|
||
|
||
(define log
|
||
(case-lambda
|
||
((n)
|
||
(log-internal n))
|
||
((n base)
|
||
(/ (log n)
|
||
(log base)))))
|
||
|
||
(define (boolean=? . bools)
|
||
(define (boolean=?-internal lst last)
|
||
(or (null? lst)
|
||
(let ((bool (car lst)))
|
||
(and (eqv? bool last) (boolean=?-internal (cdr lst) bool)))))
|
||
(or (null? bools)
|
||
(let ((bool (car bools)))
|
||
(and (boolean? bool) (boolean=?-internal (cdr bools) bool)))))
|
||
|
||
(define (symbol=? . syms)
|
||
(define (symbol=?-internal lst last)
|
||
(or (null? lst)
|
||
(let ((sym (car lst)))
|
||
(and (eq? sym last) (symbol=?-internal (cdr lst) sym)))))
|
||
(or (null? syms)
|
||
(let ((sym (car syms)))
|
||
(and (symbol? sym) (symbol=?-internal (cdr syms) sym)))))
|
||
|
||
(define (real-valued? x)
|
||
(and (complex? x)
|
||
(zero? (imag-part x))))
|
||
|
||
(define (rational-valued? x)
|
||
(and (real-valued? x)
|
||
(rational? (real-part x))))
|
||
|
||
(define (integer-valued? x)
|
||
(and (rational-valued? x)
|
||
(= x (floor (real-part x)))))
|
||
|
||
;; Auxiliary procedure for vector-map and vector-for-each
|
||
(define (vector-lengths who vs)
|
||
(let ((lengths (map vector-length vs)))
|
||
(unless (apply = lengths)
|
||
(error (string-append (symbol->string who)
|
||
": Vectors of uneven length.")
|
||
vs))
|
||
(car lengths)))
|
||
|
||
(define vector-map
|
||
(case-lambda
|
||
"(vector-map f vec2 vec2 ...) -> vector
|
||
|
||
Return a new vector of the size of the vector arguments, which must be
|
||
of equal length. Each element at index @var{i} of the new vector is
|
||
mapped from the old vectors by @code{(f (vector-ref vec1 i)
|
||
(vector-ref vec2 i) ...)}. The dynamic order of application of
|
||
@var{f} is unspecified."
|
||
((f v)
|
||
(let* ((len (vector-length v))
|
||
(result (make-vector len)))
|
||
(let loop ((i 0))
|
||
(unless (= i len)
|
||
(vector-set! result i (f (vector-ref v i)))
|
||
(loop (+ i 1))))
|
||
result))
|
||
((f v1 v2)
|
||
(let* ((len (vector-lengths 'vector-map (list v1 v2)))
|
||
(result (make-vector len)))
|
||
(let loop ((i 0))
|
||
(unless (= i len)
|
||
(vector-set! result
|
||
i
|
||
(f (vector-ref v1 i) (vector-ref v2 i)))
|
||
(loop (+ i 1)))
|
||
result)))
|
||
((f v . vs)
|
||
(let* ((vs (cons v vs))
|
||
(len (vector-lengths 'vector-map vs))
|
||
(result (make-vector len)))
|
||
(let loop ((i 0))
|
||
(unless (= i len)
|
||
(vector-set! result
|
||
i
|
||
(apply f (map (lambda (v) (vector-ref v i)) vs)))
|
||
(loop (+ i 1))))
|
||
result))))
|
||
|
||
(define vector-for-each
|
||
(case-lambda
|
||
"(vector-for-each f vec1 vec2 ...) -> unspecified
|
||
|
||
Call @code{(f (vector-ref vec1 i) (vector-ref vec2 i) ...)} for each index
|
||
in the provided vectors, which have to be of equal length. The iteration
|
||
is strictly left-to-right."
|
||
((f v)
|
||
(let ((len (vector-length v)))
|
||
(let loop ((i 0))
|
||
(unless (= i len)
|
||
(f (vector-ref v i))
|
||
(loop (+ i 1))))))
|
||
((f v1 v2)
|
||
(let ((len (vector-lengths 'vector-for-each (list v1 v2))))
|
||
(let loop ((i 0))
|
||
(unless (= i len)
|
||
(f (vector-ref v1 i) (vector-ref v2 i))
|
||
(loop (+ i 1))))))
|
||
((f v . vs)
|
||
(let* ((vs (cons v vs))
|
||
(len (vector-lengths 'vector-for-each vs)))
|
||
(let loop ((i 0))
|
||
(unless (= i len)
|
||
(apply f (map (lambda (v) (vector-ref v i)) vs))
|
||
(loop (+ i 1))))))))
|
||
|
||
|
||
(define-syntax define-proxy
|
||
(syntax-rules (@)
|
||
;; Define BINDING to point to (@ MODULE ORIGINAL). This hack is to
|
||
;; make sure MODULE is loaded lazily, at run-time, when BINDING is
|
||
;; encountered, rather than being loaded while compiling and
|
||
;; loading (rnrs base).
|
||
;; This avoids circular dependencies among modules and makes
|
||
;; (rnrs base) more lightweight.
|
||
((_ binding (@ module original))
|
||
(define-syntax binding
|
||
(identifier-syntax
|
||
(module-ref (resolve-interface 'module) 'original))))))
|
||
|
||
(define-proxy raise
|
||
(@ (rnrs exceptions) raise))
|
||
|
||
(define-proxy condition
|
||
(@ (rnrs conditions) condition))
|
||
(define-proxy make-error
|
||
(@ (rnrs conditions) make-error))
|
||
(define-proxy make-assertion-violation
|
||
(@ (rnrs conditions) make-assertion-violation))
|
||
(define-proxy make-who-condition
|
||
(@ (rnrs conditions) make-who-condition))
|
||
(define-proxy make-message-condition
|
||
(@ (rnrs conditions) make-message-condition))
|
||
(define-proxy make-irritants-condition
|
||
(@ (rnrs conditions) make-irritants-condition))
|
||
|
||
(define (error who message . irritants)
|
||
(raise (apply condition
|
||
(append (list (make-error))
|
||
(if who (list (make-who-condition who)) '())
|
||
(list (make-message-condition message)
|
||
(make-irritants-condition irritants))))))
|
||
|
||
(define (assertion-violation who message . irritants)
|
||
(raise (apply condition
|
||
(append (list (make-assertion-violation))
|
||
(if who (list (make-who-condition who)) '())
|
||
(list (make-message-condition message)
|
||
(make-irritants-condition irritants))))))
|
||
|
||
(define-syntax assert
|
||
(syntax-rules ()
|
||
((_ expression)
|
||
(or expression
|
||
(raise (condition
|
||
(make-assertion-violation)
|
||
(make-message-condition
|
||
(format #f "assertion failed: ~s" 'expression))))))))
|
||
|
||
)
|