164 lines
6.5 KiB
Scheme
164 lines
6.5 KiB
Scheme
;;;
|
|
;;; <util.ss> ---- Utility functions
|
|
;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
|
|
;;;
|
|
;;; Copyright (C) 2005-2006 by Zhu Chongkai.
|
|
;;;
|
|
;;; This file is part of SRFI-43.
|
|
|
|
;;; SRFI-43 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 2.1 of the License, or (at your option) any later version.
|
|
|
|
;;; SRFI-43 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 SRFI-43; if not, write to the Free Software
|
|
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
|
|
|
;;; Author: Zhu Chongkai <mrmathematica@yahoo.com>
|
|
;;
|
|
;;
|
|
;; Commentary:
|
|
|
|
;; Based on the reference implementation by Taylor Campbell and hence:
|
|
|
|
;;; Copyright (C) 2003, 2004 Taylor Campbell.
|
|
;;; All rights reserved.
|
|
;;;
|
|
;;; You may do as you please with this code, as long as you refrain
|
|
;;; from removing this copyright notice or holding me liable in _any_
|
|
;;; circumstances for _any_ damages that may be caused by it; and you
|
|
;;; may quote sections from it as you please, as long as you credit me.
|
|
|
|
(module util mzscheme
|
|
|
|
(require (lib "etc.ss" "mzlib")
|
|
(lib "receive.ss" "srfi" "8"))
|
|
|
|
(provide (all-defined))
|
|
|
|
;;; (CHECK-INDEX <vector> <index> <callee>) ->
|
|
;;; Ensure that INDEX is a valid index into VECTOR; if not, signal an
|
|
;;; error stating that it is not and that this happened in a call to
|
|
;;; CALLEE. (Note that this does NOT check that VECTOR is indeed a
|
|
;;; vector.)
|
|
(define (check-index vec index callee)
|
|
(unless (nonneg-int? index)
|
|
(raise-type-error callee "non-negative exact integer" index))
|
|
(unless (and (<= 0 index)
|
|
(< index (vector-length vec)))
|
|
(raise
|
|
(make-exn:fail:contract
|
|
(format "~a: index ~a out of range for vector: ~a"
|
|
callee index vec)
|
|
(current-continuation-marks)))))
|
|
|
|
(define (check-indices vec maybe-start+end callee)
|
|
(if (null? maybe-start+end)
|
|
(values 0 (vector-length vec))
|
|
(let ((start (car maybe-start+end)))
|
|
(unless (nonneg-int? start)
|
|
(raise-type-error callee "non-negative exact integer" start))
|
|
(unless (<= 0 start (vector-length vec))
|
|
(raise
|
|
(make-exn:fail:contract
|
|
(format "~a: index ~a out of range for vector: ~a"
|
|
callee start vec)
|
|
(current-continuation-marks))))
|
|
(if (null? (cdr maybe-start+end))
|
|
(values start (vector-length vec))
|
|
(let ((end (cadr maybe-start+end)))
|
|
(unless (nonneg-int? end)
|
|
(raise-type-error callee "non-negative exact integer" end))
|
|
(unless (<= start end (vector-length vec))
|
|
(raise
|
|
(make-exn:fail:contract
|
|
(format "~a: indices (~a, ~a) out of range for vector: ~a"
|
|
callee start end vec))))
|
|
(values start end))))))
|
|
|
|
(define (nonneg-int? x)
|
|
(and (integer? x)
|
|
(exact? x)
|
|
(not (negative? x))))
|
|
|
|
;;; (%VECTOR-COPY! <target> <tstart> <source> <sstart> <send>)
|
|
;;; Copy elements at locations SSTART to SEND from SOURCE to TARGET,
|
|
;;; starting at TSTART in TARGET.
|
|
(define %vector-copy!
|
|
(letrec ((loop/l->r (lambda (target source send i j)
|
|
(cond ((< i send)
|
|
(vector-set! target j
|
|
(vector-ref source i))
|
|
(loop/l->r target source send
|
|
(add1 i) (add1 j))))))
|
|
(loop/r->l (lambda (target source sstart i j)
|
|
(cond ((>= i sstart)
|
|
(vector-set! target j
|
|
(vector-ref source i))
|
|
(loop/r->l target source sstart
|
|
(sub1 i) (sub1 j)))))))
|
|
(lambda (target tstart source sstart send)
|
|
(if (> sstart tstart) ; Make sure we don't copy over
|
|
; ourselves.
|
|
(loop/l->r target source send sstart tstart)
|
|
(loop/r->l target source sstart (sub1 send)
|
|
(+ -1 tstart send (- sstart)))))))
|
|
|
|
;;; (%VECTOR-REVERSE-COPY! <target> <tstart> <source> <sstart> <send>)
|
|
;;; Copy elements from SSTART to SEND from SOURCE to TARGET, in the
|
|
;;; reverse order.
|
|
(define %vector-reverse-copy!
|
|
(letrec ((loop (lambda (target source sstart i j)
|
|
(cond ((>= i sstart)
|
|
(vector-set! target j (vector-ref source i))
|
|
(loop target source sstart
|
|
(sub1 i)
|
|
(add1 j)))))))
|
|
(lambda (target tstart source sstart send)
|
|
(loop target source sstart
|
|
(sub1 send)
|
|
tstart))))
|
|
|
|
;; type-check : check whether list-of-vecs is list of VECTORs
|
|
(define check-list-of-vecs
|
|
(opt-lambda (list-of-vecs caller (n 0) (all-args list-of-vecs))
|
|
(let loop ((l list-of-vecs)
|
|
(i 0))
|
|
(unless (null? l)
|
|
(if (vector? (car l))
|
|
(loop (cdr l) (add1 i))
|
|
(apply raise-type-error
|
|
caller "vector"
|
|
(+ n i)
|
|
all-args))))))
|
|
|
|
;;; (%SMALLEST-LENGTH <vector-list> <default-length>)
|
|
;;; -> exact, nonnegative integer
|
|
;;; Compute the smallest length of VECTOR-LIST. DEFAULT-LENGTH is
|
|
;;; the length that is returned if VECTOR-LIST is empty. Common use
|
|
;;; of this is in n-ary vector routines:
|
|
;;; (define (f vec . vectors)
|
|
(define (%smallest-length vector-list length)
|
|
(if (null? vector-list)
|
|
length
|
|
(%smallest-length (cdr vector-list)
|
|
(min length
|
|
(vector-length (car vector-list))))))
|
|
|
|
(define (vectors-ref vectors i)
|
|
(map (lambda (v) (vector-ref v i)) vectors))
|
|
|
|
;;; from vector-unfold-right
|
|
(define (unfold1! f vec i seed)
|
|
(if (>= i 0)
|
|
(receive (elt new-seed)
|
|
(f i seed)
|
|
(vector-set! vec i elt)
|
|
(unfold1! f vec (sub1 i) new-seed)))))
|