suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Set all svn:eol-style to native for text files.

Browse Source 
svn: r5
This commit is contained in:
Eli Barzilay 2005-05-27 23:11:11 +00:00
parent e41b2fb359
commit 97ce56c612
14 changed files with 2091 additions and 2091 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
collects/icons/help16x16.xpm
View File

@ -1,23 +1,23 @@
/* XPM */
static char * mred[] = {
"16 16 4 1",
" c #000000",
". c #0000ff",
"X c #ffffff",
"o c #ff0000",
" ",
" .XXXX. ",
" ooXXXXXX.. ",
" ooXXXooXXX.. ",
" ooXXooooXX.. ",
" oooooooooXX... ",
" ooooooooXXX... ",
" oooooooXXX.... ",
" ooooooXXX..... ",
" ooooooXX...... ",
" ooooooXX...... ",
" oooooXX..... ",
" oooooo...... ",
" ooooXX.... ",
" ooXX.. ",
" "};
/* XPM */
static char * mred[] = {
"16 16 4 1",
" c #000000",
". c #0000ff",
"X c #ffffff",
"o c #ff0000",
" ",
" .XXXX. ",
" ooXXXXXX.. ",
" ooXXXooXXX.. ",
" ooXXooooXX.. ",
" oooooooooXX... ",
" ooooooooXXX... ",
" oooooooXXX.... ",
" ooooooXXX..... ",
" ooooooXX...... ",
" ooooooXX...... ",
" oooooXX..... ",
" oooooo...... ",
" ooooXX.... ",
" ooXX.. ",
" "};

78
collects/icons/help32x32.xpm
View File

@ -1,39 +1,39 @@
/* XPM */
static char * mred[] = {
"32 32 4 1",
" c #000000",
". c #ff0000",
"X c #0000ff",
"o c #ffffff",
" ",
" .. XX ",
" .. ooooooo XX ",
" .. ooooooooooo XXX ",
" .. ooooooooooooo XXX ",
" .. ooooooooooooooo XXX ",
" .. ooooo ooooo XXX ",
" ... oooo ....... oooo XXXX ",
" ... oooo ....... oooo XXXX ",
" .... oooo ....... oooo XXXXX ",
" ..... ........ oooo XXXXX ",
" ................. ooooo XXXXXX ",
" ................ oooooo XXXXXX ",
" ............... oooooo XXXXXXX ",
" .............. oooooo XXXXXXXX ",
" ............. oooooo XXXXXXXXX ",
" ............ oooooo XXXXXXXXXX ",
" ............ ooooo XXXXXXXXXXX ",
" ............ oooo XXXXXXXXXXXX ",
" ............ oooo XXXXXXXXXXXX ",
" ............ oooo XXXXXXXXXXXX ",
" ........... oooo XXXXXXXXXXX ",
" ............ oo XXXXXXXXXXXX ",
" ............ XXXXXXXXXXXX ",
" .............XXXXXXXXXXXXX ",
" ........... XXXXXXXXXXX ",
" ........ oo XXXXXXXX ",
" ...... oooooo XXXXXX ",
" .... oooooo XXXX ",
" .... oo XXXX ",
" .... XXXX ",
" "};
/* XPM */
static char * mred[] = {
"32 32 4 1",
" c #000000",
". c #ff0000",
"X c #0000ff",
"o c #ffffff",
" ",
" .. XX ",
" .. ooooooo XX ",
" .. ooooooooooo XXX ",
" .. ooooooooooooo XXX ",
" .. ooooooooooooooo XXX ",
" .. ooooo ooooo XXX ",
" ... oooo ....... oooo XXXX ",
" ... oooo ....... oooo XXXX ",
" .... oooo ....... oooo XXXXX ",
" ..... ........ oooo XXXXX ",
" ................. ooooo XXXXXX ",
" ................ oooooo XXXXXX ",
" ............... oooooo XXXXXXX ",
" .............. oooooo XXXXXXXX ",
" ............. oooooo XXXXXXXXX ",
" ............ oooooo XXXXXXXXXX ",
" ............ ooooo XXXXXXXXXXX ",
" ............ oooo XXXXXXXXXXXX ",
" ............ oooo XXXXXXXXXXXX ",
" ............ oooo XXXXXXXXXXXX ",
" ........... oooo XXXXXXXXXXX ",
" ............ oo XXXXXXXXXXXX ",
" ............ XXXXXXXXXXXX ",
" .............XXXXXXXXXXXXX ",
" ........... XXXXXXXXXXX ",
" ........ oo XXXXXXXX ",
" ...... oooooo XXXXXX ",
" .... oooooo XXXX ",
" .... oo XXXX ",
" .... XXXX ",
" "};

48
collects/plot/src/all/resource.h
View File

@ -1,24 +1,24 @@
//{{NO_DEPENDENCIES}}
// Microsoft Developer Studio generated include file.
// Used by plplot.rc
//
#define IDR_MENU1 101
#define IDI_ICON1 102
#define PLCOMMANDS 106
#define PLICON 107
#define CM_NEXTPLOT 40002
#define CM_PRINTPLOT 40003
#define CM_EDITCOPY 40004
#define CM_ABOUT 40005
// Next default values for new objects
//
#ifdef APSTUDIO_INVOKED
#ifndef APSTUDIO_READONLY_SYMBOLS
#define _APS_NO_MFC 1
#define _APS_NEXT_RESOURCE_VALUE 108
#define _APS_NEXT_COMMAND_VALUE 40006
#define _APS_NEXT_CONTROL_VALUE 1000
#define _APS_NEXT_SYMED_VALUE 101
#endif
#endif
//{{NO_DEPENDENCIES}}
// Microsoft Developer Studio generated include file.
// Used by plplot.rc
//
#define IDR_MENU1 101
#define IDI_ICON1 102
#define PLCOMMANDS 106
#define PLICON 107
#define CM_NEXTPLOT 40002
#define CM_PRINTPLOT 40003
#define CM_EDITCOPY 40004
#define CM_ABOUT 40005
// Next default values for new objects
//
#ifdef APSTUDIO_INVOKED
#ifndef APSTUDIO_READONLY_SYMBOLS
#define _APS_NO_MFC 1
#define _APS_NEXT_RESOURCE_VALUE 108
#define _APS_NEXT_COMMAND_VALUE 40006
#define _APS_NEXT_CONTROL_VALUE 1000
#define _APS_NEXT_SYMED_VALUE 101
#endif
#endif

436
collects/srfi/43/constructors.ss
View File

@ -1,218 +1,218 @@
;;;
;;; <constructors.ss> ---- Vector constructors
;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
;;;
;;; Copyright (C) 2005 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 constructors mzscheme
(require (lib "receive.ss" "srfi" "8")
"util.ss"
(lib "etc.ss" "mzlib"))
(provide vector-unfold
vector-unfold-right
vector-copy
vector-reverse-copy
vector-append
vector-concatenate)
;;; (VECTOR-UNFOLD <f> <length> <initial-seed> ...) -> vector
;;; (F <index> <seed> ...) -> [elt seed' ...]
;;; The fundamental vector constructor. Creates a vector whose
;;; length is LENGTH and iterates across each index K between 0 and
;;; LENGTH, applying F at each iteration to the current index and the
;;; current seeds to receive N+1 values: first, the element to put in
;;; the Kth slot and then N new seeds for the next iteration.
(define vector-unfold
(letrec ((tabulate! ; Special zero-seed case.
(lambda (f vec i len)
(cond ((< i len)
(vector-set! vec i (f i))
(tabulate! f vec (add1 i) len)))))
(unfold1! ; Fast path for one seed.
(lambda (f vec i len seed)
(if (< i len)
(receive (elt new-seed)
(f i seed)
(vector-set! vec i elt)
(unfold1! f vec (add1 i) len new-seed)))))
(unfold2+! ; Slower variant for N seeds.
(lambda (f vec i len seeds)
(if (< i len)
(receive (elt . new-seeds)
(apply f i seeds)
(vector-set! vec i elt)
(unfold2+! f vec (add1 i) len new-seeds))))))
(lambda (f len . initial-seeds)
(unless (procedure? f)
(apply raise-type-error
'vector-unfold "procedure" 0
f len initial-seeds))
(unless (nonneg-int? len)
(apply raise-type-error
'vector-unfold "non-negative exact integer" 1
f len initial-seeds))
(let ((vec (make-vector len)))
(cond ((null? initial-seeds)
(tabulate! f vec 0 len))
((null? (cdr initial-seeds))
(unfold1! f vec 0 len (car initial-seeds)))
(else
(unfold2+! f vec 0 len initial-seeds)))
vec))))
;;; (VECTOR-UNFOLD-RIGHT <f> <length> <initial-seed> ...) -> vector
;;; (F <seed> ...) -> [seed' ...]
;;; Like VECTOR-UNFOLD, but it generates elements from LENGTH to 0
;;; (still exclusive with LENGTH and inclusive with 0), not 0 to
;;; LENGTH as with VECTOR-UNFOLD.
(define vector-unfold-right
(letrec ((tabulate!
(lambda (f vec i)
(cond ((>= i 0)
(vector-set! vec i (f i))
(tabulate! f vec (sub1 i))))))
(unfold2+!
(lambda (f vec i seeds)
(if (>= i 0)
(receive (elt . new-seeds)
(apply f i seeds)
(vector-set! vec i elt)
(unfold2+! f vec (sub1 i) new-seeds))))))
(lambda (f len . initial-seeds)
(unless (procedure? f)
(apply raise-type-error
'vector-unfold-right "procedure" 0
f len initial-seeds))
(unless (nonneg-int? len)
(apply raise-type-error
'vector-unfold-right "non-negative exact integer" 1
f len initial-seeds))
(let ((vec (make-vector len))
(i (sub1 len)))
(cond ((null? initial-seeds)
(tabulate! f vec i))
((null? (cdr initial-seeds))
(unfold1! f vec i (car initial-seeds)))
(else
(unfold2+! f vec i initial-seeds)))
vec))))
;;; (VECTOR-COPY <vector> [<start> <end> <fill>]) -> vector
;;; Create a newly allocated vector containing the elements from the
;;; range [START,END) in VECTOR. START defaults to 0; END defaults
;;; to the length of VECTOR. END may be greater than the length of
;;; VECTOR, in which case the vector is enlarged; if FILL is passed,
;;; the new locations from which there is no respective element in
;;; VECTOR are filled with FILL.
(define (vector-copy vec . arg)
(unless (vector? vec)
(raise-type-error 'vector-copy "vector" vec))
(apply
(opt-lambda (vec (start 0) (end (vector-length vec)) . fill)
(check-start vec start 'vector-copy)
(unless (nonneg-int? end)
(raise-type-error 'vector-copy "non-negative exact integer" end))
(unless (<= start end)
(raise
(make-exn:fail:contract
(string->immutable-string
(format "~a: indices (~a, ~a) out of range for vector: ~a"
'vector-copy start end vec))
(current-continuation-marks))))
(let ((new-vector
(apply make-vector (cons (- end start) fill))))
(%vector-copy! new-vector 0
vec start
(min end (vector-length vec)))
new-vector))
vec arg))
;;; (VECTOR-REVERSE-COPY <vector> [<start> <end>]) -> vector
;;; Create a newly allocated vector whose elements are the reversed
;;; sequence of elements between START and END in VECTOR. START's
;;; default is 0; END's default is the length of VECTOR.
(define (vector-reverse-copy vec . arg)
(unless (vector? vec)
(raise-type-error 'vector-reverse-copy "vector" vec))
(apply
(opt-lambda (vec (start 0) (end (vector-length vec)))
(check-indices vec start end 'vector-reverse-copy)
(let ((new (make-vector (- end start))))
(%vector-reverse-copy! new 0 vec start end)
new))
vec arg))
;;; (VECTOR-APPEND <vector> ...) -> vector
;;; Append VECTOR ... into a newly allocated vector and return that
;;; new vector.
(define (vector-append . vectors)
(check-list-of-vecs vectors 'vector-append)
(vector-concatenate:aux vectors))
;;; (VECTOR-CONCATENATE <vector-list>) -> vector
;;; Concatenate the vectors in VECTOR-LIST. This is equivalent to
;;; (apply vector-append VECTOR-LIST)
;;; Actually, they're both implemented in terms of an internal routine.
(define (vector-concatenate vector-list)
(unless (and (list? vector-list)
(andmap vector? vector-list))
(raise-type-error 'vector-concatenate "list of vectors" vector-list))
(vector-concatenate:aux vector-list))
;;; Auxiliary for VECTOR-APPEND and VECTOR-CONCATENATE
(define vector-concatenate:aux
(letrec ((compute-length
(lambda (vectors len)
(if (null? vectors)
len
(let ((vec (car vectors)))
(compute-length (cdr vectors)
(+ (vector-length vec) len))))))
(concatenate!
(lambda (vectors target to)
(if (null? vectors)
target
(let* ((vec1 (car vectors))
(len (vector-length vec1)))
(%vector-copy! target to vec1 0 len)
(concatenate! (cdr vectors) target
(+ to len)))))))
(lambda (vectors)
(let ((new-vector
(make-vector (compute-length vectors 0))))
(concatenate! vectors new-vector 0)
new-vector)))))
;;;
;;; <constructors.ss> ---- Vector constructors
;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
;;;
;;; Copyright (C) 2005 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 constructors mzscheme
(require (lib "receive.ss" "srfi" "8")
"util.ss"
(lib "etc.ss" "mzlib"))
(provide vector-unfold
vector-unfold-right
vector-copy
vector-reverse-copy
vector-append
vector-concatenate)
;;; (VECTOR-UNFOLD <f> <length> <initial-seed> ...) -> vector
;;; (F <index> <seed> ...) -> [elt seed' ...]
;;; The fundamental vector constructor. Creates a vector whose
;;; length is LENGTH and iterates across each index K between 0 and
;;; LENGTH, applying F at each iteration to the current index and the
;;; current seeds to receive N+1 values: first, the element to put in
;;; the Kth slot and then N new seeds for the next iteration.
(define vector-unfold
(letrec ((tabulate! ; Special zero-seed case.
(lambda (f vec i len)
(cond ((< i len)
(vector-set! vec i (f i))
(tabulate! f vec (add1 i) len)))))
(unfold1! ; Fast path for one seed.
(lambda (f vec i len seed)
(if (< i len)
(receive (elt new-seed)
(f i seed)
(vector-set! vec i elt)
(unfold1! f vec (add1 i) len new-seed)))))
(unfold2+! ; Slower variant for N seeds.
(lambda (f vec i len seeds)
(if (< i len)
(receive (elt . new-seeds)
(apply f i seeds)
(vector-set! vec i elt)
(unfold2+! f vec (add1 i) len new-seeds))))))
(lambda (f len . initial-seeds)
(unless (procedure? f)
(apply raise-type-error
'vector-unfold "procedure" 0
f len initial-seeds))
(unless (nonneg-int? len)
(apply raise-type-error
'vector-unfold "non-negative exact integer" 1
f len initial-seeds))
(let ((vec (make-vector len)))
(cond ((null? initial-seeds)
(tabulate! f vec 0 len))
((null? (cdr initial-seeds))
(unfold1! f vec 0 len (car initial-seeds)))
(else
(unfold2+! f vec 0 len initial-seeds)))
vec))))
;;; (VECTOR-UNFOLD-RIGHT <f> <length> <initial-seed> ...) -> vector
;;; (F <seed> ...) -> [seed' ...]
;;; Like VECTOR-UNFOLD, but it generates elements from LENGTH to 0
;;; (still exclusive with LENGTH and inclusive with 0), not 0 to
;;; LENGTH as with VECTOR-UNFOLD.
(define vector-unfold-right
(letrec ((tabulate!
(lambda (f vec i)
(cond ((>= i 0)
(vector-set! vec i (f i))
(tabulate! f vec (sub1 i))))))
(unfold2+!
(lambda (f vec i seeds)
(if (>= i 0)
(receive (elt . new-seeds)
(apply f i seeds)
(vector-set! vec i elt)
(unfold2+! f vec (sub1 i) new-seeds))))))
(lambda (f len . initial-seeds)
(unless (procedure? f)
(apply raise-type-error
'vector-unfold-right "procedure" 0
f len initial-seeds))
(unless (nonneg-int? len)
(apply raise-type-error
'vector-unfold-right "non-negative exact integer" 1
f len initial-seeds))
(let ((vec (make-vector len))
(i (sub1 len)))
(cond ((null? initial-seeds)
(tabulate! f vec i))
((null? (cdr initial-seeds))
(unfold1! f vec i (car initial-seeds)))
(else
(unfold2+! f vec i initial-seeds)))
vec))))
;;; (VECTOR-COPY <vector> [<start> <end> <fill>]) -> vector
;;; Create a newly allocated vector containing the elements from the
;;; range [START,END) in VECTOR. START defaults to 0; END defaults
;;; to the length of VECTOR. END may be greater than the length of
;;; VECTOR, in which case the vector is enlarged; if FILL is passed,
;;; the new locations from which there is no respective element in
;;; VECTOR are filled with FILL.
(define (vector-copy vec . arg)
(unless (vector? vec)
(raise-type-error 'vector-copy "vector" vec))
(apply
(opt-lambda (vec (start 0) (end (vector-length vec)) . fill)
(check-start vec start 'vector-copy)
(unless (nonneg-int? end)
(raise-type-error 'vector-copy "non-negative exact integer" end))
(unless (<= start end)
(raise
(make-exn:fail:contract
(string->immutable-string
(format "~a: indices (~a, ~a) out of range for vector: ~a"
'vector-copy start end vec))
(current-continuation-marks))))
(let ((new-vector
(apply make-vector (cons (- end start) fill))))
(%vector-copy! new-vector 0
vec start
(min end (vector-length vec)))
new-vector))
vec arg))
;;; (VECTOR-REVERSE-COPY <vector> [<start> <end>]) -> vector
;;; Create a newly allocated vector whose elements are the reversed
;;; sequence of elements between START and END in VECTOR. START's
;;; default is 0; END's default is the length of VECTOR.
(define (vector-reverse-copy vec . arg)
(unless (vector? vec)
(raise-type-error 'vector-reverse-copy "vector" vec))
(apply
(opt-lambda (vec (start 0) (end (vector-length vec)))
(check-indices vec start end 'vector-reverse-copy)
(let ((new (make-vector (- end start))))
(%vector-reverse-copy! new 0 vec start end)
new))
vec arg))
;;; (VECTOR-APPEND <vector> ...) -> vector
;;; Append VECTOR ... into a newly allocated vector and return that
;;; new vector.
(define (vector-append . vectors)
(check-list-of-vecs vectors 'vector-append)
(vector-concatenate:aux vectors))
;;; (VECTOR-CONCATENATE <vector-list>) -> vector
;;; Concatenate the vectors in VECTOR-LIST. This is equivalent to
;;; (apply vector-append VECTOR-LIST)
;;; Actually, they're both implemented in terms of an internal routine.
(define (vector-concatenate vector-list)
(unless (and (list? vector-list)
(andmap vector? vector-list))
(raise-type-error 'vector-concatenate "list of vectors" vector-list))
(vector-concatenate:aux vector-list))
;;; Auxiliary for VECTOR-APPEND and VECTOR-CONCATENATE
(define vector-concatenate:aux
(letrec ((compute-length
(lambda (vectors len)
(if (null? vectors)
len
(let ((vec (car vectors)))
(compute-length (cdr vectors)
(+ (vector-length vec) len))))))
(concatenate!
(lambda (vectors target to)
(if (null? vectors)
target
(let* ((vec1 (car vectors))
(len (vector-length vec1)))
(%vector-copy! target to vec1 0 len)
(concatenate! (cdr vectors) target
(+ to len)))))))
(lambda (vectors)
(let ((new-vector
(make-vector (compute-length vectors 0))))
(concatenate! vectors new-vector 0)
new-vector)))))

202
collects/srfi/43/conversion.ss
View File

@ -1,101 +1,101 @@
;;;
;;; <conversion.ss> ---- Vector conversion
;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
;;;
;;; Copyright (C) 2005 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 conversion mzscheme
(require "util.ss"
(lib "etc.ss"))
(provide (rename my-vector->list vector->list)
reverse-vector->list
reverse-list->vector)
;;; (VECTOR->LIST <vector> [<start> <end>]) -> list
;;; [R5RS+] Produce a list containing the elements in the locations
;;; between START, whose default is 0, and END, whose default is the
;;; length of VECTOR, from VECTOR.
(define (my-vector->list vec . maybe-start+end)
(unless (vector? vec)
(apply raise-type-error
'vector->list "vector" 0
vec maybe-start+end))
(if (null? maybe-start+end)
(vector->list vec) ;+++
(apply (opt-lambda (vec (start 0) (end (vector-length vec)))
(check-indices vec start end 'vector->list)
;(unfold (lambda (i) ; No SRFI 1.
; (< i start))
; (lambda (i) (vector-ref vec i))
; (lambda (i) (sub1 i))
; (sub1 end))
(do ((i (sub1 end) (sub1 i))
(result '() (cons (vector-ref vec i) result)))
((< i start) result)))
vec maybe-start+end)))
;;; (REVERSE-VECTOR->LIST <vector> [<start> <end>]) -> list
;;; Produce a list containing the elements in the locations between
;;; START, whose default is 0, and END, whose default is the length
;;; of VECTOR, from VECTOR, in reverse order.
(define (reverse-vector->list vec . maybe-start+end)
(unless (vector? vec)
(apply raise-type-error
'reverse-vector->list "vector" 0
vec maybe-start+end))
(apply (opt-lambda (vec (start 0) (end (vector-length vec)))
(check-indices vec start end 'reverse-vector->list)
;(unfold (lambda (i) (= i end)) ; No SRFI 1.
; (lambda (i) (vector-ref vec i))
; (lambda (i) (add1 i))
; start)
(do ((i start (add1 i))
(result '() (cons (vector-ref vec i) result)))
((= i end) result)))
vec maybe-start+end))
;;; (REVERSE-LIST->VECTOR <list> -> vector
;;; Produce a vector containing the elements in LIST in reverse order.
(define (reverse-list->vector lst)
(unless (list? lst)
(raise-type-error 'reverse-list->vector "proper list" lst))
(let* ((len (length lst))
(vec (make-vector len)))
(unfold1! (lambda (index l) (values (car l) (cdr l)))
vec
(sub1 len)
lst)
vec)))
;;;
;;; <conversion.ss> ---- Vector conversion
;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
;;;
;;; Copyright (C) 2005 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 conversion mzscheme
(require "util.ss"
(lib "etc.ss"))
(provide (rename my-vector->list vector->list)
reverse-vector->list
reverse-list->vector)
;;; (VECTOR->LIST <vector> [<start> <end>]) -> list
;;; [R5RS+] Produce a list containing the elements in the locations
;;; between START, whose default is 0, and END, whose default is the
;;; length of VECTOR, from VECTOR.
(define (my-vector->list vec . maybe-start+end)
(unless (vector? vec)
(apply raise-type-error
'vector->list "vector" 0
vec maybe-start+end))
(if (null? maybe-start+end)
(vector->list vec) ;+++
(apply (opt-lambda (vec (start 0) (end (vector-length vec)))
(check-indices vec start end 'vector->list)
;(unfold (lambda (i) ; No SRFI 1.
; (< i start))
; (lambda (i) (vector-ref vec i))
; (lambda (i) (sub1 i))
; (sub1 end))
(do ((i (sub1 end) (sub1 i))
(result '() (cons (vector-ref vec i) result)))
((< i start) result)))
vec maybe-start+end)))
;;; (REVERSE-VECTOR->LIST <vector> [<start> <end>]) -> list
;;; Produce a list containing the elements in the locations between
;;; START, whose default is 0, and END, whose default is the length
;;; of VECTOR, from VECTOR, in reverse order.
(define (reverse-vector->list vec . maybe-start+end)
(unless (vector? vec)
(apply raise-type-error
'reverse-vector->list "vector" 0
vec maybe-start+end))
(apply (opt-lambda (vec (start 0) (end (vector-length vec)))
(check-indices vec start end 'reverse-vector->list)
;(unfold (lambda (i) (= i end)) ; No SRFI 1.
; (lambda (i) (vector-ref vec i))
; (lambda (i) (add1 i))
; start)
(do ((i start (add1 i))
(result '() (cons (vector-ref vec i) result)))
((= i end) result)))
vec maybe-start+end))
;;; (REVERSE-LIST->VECTOR <list> -> vector
;;; Produce a vector containing the elements in LIST in reverse order.
(define (reverse-list->vector lst)
(unless (list? lst)
(raise-type-error 'reverse-list->vector "proper list" lst))
(let* ((len (length lst))
(vec (make-vector len)))
(unfold1! (lambda (index l) (values (car l) (cdr l)))
vec
(sub1 len)
lst)
vec)))

556
collects/srfi/43/iteration.ss
View File

@ -1,278 +1,278 @@
;;;
;;; <iteration.ss> ---- Vector iteration
;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
;;;
;;; Copyright (C) 2005 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 iteration mzscheme
(require "util.ss")
(provide vector-fold
vector-fold-right
vector-map
vector-map!
vector-for-each
vector-count)
;;; (VECTOR-FOLD <kons> <initial-knil> <vector> ...) -> knil
;;; (KONS <knil> <elt> ...) -> knil' ; N vectors -> N+1 args
;;; The fundamental vector iterator. KONS is iterated over each
;;; index in all of the vectors in parallel, stopping at the end of
;;; the shortest; KONS is applied to an argument list of (list I
;;; STATE (vector-ref VEC I) ...), where STATE is the current state
;;; value -- the state value begins with KNIL and becomes whatever
;;; KONS returned at the respective iteration --, and I is the
;;; current index in the iteration. The iteration is strictly left-
;;; to-right.
;;; (vector-fold KONS KNIL (vector E_1 E_2 ... E_N))
;;; <=>
;;; (KONS (... (KONS (KONS KNIL E_1) E_2) ... E_N-1) E_N)
(define (vector-fold kons knil vec . vectors)
(unless (procedure? kons)
(apply raise-type-error
'vector-fold "procedure" 0
kons knil vec vectors))
(unless (vector? vec)
(apply raise-type-error
'vector-fold "vector" 2
kons knil vec vectors))
(if (null? vectors)
(%vector-fold1 kons knil (vector-length vec) vec)
(begin (check-list-of-vecs vectors 'vector-fold 3
(list* kons knil vec vectors))
(%vector-fold2+ kons knil
(%smallest-length vectors
(vector-length vec))
(cons vec vectors)))))
(define %vector-fold1
(letrec ((loop (lambda (kons knil len vec i)
(if (= i len)
knil
(loop kons
(kons i knil (vector-ref vec i))
len vec (add1 i))))))
(lambda (kons knil len vec)
(loop kons knil len vec 0))))
(define %vector-fold2+
(letrec ((loop (lambda (kons knil len vectors i)
(if (= i len)
knil
(loop kons
(apply kons i knil
(vectors-ref vectors i))
len vectors (add1 i))))))
(lambda (kons knil len vectors)
(loop kons knil len vectors 0))))
;;; (VECTOR-COUNT <predicate?> <vector> ...)
;;; -> exact, nonnegative integer
;;; (PREDICATE? <index> <value> ...) ; N vectors -> N+1 args
;;; PREDICATE? is applied element-wise to the elements of VECTOR ...,
;;; and a count is tallied of the number of elements for which a
;;; true value is produced by PREDICATE?. This count is returned.
(define (vector-count pred? vec . vectors)
(unless (procedure? pred?)
(apply raise-type-error
'vector-count "procedure" 0
pred? vec vectors))
(if (null? vectors)
(%vector-fold1 (lambda (index count elt)
(if (pred? index elt)
(add1 count)
count))
0
(vector-length vec)
vec)
(begin (check-list-of-vecs vectors 'vector-count 2
(list* pred? vec vectors))
(%vector-fold2+ (lambda (index count . elts)
(if (apply pred? index elts)
(add1 count)
count))
0
(%smallest-length vectors
(vector-length vec))
(cons vec vectors)))))
;;; (VECTOR-FOLD-RIGHT <kons> <initial-knil> <vector> ...) -> knil
;;; (KONS <knil> <elt> ...) -> knil' ; N vectors => N+1 args
;;; The fundamental vector recursor. Iterates in parallel across
;;; VECTOR ... right to left, applying KONS to the elements and the
;;; current state value; the state value becomes what KONS returns
;;; at each next iteration. KNIL is the initial state value.
;;; (vector-fold-right KONS KNIL (vector E_1 E_2 ... E_N))
;;; <=>
;;; (KONS (... (KONS (KONS KNIL E_N) E_N-1) ... E_2) E_1)
;;;
;;; Not implemented in terms of a more primitive operations that might
;;; called %VECTOR-FOLD-RIGHT due to the fact that it wouldn't be very
;;; useful elsewhere.
(define vector-fold-right
(letrec ((loop1 (lambda (kons knil vec i)
(if (zero? i)
knil
(let ((j (sub1 i)))
(loop1 kons
(kons j knil (vector-ref vec j))
vec
j)))))
(loop2+ (lambda (kons knil vectors i)
(if (zero? i)
knil
(let ((j (sub1 i)))
(loop2+ kons
(apply kons j knil
(vectors-ref vectors j))
vectors
j))))))
(lambda (kons knil vec . vectors)
(unless (procedure? kons)
(apply raise-type-error
'vector-fold-right "procedure" 0
kons knil vec vectors))
(unless (vector? vec)
(apply raise-type-error
'vector-fold-right "vector" 2
kons knil vec vectors))
(if (null? vectors)
(loop1 kons knil vec (vector-length vec))
(begin (check-list-of-vecs vectors 'vector-fold-right 3
(list* kons knil vec vectors))
(loop2+ kons knil (cons vec vectors)
(%smallest-length vectors
(vector-length vec))))))))
;;; (VECTOR-MAP <f> <vector> ...) -> vector
;;; (F <elt> ...) -> value ; N vectors -> N args
;;; Constructs a new vector of the shortest length of the vector
;;; arguments. Each element at index I of the new vector is mapped
;;; from the old vectors by (F I (vector-ref VECTOR I) ...). The
;;; dynamic order of application of F is unspecified.
(define (vector-map f vec . vectors)
(unless (procedure? f)
(apply raise-type-error
'vector-map "procedure" 0
f vec vectors))
(unless (vector? vec)
(apply raise-type-error
'vector-map "vector" 1
f vec vectors))
(if (null? vectors)
(let ((len (vector-length vec)))
(%vector-map1! f (make-vector len) vec len))
(begin (check-list-of-vecs vectors 'vector-map 2
(list* f vec vectors))
(let ((len (%smallest-length vectors
(vector-length vec))))
(%vector-map2+! f (make-vector len)
(cons vec vectors) len)))))
;;; (%VECTOR-MAP1! <f> <target> <length> <vector>)
;;; (F <index> <elt>) -> elt'
(define (%vector-map1! f target vec i)
(if (zero? i)
target
(let ((j (sub1 i)))
(vector-set! target j
(f j (vector-ref vec j)))
(%vector-map1! f target vec j))))
(define (%vector-map2+! f target vectors i)
(if (zero? i)
target
(let ((j (sub1 i)))
(vector-set! target j
(apply f j (vectors-ref vectors j)))
(%vector-map2+! f target vectors j))))
;;; (VECTOR-MAP! <f> <vector> ...) -> vector
;;; (F <elt> ...) -> element' ; N vectors -> N args
;;; Similar to VECTOR-MAP, but rather than mapping the new elements
;;; into a new vector, the new mapped elements are destructively
;;; inserted into the first vector. Again, the dynamic order of
;;; application of F is unspecified, so it is dangerous for F to
;;; manipulate the first VECTOR.
(define (vector-map! f vec . vectors)
(unless (procedure? f)
(apply raise-type-error
'vector-map! "procedure" 0
f vec vectors))
(unless (vector? vec)
(apply raise-type-error
'vector-map! "vector" 1
f vec vectors))
(if (null? vectors)
(%vector-map1! f vec vec (vector-length vec))
(begin (check-list-of-vecs vectors 'vector-map! 2
(list* f vec vectors))
(%vector-map2+! f vec (cons vec vectors)
(%smallest-length vectors
(vector-length vec))))))
;;; (VECTOR-FOR-EACH <f> <vector> ...) -> void
;;; (F <elt> ...) ; N vectors -> N args
;;; Simple vector iterator: applies F to each index in the range [0,
;;; LENGTH), where LENGTH is the length of the smallest vector
;;; argument passed, and the respective element at that index. In
;;; contrast with VECTOR-MAP, F is reliably applied to each
;;; subsequent elements, starting at index 0 from left to right, in
;;; the vectors.
(define vector-for-each
(letrec ((for-each1
(lambda (f vec i len)
(when (< i len)
(f i (vector-ref vec i))
(for-each1 f vec (add1 i) len))))
(for-each2+
(lambda (f vecs i len)
(when (< i len)
(apply f i (vectors-ref vecs i))
(for-each2+ f vecs (add1 i) len)))))
(lambda (f vec . vectors)
(unless (procedure? f)
(apply raise-type-error
'vector-for-each "procedure" 0
f vec vectors))
(unless (vector? vec)
(apply raise-type-error
'vector-for-each "vector" 1
f vec vectors))
(if (null? vectors)
(for-each1 f vec 0 (vector-length vec))
(begin (check-list-of-vecs vectors 'vector-for-each 2
(list* f vec vectors))
(for-each2+ f (cons vec vectors) 0
(%smallest-length vectors
(vector-length vec)))))))))
;;;
;;; <iteration.ss> ---- Vector iteration
;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
;;;
;;; Copyright (C) 2005 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 iteration mzscheme
(require "util.ss")
(provide vector-fold
vector-fold-right
vector-map
vector-map!
vector-for-each
vector-count)
;;; (VECTOR-FOLD <kons> <initial-knil> <vector> ...) -> knil
;;; (KONS <knil> <elt> ...) -> knil' ; N vectors -> N+1 args
;;; The fundamental vector iterator. KONS is iterated over each
;;; index in all of the vectors in parallel, stopping at the end of
;;; the shortest; KONS is applied to an argument list of (list I
;;; STATE (vector-ref VEC I) ...), where STATE is the current state
;;; value -- the state value begins with KNIL and becomes whatever
;;; KONS returned at the respective iteration --, and I is the
;;; current index in the iteration. The iteration is strictly left-
;;; to-right.
;;; (vector-fold KONS KNIL (vector E_1 E_2 ... E_N))
;;; <=>
;;; (KONS (... (KONS (KONS KNIL E_1) E_2) ... E_N-1) E_N)
(define (vector-fold kons knil vec . vectors)
(unless (procedure? kons)
(apply raise-type-error
'vector-fold "procedure" 0
kons knil vec vectors))
(unless (vector? vec)
(apply raise-type-error
'vector-fold "vector" 2
kons knil vec vectors))
(if (null? vectors)
(%vector-fold1 kons knil (vector-length vec) vec)
(begin (check-list-of-vecs vectors 'vector-fold 3
(list* kons knil vec vectors))
(%vector-fold2+ kons knil
(%smallest-length vectors
(vector-length vec))
(cons vec vectors)))))
(define %vector-fold1
(letrec ((loop (lambda (kons knil len vec i)
(if (= i len)
knil
(loop kons
(kons i knil (vector-ref vec i))
len vec (add1 i))))))
(lambda (kons knil len vec)
(loop kons knil len vec 0))))
(define %vector-fold2+
(letrec ((loop (lambda (kons knil len vectors i)
(if (= i len)
knil
(loop kons
(apply kons i knil
(vectors-ref vectors i))
len vectors (add1 i))))))
(lambda (kons knil len vectors)
(loop kons knil len vectors 0))))
;;; (VECTOR-COUNT <predicate?> <vector> ...)
;;; -> exact, nonnegative integer
;;; (PREDICATE? <index> <value> ...) ; N vectors -> N+1 args
;;; PREDICATE? is applied element-wise to the elements of VECTOR ...,
;;; and a count is tallied of the number of elements for which a
;;; true value is produced by PREDICATE?. This count is returned.
(define (vector-count pred? vec . vectors)
(unless (procedure? pred?)
(apply raise-type-error
'vector-count "procedure" 0
pred? vec vectors))
(if (null? vectors)
(%vector-fold1 (lambda (index count elt)
(if (pred? index elt)
(add1 count)
count))
0
(vector-length vec)
vec)
(begin (check-list-of-vecs vectors 'vector-count 2
(list* pred? vec vectors))
(%vector-fold2+ (lambda (index count . elts)
(if (apply pred? index elts)
(add1 count)
count))
0
(%smallest-length vectors
(vector-length vec))
(cons vec vectors)))))
;;; (VECTOR-FOLD-RIGHT <kons> <initial-knil> <vector> ...) -> knil
;;; (KONS <knil> <elt> ...) -> knil' ; N vectors => N+1 args
;;; The fundamental vector recursor. Iterates in parallel across
;;; VECTOR ... right to left, applying KONS to the elements and the
;;; current state value; the state value becomes what KONS returns
;;; at each next iteration. KNIL is the initial state value.
;;; (vector-fold-right KONS KNIL (vector E_1 E_2 ... E_N))
;;; <=>
;;; (KONS (... (KONS (KONS KNIL E_N) E_N-1) ... E_2) E_1)
;;;
;;; Not implemented in terms of a more primitive operations that might
;;; called %VECTOR-FOLD-RIGHT due to the fact that it wouldn't be very
;;; useful elsewhere.
(define vector-fold-right
(letrec ((loop1 (lambda (kons knil vec i)
(if (zero? i)
knil
(let ((j (sub1 i)))
(loop1 kons
(kons j knil (vector-ref vec j))
vec
j)))))
(loop2+ (lambda (kons knil vectors i)
(if (zero? i)
knil
(let ((j (sub1 i)))
(loop2+ kons
(apply kons j knil
(vectors-ref vectors j))
vectors
j))))))
(lambda (kons knil vec . vectors)
(unless (procedure? kons)
(apply raise-type-error
'vector-fold-right "procedure" 0
kons knil vec vectors))
(unless (vector? vec)
(apply raise-type-error
'vector-fold-right "vector" 2
kons knil vec vectors))
(if (null? vectors)
(loop1 kons knil vec (vector-length vec))
(begin (check-list-of-vecs vectors 'vector-fold-right 3
(list* kons knil vec vectors))
(loop2+ kons knil (cons vec vectors)
(%smallest-length vectors
(vector-length vec))))))))
;;; (VECTOR-MAP <f> <vector> ...) -> vector
;;; (F <elt> ...) -> value ; N vectors -> N args
;;; Constructs a new vector of the shortest length of the vector
;;; arguments. Each element at index I of the new vector is mapped
;;; from the old vectors by (F I (vector-ref VECTOR I) ...). The
;;; dynamic order of application of F is unspecified.
(define (vector-map f vec . vectors)
(unless (procedure? f)
(apply raise-type-error
'vector-map "procedure" 0
f vec vectors))
(unless (vector? vec)
(apply raise-type-error
'vector-map "vector" 1
f vec vectors))
(if (null? vectors)
(let ((len (vector-length vec)))
(%vector-map1! f (make-vector len) vec len))
(begin (check-list-of-vecs vectors 'vector-map 2
(list* f vec vectors))
(let ((len (%smallest-length vectors
(vector-length vec))))
(%vector-map2+! f (make-vector len)
(cons vec vectors) len)))))
;;; (%VECTOR-MAP1! <f> <target> <length> <vector>)
;;; (F <index> <elt>) -> elt'
(define (%vector-map1! f target vec i)
(if (zero? i)
target
(let ((j (sub1 i)))
(vector-set! target j
(f j (vector-ref vec j)))
(%vector-map1! f target vec j))))
(define (%vector-map2+! f target vectors i)
(if (zero? i)
target
(let ((j (sub1 i)))
(vector-set! target j
(apply f j (vectors-ref vectors j)))
(%vector-map2+! f target vectors j))))
;;; (VECTOR-MAP! <f> <vector> ...) -> vector
;;; (F <elt> ...) -> element' ; N vectors -> N args
;;; Similar to VECTOR-MAP, but rather than mapping the new elements
;;; into a new vector, the new mapped elements are destructively
;;; inserted into the first vector. Again, the dynamic order of
;;; application of F is unspecified, so it is dangerous for F to
;;; manipulate the first VECTOR.
(define (vector-map! f vec . vectors)
(unless (procedure? f)
(apply raise-type-error
'vector-map! "procedure" 0
f vec vectors))
(unless (vector? vec)
(apply raise-type-error
'vector-map! "vector" 1
f vec vectors))
(if (null? vectors)
(%vector-map1! f vec vec (vector-length vec))
(begin (check-list-of-vecs vectors 'vector-map! 2
(list* f vec vectors))
(%vector-map2+! f vec (cons vec vectors)
(%smallest-length vectors
(vector-length vec))))))
;;; (VECTOR-FOR-EACH <f> <vector> ...) -> void
;;; (F <elt> ...) ; N vectors -> N args
;;; Simple vector iterator: applies F to each index in the range [0,
;;; LENGTH), where LENGTH is the length of the smallest vector
;;; argument passed, and the respective element at that index. In
;;; contrast with VECTOR-MAP, F is reliably applied to each
;;; subsequent elements, starting at index 0 from left to right, in
;;; the vectors.
(define vector-for-each
(letrec ((for-each1
(lambda (f vec i len)
(when (< i len)
(f i (vector-ref vec i))
(for-each1 f vec (add1 i) len))))
(for-each2+
(lambda (f vecs i len)
(when (< i len)
(apply f i (vectors-ref vecs i))
(for-each2+ f vecs (add1 i) len)))))
(lambda (f vec . vectors)
(unless (procedure? f)
(apply raise-type-error
'vector-for-each "procedure" 0
f vec vectors))
(unless (vector? vec)
(apply raise-type-error
'vector-for-each "vector" 1
f vec vectors))
(if (null? vectors)
(for-each1 f vec 0 (vector-length vec))
(begin (check-list-of-vecs vectors 'vector-for-each 2
(list* f vec vectors))
(for-each2+ f (cons vec vectors) 0
(%smallest-length vectors
(vector-length vec)))))))))

340
collects/srfi/43/mutators.ss
View File

@ -1,171 +1,171 @@
;;;
;;; <mutators.ss> ---- Vector mutators
;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
;;;
;;; Copyright (C) 2005 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 mutators mzscheme
(require "util.ss"
(lib "etc.ss"))
(provide vector-swap!
(rename my-vector-fill! vector-fill!)
vector-reverse!
vector-copy!
vector-reverse-copy!)
;;; (VECTOR-SWAP! <vector> <index1> <index2>) -> void
;;; Swap the values in the locations at INDEX1 and INDEX2.
(define (vector-swap! vec i j)
(unless (vector? vec)
(raise-type-error 'vector-swap! "vector" 0
vec i j))
(check-index vec i 'vector-swap!)
(check-index vec j 'vector-swap!)
(%vector-swap! vec i j))
(define (%vector-swap! vec i j)
(let ((x (vector-ref vec i)))
(vector-set! vec i (vector-ref vec j))
(vector-set! vec j x)))
;;; (VECTOR-FILL! <vector> <value> [<start> <end>]) -> <vector>
;;; [R5RS+] Fill the locations in VECTOR between START, whose default
;;; is 0, and END, whose default is the length of VECTOR, with VALUE.
;;;
;;; This one can probably be made really fast natively.
(define (my-vector-fill! vec value . maybe-start+end)
(cond ((null? maybe-start+end)
(vector-fill! vec value)) ;+++
((not (vector? vec))
(apply raise-type-error
'vector-fill! "vector" 0
vec value maybe-start+end))
(else
(apply (opt-lambda (vec value (start 0) (end (vector-length vec)))
(check-indices vec start end 'vector-fill!)
(do ((i start (add1 i)))
((= i end))
(vector-set! vec i value))
vec)
vec value maybe-start+end))))
(define %vector-reverse!
(letrec ((loop (lambda (vec i j)
(when (< i j)
(%vector-swap! vec i j)
(loop vec (add1 i) (sub1 j))))))
(lambda (vec start end)
(loop vec start (sub1 end)))))
;;; (VECTOR-REVERSE! <vector> [<start> <end>]) -> void
;;; Destructively reverse the contents of the sequence of locations
;;; in VECTOR between START, whose default is 0, and END, whose
;;; default is the length of VECTOR.
(define (vector-reverse! vec . maybe-start+end)
(unless (vector? vec)
(apply raise-type-error
'vector-reverse! "vector" 0
vec maybe-start+end))
(apply (opt-lambda (vec (start 0) (end (vector-length vec)))
(check-indices vec start end 'vector-reverse!)
(%vector-reverse! vec start end))
vec maybe-start+end))
;;; (VECTOR-COPY! <target> <tstart> <source> [<sstart> <send>])
;;; -> unspecified
;;; Copy the values in the locations in [SSTART,SEND) from SOURCE to
;;; to TARGET, starting at TSTART in TARGET.
(define (vector-copy! target tstart source . maybe-sstart+send)
(unless (vector? target)
(apply raise-type-error
'vector-copy! "vector" 0
target tstart source maybe-sstart+send))
(check-start target tstart 'vector-copy!)
(unless (vector? source)
(apply raise-type-error
'vector-copy! "vector" 2
target tstart source maybe-sstart+send))
(apply (opt-lambda (target
tstart
source
(sstart 0)
(send (vector-length source)))
(check-indices source sstart send 'vector-copy!)
(if (< (- (vector-length target) tstart)
(- send sstart))
(error 'vector-copy!
"target vector not long enough to copy"))
(%vector-copy! target tstart source sstart send))
target tstart source maybe-sstart+send))
;;; (VECTOR-REVERSE-COPY! <target> <tstart> <source> [<sstart> <send>])
(define (vector-reverse-copy! target tstart source . maybe-sstart+send)
(unless (vector? target)
(apply raise-type-error
'vector-reverse-copy! "vector" 0
target tstart source maybe-sstart+send))
(check-start target tstart 'vector-reverse-copy!)
(unless (vector? source)
(apply raise-type-error
'vector-reverse-copy! "vector" 2
target tstart source maybe-sstart+send))
(apply (opt-lambda (target
tstart
source
(sstart 0)
(send (vector-length source)))
(check-indices source sstart send 'vector-reverse-copy!)
(cond ((< (- (vector-length target) tstart)
(- send sstart))
(error 'vector-reverse-copy!
"target vector not long enough to copy"))
((and (eq? target source)
(= sstart tstart))
(%vector-reverse! target tstart send))
((and (eq? target source)
(or (between? sstart tstart send)
(between? tstart sstart
(+ tstart (- send sstart)))))
;an error in the reference implement here
(error 'vector-reverse-copy!
"Vector range for self-copying overlaps"))
(else
(%vector-reverse-copy! target tstart
source sstart send))))
target tstart source maybe-sstart+send))
(define (between? x y z)
(and (< x y)
;;;
;;; <mutators.ss> ---- Vector mutators
;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
;;;
;;; Copyright (C) 2005 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 mutators mzscheme
(require "util.ss"
(lib "etc.ss"))
(provide vector-swap!
(rename my-vector-fill! vector-fill!)
vector-reverse!
vector-copy!
vector-reverse-copy!)
;;; (VECTOR-SWAP! <vector> <index1> <index2>) -> void
;;; Swap the values in the locations at INDEX1 and INDEX2.
(define (vector-swap! vec i j)
(unless (vector? vec)
(raise-type-error 'vector-swap! "vector" 0
vec i j))
(check-index vec i 'vector-swap!)
(check-index vec j 'vector-swap!)
(%vector-swap! vec i j))
(define (%vector-swap! vec i j)
(let ((x (vector-ref vec i)))
(vector-set! vec i (vector-ref vec j))
(vector-set! vec j x)))
;;; (VECTOR-FILL! <vector> <value> [<start> <end>]) -> <vector>
;;; [R5RS+] Fill the locations in VECTOR between START, whose default
;;; is 0, and END, whose default is the length of VECTOR, with VALUE.
;;;
;;; This one can probably be made really fast natively.
(define (my-vector-fill! vec value . maybe-start+end)
(cond ((null? maybe-start+end)
(vector-fill! vec value)) ;+++
((not (vector? vec))
(apply raise-type-error
'vector-fill! "vector" 0
vec value maybe-start+end))
(else
(apply (opt-lambda (vec value (start 0) (end (vector-length vec)))
(check-indices vec start end 'vector-fill!)
(do ((i start (add1 i)))
((= i end))
(vector-set! vec i value))
vec)
vec value maybe-start+end))))
(define %vector-reverse!
(letrec ((loop (lambda (vec i j)
(when (< i j)
(%vector-swap! vec i j)
(loop vec (add1 i) (sub1 j))))))
(lambda (vec start end)
(loop vec start (sub1 end)))))
;;; (VECTOR-REVERSE! <vector> [<start> <end>]) -> void
;;; Destructively reverse the contents of the sequence of locations
;;; in VECTOR between START, whose default is 0, and END, whose
;;; default is the length of VECTOR.
(define (vector-reverse! vec . maybe-start+end)
(unless (vector? vec)
(apply raise-type-error
'vector-reverse! "vector" 0
vec maybe-start+end))
(apply (opt-lambda (vec (start 0) (end (vector-length vec)))
(check-indices vec start end 'vector-reverse!)
(%vector-reverse! vec start end))
vec maybe-start+end))
;;; (VECTOR-COPY! <target> <tstart> <source> [<sstart> <send>])
;;; -> unspecified
;;; Copy the values in the locations in [SSTART,SEND) from SOURCE to
;;; to TARGET, starting at TSTART in TARGET.
(define (vector-copy! target tstart source . maybe-sstart+send)
(unless (vector? target)
(apply raise-type-error
'vector-copy! "vector" 0
target tstart source maybe-sstart+send))
(check-start target tstart 'vector-copy!)
(unless (vector? source)
(apply raise-type-error
'vector-copy! "vector" 2
target tstart source maybe-sstart+send))
(apply (opt-lambda (target
tstart
source
(sstart 0)
(send (vector-length source)))
(check-indices source sstart send 'vector-copy!)
(if (< (- (vector-length target) tstart)
(- send sstart))
(error 'vector-copy!
"target vector not long enough to copy"))
(%vector-copy! target tstart source sstart send))
target tstart source maybe-sstart+send))
;;; (VECTOR-REVERSE-COPY! <target> <tstart> <source> [<sstart> <send>])
(define (vector-reverse-copy! target tstart source . maybe-sstart+send)
(unless (vector? target)
(apply raise-type-error
'vector-reverse-copy! "vector" 0
target tstart source maybe-sstart+send))
(check-start target tstart 'vector-reverse-copy!)
(unless (vector? source)
(apply raise-type-error
'vector-reverse-copy! "vector" 2
target tstart source maybe-sstart+send))
(apply (opt-lambda (target
tstart
source
(sstart 0)
(send (vector-length source)))
(check-indices source sstart send 'vector-reverse-copy!)
(cond ((< (- (vector-length target) tstart)
(- send sstart))
(error 'vector-reverse-copy!
"target vector not long enough to copy"))
((and (eq? target source)
(= sstart tstart))
(%vector-reverse! target tstart send))
((and (eq? target source)
(or (between? sstart tstart send)
(between? tstart sstart
(+ tstart (- send sstart)))))
;an error in the reference implement here
(error 'vector-reverse-copy!
"Vector range for self-copying overlaps"))
(else
(%vector-reverse-copy! target tstart
source sstart send))))
target tstart source maybe-sstart+send))
(define (between? x y z)
(and (< x y)
(<= y z))))

204
collects/srfi/43/predicates.ss
View File

@ -1,103 +1,103 @@
;;;
;;; <predicates.ss> ---- Vector predicates
;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
;;;
;;; Copyright (C) 2005 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 predicates mzscheme
(require "util.ss")
(provide vector-empty?
vector=)
;;; (VECTOR-EMPTY? <vector>) -> boolean
;;; Return #T if VECTOR has zero elements in it, i.e. VECTOR's length
;;; is 0, and #F if not.
(define (vector-empty? vec)
(unless (vector? vec)
(raise-type-error 'vector-empty? "vector" vec))
(zero? (vector-length vec)))
;;; (VECTOR= <elt=?> <vector> ...) -> boolean
;;; (ELT=? <value> <value>) -> boolean
;;; Determine vector equality generalized across element comparators.
;;; Vectors A and B are equal iff their lengths are the same and for
;;; each respective elements E_a and E_b (element=? E_a E_b) returns
;;; a true value. ELT=? is always applied to two arguments. Element
;;; comparison must be consistent wtih EQ?; that is, if (eq? E_a E_b)
;;; results in a true value, then (ELEMENT=? E_a E_b) must result in a
;;; true value. This may be exploited to avoid multiple unnecessary
;;; element comparisons. (This implementation does, but does not deal
;;; with the situation that ELEMENT=? is EQ? to avoid more unnecessary
;;; comparisons, but I believe this optimization is probably fairly
;;; insignificant.)
;;;
;;; If the number of vector arguments is zero or one, then #T is
;;; automatically returned. If there are N vector arguments,
;;; VECTOR_1 VECTOR_2 ... VECTOR_N, then VECTOR_1 & VECTOR_2 are
;;; compared; if they are equal, the vectors VECTOR_2 ... VECTOR_N
;;; are compared. The precise order in which ELT=? is applied is not
;;; specified.
(define (vector= elt=? . vectors)
(unless (procedure-arity-includes? elt=? 2)
(apply raise-type-error
'vector= "procedure of arity 2" 0
elt=? vectors))
(cond ((null? vectors)
#t)
((null? (cdr vectors))
(unless (vector? (car vectors))
(apply raise-type-error
'vector= "vector" 1
elt=? vectors))
#t)
(else
(check-list-of-vecs vectors 'vector=
1 (cons elt=? vectors))
(let loop ((vecs vectors))
(let ((vec1 (car vecs))
(vec2+ (cdr vecs)))
(or (null? vec2+)
(and (binary-vector= elt=? vec1 (car vec2+))
(loop vec2+))))))))
(define (binary-vector= elt=? vector-a vector-b)
(or (eq? vector-a vector-b) ;+++
(let ((length-a (vector-length vector-a)))
(and (= length-a (vector-length vector-b))
(let loop ((i 0))
(or (= i length-a)
(and (elt=? (vector-ref vector-a i)
(vector-ref vector-b i))
;;;
;;; <predicates.ss> ---- Vector predicates
;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
;;;
;;; Copyright (C) 2005 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 predicates mzscheme
(require "util.ss")
(provide vector-empty?
vector=)
;;; (VECTOR-EMPTY? <vector>) -> boolean
;;; Return #T if VECTOR has zero elements in it, i.e. VECTOR's length
;;; is 0, and #F if not.
(define (vector-empty? vec)
(unless (vector? vec)
(raise-type-error 'vector-empty? "vector" vec))
(zero? (vector-length vec)))
;;; (VECTOR= <elt=?> <vector> ...) -> boolean
;;; (ELT=? <value> <value>) -> boolean
;;; Determine vector equality generalized across element comparators.
;;; Vectors A and B are equal iff their lengths are the same and for
;;; each respective elements E_a and E_b (element=? E_a E_b) returns
;;; a true value. ELT=? is always applied to two arguments. Element
;;; comparison must be consistent wtih EQ?; that is, if (eq? E_a E_b)
;;; results in a true value, then (ELEMENT=? E_a E_b) must result in a
;;; true value. This may be exploited to avoid multiple unnecessary
;;; element comparisons. (This implementation does, but does not deal
;;; with the situation that ELEMENT=? is EQ? to avoid more unnecessary
;;; comparisons, but I believe this optimization is probably fairly
;;; insignificant.)
;;;
;;; If the number of vector arguments is zero or one, then #T is
;;; automatically returned. If there are N vector arguments,
;;; VECTOR_1 VECTOR_2 ... VECTOR_N, then VECTOR_1 & VECTOR_2 are
;;; compared; if they are equal, the vectors VECTOR_2 ... VECTOR_N
;;; are compared. The precise order in which ELT=? is applied is not
;;; specified.
(define (vector= elt=? . vectors)
(unless (procedure-arity-includes? elt=? 2)
(apply raise-type-error
'vector= "procedure of arity 2" 0
elt=? vectors))
(cond ((null? vectors)
#t)
((null? (cdr vectors))
(unless (vector? (car vectors))
(apply raise-type-error
'vector= "vector" 1
elt=? vectors))
#t)
(else
(check-list-of-vecs vectors 'vector=
1 (cons elt=? vectors))
(let loop ((vecs vectors))
(let ((vec1 (car vecs))
(vec2+ (cdr vecs)))
(or (null? vec2+)
(and (binary-vector= elt=? vec1 (car vec2+))
(loop vec2+))))))))
(define (binary-vector= elt=? vector-a vector-b)
(or (eq? vector-a vector-b) ;+++
(let ((length-a (vector-length vector-a)))
(and (= length-a (vector-length vector-b))
(let loop ((i 0))
(or (= i length-a)
(and (elt=? (vector-ref vector-a i)
(vector-ref vector-b i))
(loop (add1 i))))))))))

596
collects/srfi/43/searching.ss
View File

@ -1,298 +1,298 @@
;;;
;;; <searching.ss> ---- Vector searching
;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
;;;
;;; Copyright (C) 2005 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 searching mzscheme
(require "util.ss")
(provide vector-index
vector-index-right
vector-skip
vector-skip-right
vector-binary-search
vector-any
vector-every)
;; All the functions (except vector-binary-search) here can be
;; abstracted, but for performance I didn't do so.
;;; (VECTOR-INDEX <predicate?> <vector> ...)
;;; -> exact, nonnegative integer or #F
;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
;;; Search left-to-right across VECTOR ... in parallel, returning the
;;; index of the first set of values VALUE ... such that (PREDICATE?
;;; VALUE ...) returns a true value; if no such set of elements is
;;; reached, return #F.
(define vector-index
(letrec ((loop1 (lambda (pred? vec len i)
(cond ((= i len) #f)
((pred? (vector-ref vec i)) i)
(else (loop1 pred? vec len (add1 i))))))
(loop2+ (lambda (pred? vectors len i)
(cond ((= i len) #f)
((apply pred? (vectors-ref vectors i)) i)
(else (loop2+ pred? vectors len (add1 i)))))))
(lambda (pred? vec . vectors)
(unless (procedure? pred?)
(apply raise-type-error
'vector-index "procedure" 0
pred? vec vectors))
(unless (vector? vec)
(apply raise-type-error
'vector-index "vector" 1
pred? vec vectors))
(if (null? vectors)
(loop1 pred? vec (vector-length vec) 0)
(begin (check-list-of-vecs vectors 'vector-index 2
(list* pred? vec vectors))
(loop2+ pred? (cons vec vectors)
(%smallest-length vectors
(vector-length vec))
0))))))
;;; (VECTOR-SKIP <predicate?> <vector> ...)
;;; -> exact, nonnegative integer or #F
;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
;;; (vector-index (lambda elts (not (apply PREDICATE? elts)))
;;; VECTOR ...)
;;; Like VECTOR-INDEX, but find the index of the first set of values
;;; that do _not_ satisfy PREDICATE?.
(define vector-skip
(letrec ((loop1 (lambda (pred? vec len i)
(cond ((= i len) #f)
((pred? (vector-ref vec i))
(loop1 pred? vec len (add1 i)))
(else i))))
(loop2+ (lambda (pred? vectors len i)
(cond ((= i len) #f)
((apply pred? (vectors-ref vectors i))
(loop2+ pred? vectors len (add1 i)))
(else i)))))
(lambda (pred? vec . vectors)
(unless (procedure? pred?)
(apply raise-type-error
'vector-skip "procedure" 0
pred? vec vectors))
(unless (vector? vec)
(apply raise-type-error
'vector-skip "vector" 1
pred? vec vectors))
(if (null? vectors)
(loop1 pred? vec (vector-length vec) 0)
(begin (check-list-of-vecs vectors 'vector-skip 2
(list* pred? vec vectors))
(loop2+ pred? (cons vec vectors)
(%smallest-length vectors
(vector-length vec))
0))))))
;;; (VECTOR-INDEX-RIGHT <predicate?> <vector> ...)
;;; -> exact, nonnegative integer or #F
;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
;;; Right-to-left variant of VECTOR-INDEX.
(define vector-index-right
(letrec ((loop1 (lambda (pred? vec i)
(if (zero? i)
#f
(let ((i (sub1 i)))
(if (pred? (vector-ref vec i))
i
(loop1 pred? vec i))))))
(loop2+ (lambda (pred? vectors i)
(if (zero? i)
#f
(let ((i (sub1 i)))
(if (apply pred? (vectors-ref vectors i))
i
(loop2+ pred? vectors i)))))))
(lambda (pred? vec . vectors)
(unless (procedure? pred?)
(apply raise-type-error
'vector-index-right "procedure" 0
pred? vec vectors))
(unless (vector? vec)
(apply raise-type-error
'vector-index-right "vector" 1
pred? vec vectors))
(if (null? vectors)
(loop1 pred? vec (vector-length vec))
(begin (check-list-of-vecs vectors 'vector-index-right 2
(list* pred? vec vectors))
(loop2+ pred? (cons vec vectors)
(%smallest-length vectors
(vector-length vec))))))))
;;; (VECTOR-SKIP-RIGHT <predicate?> <vector> ...)
;;; -> exact, nonnegative integer or #F
;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
;;; Right-to-left variant of VECTOR-SKIP.
(define vector-skip-right
(letrec ((loop1 (lambda (pred? vec i)
(if (zero? i)
#f
(let ((i (sub1 i)))
(if (pred? (vector-ref vec i))
(loop1 pred? vec i)
i)))))
(loop2+ (lambda (pred? vectors i)
(if (zero? i)
#f
(let ((i (sub1 i)))
(if (apply pred? (vectors-ref vectors i))
(loop2+ pred? vectors i)
i))))))
(lambda (pred? vec . vectors)
(unless (procedure? pred?)
(apply raise-type-error
'vector-skip-right "procedure" 0
pred? vec vectors))
(unless (vector? vec)
(apply raise-type-error
'vector-skip-right "vector" 1
pred? vec vectors))
(if (null? vectors)
(loop1 pred? vec (vector-length vec))
(begin (check-list-of-vecs vectors 'vector-skip-right 2
(list* pred? vec vectors))
(loop2+ pred? (cons vec vectors)
(%smallest-length vectors
(vector-length vec))))))))
;;; (VECTOR-BINARY-SEARCH <vector> <value> <cmp>)
;;; -> exact, nonnegative integer or #F
;;; (CMP <value1> <value2>) -> integer
;;; positive -> VALUE1 > VALUE2
;;; zero -> VALUE1 = VALUE2
;;; negative -> VALUE1 < VALUE2
;;; Perform a binary search through VECTOR for VALUE, comparing each
;;; element to VALUE with CMP.
(define (vector-binary-search vec value cmp)
(unless (vector? vec)
(raise-type-error 'vector-binary-search "vector" 0
vec value cmp))
(unless (procedure-arity-includes? cmp 2)
(raise-type-error 'vector-binary-search "procedure of arity 2" 2
vec value cmp))
(let loop ((start 0)
(end (vector-length vec))
(j -1))
(let ((i (quotient (+ start end) 2)))
(if (= i j)
#f
(let ((comparison (cmp (vector-ref vec i) value)))
(unless (integer? comparison)
(raise-type-error 'vector-binary-search
"procedure that returns an integer"
2
vec value cmp))
(cond ((zero? comparison) i)
((positive? comparison) (loop start i i))
(else (loop i end i))))))))
;;; (VECTOR-ANY <pred?> <vector> ...) -> value
;;; Apply PRED? to each parallel element in each VECTOR ...; if PRED?
;;; should ever return a true value, immediately stop and return that
;;; value; otherwise, when the shortest vector runs out, return #F.
;;; The iteration and order of application of PRED? across elements
;;; is of the vectors is strictly left-to-right.
(define vector-any
(letrec ((loop1 (lambda (pred? vec i len)
(and (not (= i len))
(or (pred? (vector-ref vec i))
(loop1 pred? vec (add1 i) len)))))
(loop2+ (lambda (pred? vectors i len)
(and (not (= i len))
(or (apply pred? (vectors-ref vectors i))
(loop2+ pred? vectors (add1 i) len))))))
(lambda (pred? vec . vectors)
(unless (procedure? pred?)
(apply raise-type-error
'vector-any "procedure" 0
pred? vec vectors))
(unless (vector? vec)
(apply raise-type-error
'vector-any "vector" 1
pred? vec vectors))
(if (null? vectors)
(loop1 pred? vec 0 (vector-length vec))
(begin (check-list-of-vecs vectors 'vector-any 2
(list* pred? vec vectors))
(loop2+ pred? (cons vec vectors)
0 (%smallest-length vectors
(vector-length vec))))))))
;;; (VECTOR-EVERY <pred?> <vector> ...) -> value
;;; Apply PRED? to each parallel value in each VECTOR ...; if PRED?
;;; should ever return #F, immediately stop and return #F; otherwise,
;;; if PRED? should return a true value for each element, stopping at
;;; the end of the shortest vector, return the last value that PRED?
;;; returned. In the case that there is an empty vector, return #T.
;;; The iteration and order of application of PRED? across elements
;;; is of the vectors is strictly left-to-right.
(define vector-every
(letrec ((loop1 (lambda (pred? vec i len)
(or (> i len)
(if (= i len)
(pred? (vector-ref vec i))
(and (pred? (vector-ref vec i))
(loop1 pred? vec (add1 i) len))))))
(loop2+ (lambda (pred? vectors i len)
(or (> i len)
(if (= i len)
(apply pred? (vectors-ref vectors i))
(and (apply pred? (vectors-ref vectors i))
(loop2+ pred? vectors (add1 i) len)))))))
(lambda (pred? vec . vectors)
(unless (procedure? pred?)
(apply raise-type-error
'vector-every "procedure" 0
pred? vec vectors))
(unless (vector? vec)
(apply raise-type-error
'vector-every "vector" 1
pred? vec vectors))
(if (null? vectors)
(loop1 pred? vec 0 (sub1 (vector-length vec)))
(begin (check-list-of-vecs vectors 'vector-every 2
(list* pred? vec vectors))
(loop2+ pred?
(cons vec vectors)
0
(sub1
(%smallest-length vectors
(vector-length vec))))))))))
;;;
;;; <searching.ss> ---- Vector searching
;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
;;;
;;; Copyright (C) 2005 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 searching mzscheme
(require "util.ss")
(provide vector-index
vector-index-right
vector-skip
vector-skip-right
vector-binary-search
vector-any
vector-every)
;; All the functions (except vector-binary-search) here can be
;; abstracted, but for performance I didn't do so.
;;; (VECTOR-INDEX <predicate?> <vector> ...)
;;; -> exact, nonnegative integer or #F
;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
;;; Search left-to-right across VECTOR ... in parallel, returning the
;;; index of the first set of values VALUE ... such that (PREDICATE?
;;; VALUE ...) returns a true value; if no such set of elements is
;;; reached, return #F.
(define vector-index
(letrec ((loop1 (lambda (pred? vec len i)
(cond ((= i len) #f)
((pred? (vector-ref vec i)) i)
(else (loop1 pred? vec len (add1 i))))))
(loop2+ (lambda (pred? vectors len i)
(cond ((= i len) #f)
((apply pred? (vectors-ref vectors i)) i)
(else (loop2+ pred? vectors len (add1 i)))))))
(lambda (pred? vec . vectors)
(unless (procedure? pred?)
(apply raise-type-error
'vector-index "procedure" 0
pred? vec vectors))
(unless (vector? vec)
(apply raise-type-error
'vector-index "vector" 1
pred? vec vectors))
(if (null? vectors)
(loop1 pred? vec (vector-length vec) 0)
(begin (check-list-of-vecs vectors 'vector-index 2
(list* pred? vec vectors))
(loop2+ pred? (cons vec vectors)
(%smallest-length vectors
(vector-length vec))
0))))))
;;; (VECTOR-SKIP <predicate?> <vector> ...)
;;; -> exact, nonnegative integer or #F
;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
;;; (vector-index (lambda elts (not (apply PREDICATE? elts)))
;;; VECTOR ...)
;;; Like VECTOR-INDEX, but find the index of the first set of values
;;; that do _not_ satisfy PREDICATE?.
(define vector-skip
(letrec ((loop1 (lambda (pred? vec len i)
(cond ((= i len) #f)
((pred? (vector-ref vec i))
(loop1 pred? vec len (add1 i)))
(else i))))
(loop2+ (lambda (pred? vectors len i)
(cond ((= i len) #f)
((apply pred? (vectors-ref vectors i))
(loop2+ pred? vectors len (add1 i)))
(else i)))))
(lambda (pred? vec . vectors)
(unless (procedure? pred?)
(apply raise-type-error
'vector-skip "procedure" 0
pred? vec vectors))
(unless (vector? vec)
(apply raise-type-error
'vector-skip "vector" 1
pred? vec vectors))
(if (null? vectors)
(loop1 pred? vec (vector-length vec) 0)
(begin (check-list-of-vecs vectors 'vector-skip 2
(list* pred? vec vectors))
(loop2+ pred? (cons vec vectors)
(%smallest-length vectors
(vector-length vec))
0))))))
;;; (VECTOR-INDEX-RIGHT <predicate?> <vector> ...)
;;; -> exact, nonnegative integer or #F
;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
;;; Right-to-left variant of VECTOR-INDEX.
(define vector-index-right
(letrec ((loop1 (lambda (pred? vec i)
(if (zero? i)
#f
(let ((i (sub1 i)))
(if (pred? (vector-ref vec i))
i
(loop1 pred? vec i))))))
(loop2+ (lambda (pred? vectors i)
(if (zero? i)
#f
(let ((i (sub1 i)))
(if (apply pred? (vectors-ref vectors i))
i
(loop2+ pred? vectors i)))))))
(lambda (pred? vec . vectors)
(unless (procedure? pred?)
(apply raise-type-error
'vector-index-right "procedure" 0
pred? vec vectors))
(unless (vector? vec)
(apply raise-type-error
'vector-index-right "vector" 1
pred? vec vectors))
(if (null? vectors)
(loop1 pred? vec (vector-length vec))
(begin (check-list-of-vecs vectors 'vector-index-right 2
(list* pred? vec vectors))
(loop2+ pred? (cons vec vectors)
(%smallest-length vectors
(vector-length vec))))))))
;;; (VECTOR-SKIP-RIGHT <predicate?> <vector> ...)
;;; -> exact, nonnegative integer or #F
;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
;;; Right-to-left variant of VECTOR-SKIP.
(define vector-skip-right
(letrec ((loop1 (lambda (pred? vec i)
(if (zero? i)
#f
(let ((i (sub1 i)))
(if (pred? (vector-ref vec i))
(loop1 pred? vec i)
i)))))
(loop2+ (lambda (pred? vectors i)
(if (zero? i)
#f
(let ((i (sub1 i)))
(if (apply pred? (vectors-ref vectors i))
(loop2+ pred? vectors i)
i))))))
(lambda (pred? vec . vectors)
(unless (procedure? pred?)
(apply raise-type-error
'vector-skip-right "procedure" 0
pred? vec vectors))
(unless (vector? vec)
(apply raise-type-error
'vector-skip-right "vector" 1
pred? vec vectors))
(if (null? vectors)
(loop1 pred? vec (vector-length vec))
(begin (check-list-of-vecs vectors 'vector-skip-right 2
(list* pred? vec vectors))
(loop2+ pred? (cons vec vectors)
(%smallest-length vectors
(vector-length vec))))))))
;;; (VECTOR-BINARY-SEARCH <vector> <value> <cmp>)
;;; -> exact, nonnegative integer or #F
;;; (CMP <value1> <value2>) -> integer
;;; positive -> VALUE1 > VALUE2
;;; zero -> VALUE1 = VALUE2
;;; negative -> VALUE1 < VALUE2
;;; Perform a binary search through VECTOR for VALUE, comparing each
;;; element to VALUE with CMP.
(define (vector-binary-search vec value cmp)
(unless (vector? vec)
(raise-type-error 'vector-binary-search "vector" 0
vec value cmp))
(unless (procedure-arity-includes? cmp 2)
(raise-type-error 'vector-binary-search "procedure of arity 2" 2
vec value cmp))
(let loop ((start 0)
(end (vector-length vec))
(j -1))
(let ((i (quotient (+ start end) 2)))
(if (= i j)
#f
(let ((comparison (cmp (vector-ref vec i) value)))
(unless (integer? comparison)
(raise-type-error 'vector-binary-search
"procedure that returns an integer"
2
vec value cmp))
(cond ((zero? comparison) i)
((positive? comparison) (loop start i i))
(else (loop i end i))))))))
;;; (VECTOR-ANY <pred?> <vector> ...) -> value
;;; Apply PRED? to each parallel element in each VECTOR ...; if PRED?
;;; should ever return a true value, immediately stop and return that
;;; value; otherwise, when the shortest vector runs out, return #F.
;;; The iteration and order of application of PRED? across elements
;;; is of the vectors is strictly left-to-right.
(define vector-any
(letrec ((loop1 (lambda (pred? vec i len)
(and (not (= i len))
(or (pred? (vector-ref vec i))
(loop1 pred? vec (add1 i) len)))))
(loop2+ (lambda (pred? vectors i len)
(and (not (= i len))
(or (apply pred? (vectors-ref vectors i))
(loop2+ pred? vectors (add1 i) len))))))
(lambda (pred? vec . vectors)
(unless (procedure? pred?)
(apply raise-type-error
'vector-any "procedure" 0
pred? vec vectors))
(unless (vector? vec)
(apply raise-type-error
'vector-any "vector" 1
pred? vec vectors))
(if (null? vectors)
(loop1 pred? vec 0 (vector-length vec))
(begin (check-list-of-vecs vectors 'vector-any 2
(list* pred? vec vectors))
(loop2+ pred? (cons vec vectors)
0 (%smallest-length vectors
(vector-length vec))))))))
;;; (VECTOR-EVERY <pred?> <vector> ...) -> value
;;; Apply PRED? to each parallel value in each VECTOR ...; if PRED?
;;; should ever return #F, immediately stop and return #F; otherwise,
;;; if PRED? should return a true value for each element, stopping at
;;; the end of the shortest vector, return the last value that PRED?
;;; returned. In the case that there is an empty vector, return #T.
;;; The iteration and order of application of PRED? across elements
;;; is of the vectors is strictly left-to-right.
(define vector-every
(letrec ((loop1 (lambda (pred? vec i len)
(or (> i len)
(if (= i len)
(pred? (vector-ref vec i))
(and (pred? (vector-ref vec i))
(loop1 pred? vec (add1 i) len))))))
(loop2+ (lambda (pred? vectors i len)
(or (> i len)
(if (= i len)
(apply pred? (vectors-ref vectors i))
(and (apply pred? (vectors-ref vectors i))
(loop2+ pred? vectors (add1 i) len)))))))
(lambda (pred? vec . vectors)
(unless (procedure? pred?)
(apply raise-type-error
'vector-every "procedure" 0
pred? vec vectors))
(unless (vector? vec)
(apply raise-type-error
'vector-every "vector" 1
pred? vec vectors))
(if (null? vectors)
(loop1 pred? vec 0 (sub1 (vector-length vec)))
(begin (check-list-of-vecs vectors 'vector-every 2
(list* pred? vec vectors))
(loop2+ pred?
(cons vec vectors)
0
(sub1
(%smallest-length vectors
(vector-length vec))))))))))

322
collects/srfi/43/util.ss
View File

@ -1,162 +1,162 @@
;;;
;;; <util.ss> ---- Utility functions
;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
;;;
;;; Copyright (C) 2005 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
(string->immutable-string
(format "~a: index ~a out of range for vector: ~a"
callee index vec))
(current-continuation-marks)))))
;;; (CHECK-START <vector> <index> <callee>) ->
;;; Ensure that INDEX is a valid bound of 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-start vec index callee)
(unless (nonneg-int? index)
(raise-type-error callee "non-negative exact integer" index))
(unless (<= 0 index (vector-length vec))
(raise
(make-exn:fail:contract
(string->immutable-string
(format "~a: index ~a out of range for vector: ~a"
callee index vec))
(current-continuation-marks)))))
;;; (CHECK-INDICES <vector> <start> <end> <caller>) ->
;;; Ensure that START and END are valid bounds of a range within
;;; VECTOR; if not, signal an error stating that they are not
;;; while calling CALLEE.
(define (check-indices vec start end callee)
(unless (nonneg-int? start)
(raise-type-error callee "non-negative exact integer" start))
(unless (nonneg-int? end)
(raise-type-error callee "non-negative exact integer" end))
(unless (<= 0 start end (vector-length vec))
(raise
(make-exn:fail:contract
(string->immutable-string
(format "~a: indices (~a, ~a) out of range for vector: ~a"
callee start end vec))
(current-continuation-marks)))))
(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! target tstart source sstart send)
(let loop ((i sstart)
(j tstart))
(cond ((< i send)
(vector-set! target j
(vector-ref source i))
(loop (add1 i) (add1 j))))))
;;; (%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)
;;;
;;; <util.ss> ---- Utility functions
;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
;;;
;;; Copyright (C) 2005 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
(string->immutable-string
(format "~a: index ~a out of range for vector: ~a"
callee index vec))
(current-continuation-marks)))))
;;; (CHECK-START <vector> <index> <callee>) ->
;;; Ensure that INDEX is a valid bound of 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-start vec index callee)
(unless (nonneg-int? index)
(raise-type-error callee "non-negative exact integer" index))
(unless (<= 0 index (vector-length vec))
(raise
(make-exn:fail:contract
(string->immutable-string
(format "~a: index ~a out of range for vector: ~a"
callee index vec))
(current-continuation-marks)))))
;;; (CHECK-INDICES <vector> <start> <end> <caller>) ->
;;; Ensure that START and END are valid bounds of a range within
;;; VECTOR; if not, signal an error stating that they are not
;;; while calling CALLEE.
(define (check-indices vec start end callee)
(unless (nonneg-int? start)
(raise-type-error callee "non-negative exact integer" start))
(unless (nonneg-int? end)
(raise-type-error callee "non-negative exact integer" end))
(unless (<= 0 start end (vector-length vec))
(raise
(make-exn:fail:contract
(string->immutable-string
(format "~a: indices (~a, ~a) out of range for vector: ~a"
callee start end vec))
(current-continuation-marks)))))
(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! target tstart source sstart send)
(let loop ((i sstart)
(j tstart))
(cond ((< i send)
(vector-set! target j
(vector-ref source i))
(loop (add1 i) (add1 j))))))
;;; (%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)))))

86
collects/srfi/43/vector-lib.ss
View File

@ -1,43 +1,43 @@
;;;
;;; <util.ss> ---- Utility functions
;;; Time-stamp: <05/03/07 18:21:41 Zhu Chongkai>
;;;
;;; Copyright (C) 2005 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>
;;
(module vector-lib mzscheme
(require "constructors.ss"
"predicates.ss"
"iteration.ss"
"searching.ss"
(all-except "mutators.ss" vector-fill!)
(rename "mutators.ss" s:vector-fill! vector-fill!)
(all-except "conversion.ss" vector->list)
(rename "conversion.ss" s:vector->list vector->list))
(provide
(all-from "constructors.ss")
(all-from "predicates.ss")
(all-from "iteration.ss")
(all-from "searching.ss")
(all-from "mutators.ss")
(all-from "conversion.ss")))
;;;
;;; <util.ss> ---- Utility functions
;;; Time-stamp: <05/03/07 18:21:41 Zhu Chongkai>
;;;
;;; Copyright (C) 2005 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>
;;
(module vector-lib mzscheme
(require "constructors.ss"
"predicates.ss"
"iteration.ss"
"searching.ss"
(all-except "mutators.ss" vector-fill!)
(rename "mutators.ss" s:vector-fill! vector-fill!)
(all-except "conversion.ss" vector->list)
(rename "conversion.ss" s:vector->list vector->list))
(provide
(all-from "constructors.ss")
(all-from "predicates.ss")
(all-from "iteration.ss")
(all-from "searching.ss")
(all-from "mutators.ss")
(all-from "conversion.ss")))

332
src/worksp/README
View File

@ -1,166 +1,166 @@
This directory contains
- solution files and project files for building MzScheme and
MrEd with Microsoft Visual Studio (which work with the .NET
and Express 2005 versions of Visual Studio);
- mzconfig.h which is a manual version of information that is
gathered automatically when using the "configure" script.
If you have downloaded MzCOM, the directory also contains Visual
Studio files for MzCOM.
Visual Studio Express is available for free from Microsoft, and it is
the recommended compiler for building PLT Scheme.
MzScheme (but not MzCOM or MrEd) also compiles with Cygwin gcc (a
free compiler from GNU and Cygnus Solutions); to compile with gcc,
follow the instructions in plt\src\README (there is a short
Windows-specific section in that file).
As always, please report bugs via one of the following:
- Help Desk's "submit bug report" link (preferred)
- http://bugs.plt-scheme.org/
- bugs@plt-scheme.org (last resort)
-PLT
scheme@plt-scheme.org
----------------------------------------------------------------------
Building MzScheme, MzCOM, and MrEd
----------------------------------------------------------------------
The source code for MzScheme, MzCOM, and MrEd is split into several
projects that are grouped into a few solutions. To make the `X'
solution with Visual Studio, open the file plt\src\worksp\X\X.sln.
[When you open a solution, the selected configuration will most likely
be "Debug". Consider changing to "Release" before you build to enable
optimization.]
To build MzScheme, make the MzScheme solution in
plt\src\worksp\mzscheme - makes plt\mzscheme.exe
To build MzCOM, make the MzCOM solution in
plt\src\worksp\mzcom - makes plt\collects\mzcom\mzcom.exe
To build MrEd, make the MrEd solution:
plt\src\worksp\mred - makes plt\mred.exe
The make processes for MzScheme and MzCOM automatically build
libmzgc - makes plt\libmzgcxxxxxxx.dll and
plt\src\worksp\libmzgc\Release\libmzgcxxxxxxx.lib
mzsrc - makes plt\libmzschxxxxxxx.dll and
plt\src\worksp\mzsrc\Release\mzsrcxxxxxxx.lib
The make process for MrEd automatically builds
libmzgc - as above
libmzsch - as above
libmred - makes plt\libmredxxxxxxx.dll and
plt\src\worksp\libmred\Release\libmredxxxxxxx.lib
pltdgi - makes plt\pltgdi_xxxxxxx.dll
wxutils - makes plt\src\worksp\wxutils\Release\wxutils.lib
wxwin - makes plt\src\worksp\wxwin\Release\wxwin.lib
wxs - makes plt\src\worksp\wxs\Release\wxs.lib
wxme - makes plt\src\worksp\wxme\Release\wxme.lib
jpeg - makes plt\src\worksp\jpeg\Release\jpeg.lib
png - makes plt\src\worksp\jpeg\Release\png.lib
zlib - makes plt\src\worksp\jpeg\Release\zlib.lib
In addition, building MzScheme executes
plt\src\mzscheme\dynsrc\mkmzdyn.bat
which copies .exp, .obj, and .lib files into plt\lib\, and also copies
uniplt_xxxxxxx.dll to plt\. The DLL is used only under Windows
95/98/Me for Unicode.
The pltgdi_xxxxxxx.dll is used for smoothed (i.e., anti-aliased)
drawing, but only when gdiplus.dll is available. If pltgdi_xxxxxxx.dll
or gdiplus.dll is not found by MrEd at run-time, smooth drawing is
disabled.
To complete a build, run the versioning script described in the next
section.
----------------------------------------------------------------------
Versioning
----------------------------------------------------------------------
The obnoxious "xxxxxxx" in the DLL names is a placeholder for a
version number. Embedding a version number in a DLL name appears to
be the simplest and surest way to avoid version confusion.
For local testing, you can use the "xxxxxxx" libraries directly. For
any binaries that will be distributed, however, the placeholder should
be replaced with a specific version.
To replace the "xxxxxxx" with a specific version, run
mzscheme -mvqL winvers.ss setup
in a shell. The "winvers.ss" program will have to make a temporary
copy of mzscheme.exe, libmzschxxxxxxx.dll, and libmzgcxxxxxxx.dll (in
the temporary directory), and it will re-launch MzScheme a couple of
times. The resulting conversions are
plt\mzscheme.exe -> plt\mzscheme.exe (updated)
plt\mred.exe -> plt\mred.exe (updated)
plt\mzcom.exe -> plt\mzcom.exe (updated)
plt\libmzgcxxxxxxx.dll -> plt\libmzgc<version>.dll
plt\libmzschxxxxxxx.dll -> plt\libmzsch<version>.dll
plt\libmredxxxxxxx.dll -> plt\libmred<version>.dll
plt\src\worksp\libmzsch\Release\libmzschxxxxxxx.lib
-> plt\lib\win32\msvc\libmzsch<version>.lib
plt\src\worksp\libmzgc\Release\libmzgcxxxxxxx.lib
-> plt\lib\win32\msvc\libmzgc<version>.lib
plt\pltgdi_xxxxxxx.dll -> plt\pltgdi_<version>.dll
plt\uniplt_xxxxxxx.dll -> plt\uniplt_<version>.dll
----------------------------------------------------------------------
Extra stuff for MzScheme and MrEd
----------------------------------------------------------------------
If you're building from scratch, you'll also want the starter
programs used by the launcher collection to make drscheme.exe
and mzc.exe:
mzstart - makes plt\collects\launcher\mzstart.exe
mrstart - makes plt\collects\launcher\mrstart.exe
Then, set up all the other executables (besides mred.exe
and mzscheme.exe) by running
mzscheme.exe -mvqM- setup
(This makes the .zo files, too. To skip compiling .zos,
add -n to the end of the above command.)
----------------------------------------------------------------------
Embedding MzScheme
----------------------------------------------------------------------
The MzScheme DLLs can be used within an embedding application.
The libraries
plt\src\worksp\libmzsch\Release\libmzschxxxxxxx.lib
plt\src\worksp\libmzgc\Release\libmzgcxxxxxxx.lib
which are created by the mzsrc and gc projects, provide linking
information for using the libmzschxxxxxxx.dll and libmzgcxxxxxxx.dll
DLLs. The versioning script adjusts the names and puts them in
plt\lib\msvc\libmzsch<version>.lib
plt\lib\msvc\libmzgc<version>.lib
See the "Inside PLT MzScheme" manual for more information about using
these libraries to embed MzScheme in an application.
If you need MzScheme to link to a DLL-based C library (instead of
statically linking to the C library within the MzScheme DLL), then:
1. Compile MzScheme with the /MD flag.
2. Define the pre-processor symbol USE_MSVC_MD_LIBRARY while
compiling the GC with /MD.
3. In your embedding application, call GC_pre_init() before calling
any MzScheme and GC function.
This directory contains
- solution files and project files for building MzScheme and
MrEd with Microsoft Visual Studio (which work with the .NET
and Express 2005 versions of Visual Studio);
- mzconfig.h which is a manual version of information that is
gathered automatically when using the "configure" script.
If you have downloaded MzCOM, the directory also contains Visual
Studio files for MzCOM.
Visual Studio Express is available for free from Microsoft, and it is
the recommended compiler for building PLT Scheme.
MzScheme (but not MzCOM or MrEd) also compiles with Cygwin gcc (a
free compiler from GNU and Cygnus Solutions); to compile with gcc,
follow the instructions in plt\src\README (there is a short
Windows-specific section in that file).
As always, please report bugs via one of the following:
- Help Desk's "submit bug report" link (preferred)
- http://bugs.plt-scheme.org/
- bugs@plt-scheme.org (last resort)
-PLT
scheme@plt-scheme.org
----------------------------------------------------------------------
Building MzScheme, MzCOM, and MrEd
----------------------------------------------------------------------
The source code for MzScheme, MzCOM, and MrEd is split into several
projects that are grouped into a few solutions. To make the `X'
solution with Visual Studio, open the file plt\src\worksp\X\X.sln.
[When you open a solution, the selected configuration will most likely
be "Debug". Consider changing to "Release" before you build to enable
optimization.]
To build MzScheme, make the MzScheme solution in
plt\src\worksp\mzscheme - makes plt\mzscheme.exe
To build MzCOM, make the MzCOM solution in
plt\src\worksp\mzcom - makes plt\collects\mzcom\mzcom.exe
To build MrEd, make the MrEd solution:
plt\src\worksp\mred - makes plt\mred.exe
The make processes for MzScheme and MzCOM automatically build
libmzgc - makes plt\libmzgcxxxxxxx.dll and
plt\src\worksp\libmzgc\Release\libmzgcxxxxxxx.lib
mzsrc - makes plt\libmzschxxxxxxx.dll and
plt\src\worksp\mzsrc\Release\mzsrcxxxxxxx.lib
The make process for MrEd automatically builds
libmzgc - as above
libmzsch - as above
libmred - makes plt\libmredxxxxxxx.dll and
plt\src\worksp\libmred\Release\libmredxxxxxxx.lib
pltdgi - makes plt\pltgdi_xxxxxxx.dll
wxutils - makes plt\src\worksp\wxutils\Release\wxutils.lib
wxwin - makes plt\src\worksp\wxwin\Release\wxwin.lib
wxs - makes plt\src\worksp\wxs\Release\wxs.lib
wxme - makes plt\src\worksp\wxme\Release\wxme.lib
jpeg - makes plt\src\worksp\jpeg\Release\jpeg.lib
png - makes plt\src\worksp\jpeg\Release\png.lib
zlib - makes plt\src\worksp\jpeg\Release\zlib.lib
In addition, building MzScheme executes
plt\src\mzscheme\dynsrc\mkmzdyn.bat
which copies .exp, .obj, and .lib files into plt\lib\, and also copies
uniplt_xxxxxxx.dll to plt\. The DLL is used only under Windows
95/98/Me for Unicode.
The pltgdi_xxxxxxx.dll is used for smoothed (i.e., anti-aliased)
drawing, but only when gdiplus.dll is available. If pltgdi_xxxxxxx.dll
or gdiplus.dll is not found by MrEd at run-time, smooth drawing is
disabled.
To complete a build, run the versioning script described in the next
section.
----------------------------------------------------------------------
Versioning
----------------------------------------------------------------------
The obnoxious "xxxxxxx" in the DLL names is a placeholder for a
version number. Embedding a version number in a DLL name appears to
be the simplest and surest way to avoid version confusion.
For local testing, you can use the "xxxxxxx" libraries directly. For
any binaries that will be distributed, however, the placeholder should
be replaced with a specific version.
To replace the "xxxxxxx" with a specific version, run
mzscheme -mvqL winvers.ss setup
in a shell. The "winvers.ss" program will have to make a temporary
copy of mzscheme.exe, libmzschxxxxxxx.dll, and libmzgcxxxxxxx.dll (in
the temporary directory), and it will re-launch MzScheme a couple of
times. The resulting conversions are
plt\mzscheme.exe -> plt\mzscheme.exe (updated)
plt\mred.exe -> plt\mred.exe (updated)
plt\mzcom.exe -> plt\mzcom.exe (updated)
plt\libmzgcxxxxxxx.dll -> plt\libmzgc<version>.dll
plt\libmzschxxxxxxx.dll -> plt\libmzsch<version>.dll
plt\libmredxxxxxxx.dll -> plt\libmred<version>.dll
plt\src\worksp\libmzsch\Release\libmzschxxxxxxx.lib
-> plt\lib\win32\msvc\libmzsch<version>.lib
plt\src\worksp\libmzgc\Release\libmzgcxxxxxxx.lib
-> plt\lib\win32\msvc\libmzgc<version>.lib
plt\pltgdi_xxxxxxx.dll -> plt\pltgdi_<version>.dll
plt\uniplt_xxxxxxx.dll -> plt\uniplt_<version>.dll
----------------------------------------------------------------------
Extra stuff for MzScheme and MrEd
----------------------------------------------------------------------
If you're building from scratch, you'll also want the starter
programs used by the launcher collection to make drscheme.exe
and mzc.exe:
mzstart - makes plt\collects\launcher\mzstart.exe
mrstart - makes plt\collects\launcher\mrstart.exe
Then, set up all the other executables (besides mred.exe
and mzscheme.exe) by running
mzscheme.exe -mvqM- setup
(This makes the .zo files, too. To skip compiling .zos,
add -n to the end of the above command.)
----------------------------------------------------------------------
Embedding MzScheme
----------------------------------------------------------------------
The MzScheme DLLs can be used within an embedding application.
The libraries
plt\src\worksp\libmzsch\Release\libmzschxxxxxxx.lib
plt\src\worksp\libmzgc\Release\libmzgcxxxxxxx.lib
which are created by the mzsrc and gc projects, provide linking
information for using the libmzschxxxxxxx.dll and libmzgcxxxxxxx.dll
DLLs. The versioning script adjusts the names and puts them in
plt\lib\msvc\libmzsch<version>.lib
plt\lib\msvc\libmzgc<version>.lib
See the "Inside PLT MzScheme" manual for more information about using
these libraries to embed MzScheme in an application.
If you need MzScheme to link to a DLL-based C library (instead of
statically linking to the C library within the MzScheme DLL), then:
1. Compile MzScheme with the /MD flag.
2. Define the pre-processor symbol USE_MSVC_MD_LIBRARY while
compiling the GC with /MD.
3. In your embedding application, call GC_pre_init() before calling
any MzScheme and GC function.

892
src/worksp/gc2/make.ss
View File

@ -1,446 +1,446 @@
(use-compiled-file-paths null)
(require (lib "restart.ss")
(lib "process.ss"))
(define (system- s)
(fprintf (current-error-port) "~a~n" s)
(system s))
(define accounting-gc? #t)
(define opt-flags "/O2")
(define re:only #f)
(unless (directory-exists? "xsrc")
(make-directory "xsrc"))
(define srcs
'("salloc"
"bignum"
"bool"
"builtin"
"char"
"complex"
"dynext"
"env"
"error"
"eval"
"file"
"fun"
"hash"
"image"
"list"
"module"
"network"
"numarith"
"number"
"numcomp"
"numstr"
"port"
"portfun"
"print"
"rational"
"read"
"regexp"
"sema"
"setjmpup"
"string"
"struct"
"symbol"
"syntax"
"stxobj"
"thread"
"type"
"vector"))
(define (try src deps dest objdest includes use-precomp extra-compile-flags expand-extra-flags msvc-pch)
(when (or (not re:only) (regexp-match re:only dest))
(unless (and (file-exists? dest)
(let ([t (file-or-directory-modify-seconds dest)])
(andmap
(lambda (dep)
(let ([dep (cond
[(bytes? dep) (bytes->path dep)]
[else dep])])
(> t (file-or-directory-modify-seconds dep))))
(append deps
(if use-precomp (list use-precomp) null)
(let ([deps (path-replace-suffix dest #".sdep")])
(if (file-exists? deps)
(with-input-from-file deps read)
null))))))
(unless (parameterize
([use-compiled-file-paths (list "compiled")])
(restart-mzscheme #() (lambda (x) x)
(list->vector
(append
(list "-r"
"../../mzscheme/gc2/xform.ss"
"--setup")
(if objdest
(if use-precomp
(list "--precompiled" use-precomp)
null)
(list "--precompile"))
(list
"--depends"
(format "cl.exe /MT /E ~a ~a" expand-extra-flags includes)
src
dest)))
void))
(when (file-exists? dest)
(delete-file dest))
(error "error xforming")))
(when objdest
(compile dest objdest null (string-append
extra-compile-flags
(if msvc-pch
(format " /Fp~a" msvc-pch)
""))))))
(define (compile c o deps flags)
(unless (and (file-exists? o)
(let ([t (file-or-directory-modify-seconds o)])
(and (>= t (file-or-directory-modify-seconds c))
(andmap
(lambda (f)
(>= t (file-or-directory-modify-seconds f)))
deps))))
(unless (system- (format "cl.exe ~a /MT /Zi ~a /c ~a /Fdxsrc/ /Fo~a" flags opt-flags c o))
(error "failed compile"))))
(define common-deps (list "../../mzscheme/gc2/xform.ss"
"../../mzscheme/gc2/xform-mod.ss"))
(define (find-obj f d) (format "../../worksp/~a/release/~a.obj" d f))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define mz-inc "/I ../../mzscheme/include /I .. ")
(try "precomp.c" (list* "../../mzscheme/src/schvers.h"
common-deps)
"xsrc/precomp.h" #f
(string-append mz-inc "/I ../../mzscheme/src")
#f "" "" #f)
(for-each
(lambda (x)
(try (format "../../mzscheme/src/~a.c" x)
(list* ; (find-obj x "libmzsch")
(format "../../mzscheme/src/~a.c" x)
common-deps)
(format "xsrc/~a.c" x)
(format "xsrc/~a.obj" x)
mz-inc
"xsrc/precomp.h"
""
""
"mz.pch"))
srcs)
(try "../../mzscheme/main.c"
(list* ; (find-obj "main" "mzscheme")
"../../mzscheme/main.c"
common-deps)
"xsrc/main.c"
"xsrc/main.obj"
mz-inc
#f
""
""
#f)
(try "../../foreign/foreign.c"
(list* ; (find-obj "main" "mzscheme")
"../../foreign/foreign.c"
common-deps)
"xsrc/foreign.c"
"xsrc/foreign.obj"
(string-append
mz-inc
"/I../../foreign/libffi_msvc "
"/I../../mzscheme/src ")
#f
""
""
#f)
(compile "../../mzscheme/gc2/gc2.c" "xsrc/gc2.obj"
(map (lambda (f) (build-path "../../mzscheme/gc2/" f))
'("gc2.c"
"compact.c"
"newgc.c"
"vm_win.c"
"sighand.c"
"msgprint.c"))
(string-append
"/D GC2_AS_EXPORT "
(if accounting-gc?
"/D NEWGC_BTC_ACCOUNT "
"/D USE_COMPACT_3M_GC")
mz-inc))
(compile "../../mzscheme/src/mzsj86.c" "xsrc/mzsj86.obj" '() mz-inc)
(define dll "../../../libmzsch3mxxxxxxx.dll")
(define exe "../../../MzScheme3m.exe")
(define libs "kernel32.lib user32.lib wsock32.lib shell32.lib advapi32.lib")
(define (link-dll objs sys-libs dll link-options exe?)
(let ([ms (if (file-exists? dll)
(file-or-directory-modify-seconds dll)
0)])
(when (ormap
(lambda (f)
(> (file-or-directory-modify-seconds f)
ms))
objs)
(unless (system- (format "cl.exe ~a /MT /Zi /Fe~a unicows.lib ~a ~a ~a"
(if exe? "" "/LD /DLL")
dll
(let loop ([objs (append objs sys-libs)])
(if (null? objs)
""
(string-append
(car objs)
" "
(loop (cdr objs)))))
libs
link-options))
(error 'winmake "~a link failed" (if exe? "EXE" "DLL"))))))
(let ([objs (list*
"../libmzsch/Release/uniplt.obj"
"xsrc/gc2.obj"
"xsrc/mzsj86.obj"
"xsrc/foreign.obj"
(find-obj "gmp" "libmzsch")
(find-obj "ffi" "libmzsch")
(find-obj "win32" "libmzsch")
(find-obj "prep_cif" "libmzsch")
(find-obj "types" "libmzsch")
(map
(lambda (n)
(format "xsrc/~a.obj" n))
srcs))])
(link-dll objs null dll "" #f))
(let ([objs (list
"xsrc/main.obj"
"../libmzsch/Release/uniplt.obj"
"../../../libmzsch3mxxxxxxx.lib")])
(link-dll objs null exe "" #t))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define wx-inc (string-append "/I ../../mzscheme/include "
"/I .. "
"/I ../../mzscheme/gc2 "
"/I ../../wxwindow/include/msw "
"/I ../../wxwindow/include/base "
"/I ../../mred/wxme "
"/I ../../wxwindow/contrib/wxxpm/libxpm.34b/lib "
"/I ../../wxWindow/contrib/fafa "
"/I ../../wxcommon/jpeg /I ../../worksp/jpeg /I ../../wxcommon/zlib "))
(try "wxprecomp.cxx" (list* "../../mzscheme/src/schvers.h" common-deps)
"xsrc/wxprecomp.h" #f wx-inc #f "" "-DGC2_AS_IMPORT" #f)
(define (wx-try base proj x use-precomp? suffix)
(let ([cxx-file (format "../../~a/~a.~a" base x suffix)])
(try cxx-file
(list* ; (find-obj x proj)
cxx-file
common-deps)
(format "xsrc/~a.~a" x suffix)
(format "xsrc/~a.obj" x)
wx-inc
(and use-precomp? "xsrc/wxprecomp.h")
"-DGC2_JUST_MACROS /FI../../../mzscheme/gc2/gc2.h"
"-DGC2_AS_IMPORT"
"wx.pch")))
(define wxwin-base-srcs
'("wb_canvs"
"wb_cmdlg"
"wb_data"
"wb_dc"
"wb_dialg"
"wb_frame"
"wb_gdi"
"wb_hash"
"wb_item"
"wb_list"
"wb_main"
"wb_obj"
"wb_panel"
"wb_print"
"wb_ps"
"wb_stdev"
"wb_sysev"
"wb_timer"
"wb_types"
"wb_utils"
"wb_win"))
(map (lambda (x)
(wx-try "wxwindow/src/base" "wxwin" x #t "cxx"))
wxwin-base-srcs)
(define wxwin-msw-srcs
'("wx_buttn"
"wx_canvs"
"wx_check"
"wx_choic"
"wx_clipb"
"wx_cmdlg"
"wx_dc"
"wx_dialg"
"wx_frame"
"wx_gauge"
"wx_gbox"
"wx_gdi"
"wx_graph_glue"
"wx_item"
"wx_lbox"
"wx_main"
"wx_menu"
"wx_messg"
"wx_panel"
"wx_pdf"
"wx_rbox"
"wx_slidr"
"wx_tabc"
"wx_timer"
"wx_utils"
"wx_win"
"wximgfil"))
(map (lambda (x)
(wx-try "wxwindow/src/msw" "wxwin" x #t "cxx"))
wxwin-msw-srcs)
(define wxs-srcs
'("wxs_bmap"
"wxs_butn"
"wxs_chce"
"wxs_ckbx"
"wxs_cnvs"
"wxs_dc"
"wxs_evnt"
"wxs_fram"
"wxs_gage"
"wxs_gdi"
"wxs_glob"
"wxs_item"
"wxs_lbox"
"wxs_madm"
"wxs_mede"
"wxs_medi"
"wxs_menu"
"wxs_mio"
"wxs_misc"
"wxs_mpb"
"wxs_obj"
"wxs_panl"
"wxs_rado"
"wxs_slid"
"wxs_snip"
"wxs_styl"
"wxs_tabc"
"wxs_win"
"wxscheme"))
(map (lambda (x)
(wx-try "mred/wxs" "wxs" x #t "cxx"))
wxs-srcs)
(define wxme-srcs
'("wx_cgrec"
"wx_keym"
"wx_mbuf"
"wx_medad"
"wx_media"
"wx_medio"
"wx_mline"
"wx_mpbrd"
"wx_mpriv"
"wx_msnip"
"wx_snip"
"wx_style"))
(map (lambda (x)
(wx-try "mred/wxme" "wxme" x #t "cxx"))
wxme-srcs)
(define mred-srcs
'("mred"
"mredmsw"))
(map (lambda (x)
(wx-try "mred" "libmred" x #t "cxx"))
mred-srcs)
(wx-try "wxcommon" "wxme" "wxJPEG" #t "cxx")
(wx-try "mzscheme/utils" "wxme" "xcglue" #f "c")
(compile "../../wxcommon/wxGC.cxx"
"xsrc/wxGC.obj"
(list "../../worksp/wxme/Release/wxGC.obj")
(string-append wx-inc " -DMZ_PRECISE_GC -DGC2_AS_IMPORT -Dwx_msw"))
(let ([objs (append (list
"../libmzsch/Release/uniplt.obj"
"xsrc/wxGC.obj"
"xsrc/wxJPEG.obj"
"xsrc/xcglue.obj")
(map
(lambda (n)
(format "xsrc/~a.obj" n))
(append wxwin-base-srcs
wxwin-msw-srcs
wxs-srcs
wxme-srcs
mred-srcs)))]
[libs (list
"../../../libmzsch3mxxxxxxx.lib"
"../../worksp/wxutils/Release/wxutils.lib"
"../../worksp/jpeg/Release/jpeg.lib"
"../../worksp/png/Release/png.lib"
"../../worksp/zlib/Release/zlib.lib")]
[win-libs (list
"comctl32.lib" "glu32.lib" "opengl32.lib"
"gdi32.lib" "comdlg32.lib" "advapi32.lib"
"shell32.lib" "ole32.lib" "oleaut32.lib"
"winmm.lib")])
(link-dll (append objs libs) win-libs "../../../libmred3mxxxxxxx.dll" "" #f))
(wx-try "mred" "mred" "mrmain" #f "cxx")
(unless (file-exists? "mred.res")
(system- (string-append
"rc /l 0x409 /I ../../wxwindow/include/msw /I ../../wxwindow/contrib/fafa "
"/fomred.res ../../worksp/mred/mred.rc")))
(let ([objs (list
"mred.res"
"xsrc/mrmain.obj"
"../libmzsch/Release/uniplt.obj"
"../../../libmzsch3mxxxxxxx.lib"
"../../../libmred3mxxxxxxx.lib")])
(link-dll objs (list "advapi32.lib") "../../../MrEd3m.exe" "/link /subsystem:windows" #t))
(system- "cl.exe /MT /O2 /DMZ_PRECISE_GC /I../../mzscheme/include /I.. /c ../../mzscheme/dynsrc/mzdyn.c /Fomzdyn3m.obj")
(system- "lib.exe -def:../../mzscheme/dynsrc/mzdyn.def -out:mzdyn3m.lib")
(define (copy-file/diff src dest)
(unless (and (file-exists? dest)
(string=? (with-input-from-file src (lambda () (read-string (file-size src))))
(with-input-from-file dest (lambda () (read-string (file-size dest))))))
(printf "Updating ~a~n" dest)
(when (file-exists? dest) (delete-file dest))
(copy-file src dest)))
(copy-file/diff "mzdyn3m.exp" "../../../lib/msvc/mzdyn3m.exp")
(copy-file/diff "mzdyn3m.obj" "../../../lib/msvc/mzdyn3m.obj")
(copy-file/diff "../../../libmzsch3mxxxxxxx.lib" "../../../lib/msvc/libmzsch3mxxxxxxx.lib")
(use-compiled-file-paths null)
(require (lib "restart.ss")
(lib "process.ss"))
(define (system- s)
(fprintf (current-error-port) "~a~n" s)
(system s))
(define accounting-gc? #t)
(define opt-flags "/O2")
(define re:only #f)
(unless (directory-exists? "xsrc")
(make-directory "xsrc"))
(define srcs
'("salloc"
"bignum"
"bool"
"builtin"
"char"
"complex"
"dynext"
"env"
"error"
"eval"
"file"
"fun"
"hash"
"image"
"list"
"module"
"network"
"numarith"
"number"
"numcomp"
"numstr"
"port"
"portfun"
"print"
"rational"
"read"
"regexp"
"sema"
"setjmpup"
"string"
"struct"
"symbol"
"syntax"
"stxobj"
"thread"
"type"
"vector"))
(define (try src deps dest objdest includes use-precomp extra-compile-flags expand-extra-flags msvc-pch)
(when (or (not re:only) (regexp-match re:only dest))
(unless (and (file-exists? dest)
(let ([t (file-or-directory-modify-seconds dest)])
(andmap
(lambda (dep)
(let ([dep (cond
[(bytes? dep) (bytes->path dep)]
[else dep])])
(> t (file-or-directory-modify-seconds dep))))
(append deps
(if use-precomp (list use-precomp) null)
(let ([deps (path-replace-suffix dest #".sdep")])
(if (file-exists? deps)
(with-input-from-file deps read)
null))))))
(unless (parameterize
([use-compiled-file-paths (list "compiled")])
(restart-mzscheme #() (lambda (x) x)
(list->vector
(append
(list "-r"
"../../mzscheme/gc2/xform.ss"
"--setup")
(if objdest
(if use-precomp
(list "--precompiled" use-precomp)
null)
(list "--precompile"))
(list
"--depends"
(format "cl.exe /MT /E ~a ~a" expand-extra-flags includes)
src
dest)))
void))
(when (file-exists? dest)
(delete-file dest))
(error "error xforming")))
(when objdest
(compile dest objdest null (string-append
extra-compile-flags
(if msvc-pch
(format " /Fp~a" msvc-pch)
""))))))
(define (compile c o deps flags)
(unless (and (file-exists? o)
(let ([t (file-or-directory-modify-seconds o)])
(and (>= t (file-or-directory-modify-seconds c))
(andmap
(lambda (f)
(>= t (file-or-directory-modify-seconds f)))
deps))))
(unless (system- (format "cl.exe ~a /MT /Zi ~a /c ~a /Fdxsrc/ /Fo~a" flags opt-flags c o))
(error "failed compile"))))
(define common-deps (list "../../mzscheme/gc2/xform.ss"
"../../mzscheme/gc2/xform-mod.ss"))
(define (find-obj f d) (format "../../worksp/~a/release/~a.obj" d f))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define mz-inc "/I ../../mzscheme/include /I .. ")
(try "precomp.c" (list* "../../mzscheme/src/schvers.h"
common-deps)
"xsrc/precomp.h" #f
(string-append mz-inc "/I ../../mzscheme/src")
#f "" "" #f)
(for-each
(lambda (x)
(try (format "../../mzscheme/src/~a.c" x)
(list* ; (find-obj x "libmzsch")
(format "../../mzscheme/src/~a.c" x)
common-deps)
(format "xsrc/~a.c" x)
(format "xsrc/~a.obj" x)
mz-inc
"xsrc/precomp.h"
""
""
"mz.pch"))
srcs)
(try "../../mzscheme/main.c"
(list* ; (find-obj "main" "mzscheme")
"../../mzscheme/main.c"
common-deps)
"xsrc/main.c"
"xsrc/main.obj"
mz-inc
#f
""
""
#f)
(try "../../foreign/foreign.c"
(list* ; (find-obj "main" "mzscheme")
"../../foreign/foreign.c"
common-deps)
"xsrc/foreign.c"
"xsrc/foreign.obj"
(string-append
mz-inc
"/I../../foreign/libffi_msvc "
"/I../../mzscheme/src ")
#f
""
""
#f)
(compile "../../mzscheme/gc2/gc2.c" "xsrc/gc2.obj"
(map (lambda (f) (build-path "../../mzscheme/gc2/" f))
'("gc2.c"
"compact.c"
"newgc.c"
"vm_win.c"
"sighand.c"
"msgprint.c"))
(string-append
"/D GC2_AS_EXPORT "
(if accounting-gc?
"/D NEWGC_BTC_ACCOUNT "
"/D USE_COMPACT_3M_GC")
mz-inc))
(compile "../../mzscheme/src/mzsj86.c" "xsrc/mzsj86.obj" '() mz-inc)
(define dll "../../../libmzsch3mxxxxxxx.dll")
(define exe "../../../MzScheme3m.exe")
(define libs "kernel32.lib user32.lib wsock32.lib shell32.lib advapi32.lib")
(define (link-dll objs sys-libs dll link-options exe?)
(let ([ms (if (file-exists? dll)
(file-or-directory-modify-seconds dll)
0)])
(when (ormap
(lambda (f)
(> (file-or-directory-modify-seconds f)
ms))
objs)
(unless (system- (format "cl.exe ~a /MT /Zi /Fe~a unicows.lib ~a ~a ~a"
(if exe? "" "/LD /DLL")
dll
(let loop ([objs (append objs sys-libs)])
(if (null? objs)
""
(string-append
(car objs)
" "
(loop (cdr objs)))))
libs
link-options))
(error 'winmake "~a link failed" (if exe? "EXE" "DLL"))))))
(let ([objs (list*
"../libmzsch/Release/uniplt.obj"
"xsrc/gc2.obj"
"xsrc/mzsj86.obj"
"xsrc/foreign.obj"
(find-obj "gmp" "libmzsch")
(find-obj "ffi" "libmzsch")
(find-obj "win32" "libmzsch")
(find-obj "prep_cif" "libmzsch")
(find-obj "types" "libmzsch")
(map
(lambda (n)
(format "xsrc/~a.obj" n))
srcs))])
(link-dll objs null dll "" #f))
(let ([objs (list
"xsrc/main.obj"
"../libmzsch/Release/uniplt.obj"
"../../../libmzsch3mxxxxxxx.lib")])
(link-dll objs null exe "" #t))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define wx-inc (string-append "/I ../../mzscheme/include "
"/I .. "
"/I ../../mzscheme/gc2 "
"/I ../../wxwindow/include/msw "
"/I ../../wxwindow/include/base "
"/I ../../mred/wxme "
"/I ../../wxwindow/contrib/wxxpm/libxpm.34b/lib "
"/I ../../wxWindow/contrib/fafa "
"/I ../../wxcommon/jpeg /I ../../worksp/jpeg /I ../../wxcommon/zlib "))
(try "wxprecomp.cxx" (list* "../../mzscheme/src/schvers.h" common-deps)
"xsrc/wxprecomp.h" #f wx-inc #f "" "-DGC2_AS_IMPORT" #f)
(define (wx-try base proj x use-precomp? suffix)
(let ([cxx-file (format "../../~a/~a.~a" base x suffix)])
(try cxx-file
(list* ; (find-obj x proj)
cxx-file
common-deps)
(format "xsrc/~a.~a" x suffix)
(format "xsrc/~a.obj" x)
wx-inc
(and use-precomp? "xsrc/wxprecomp.h")
"-DGC2_JUST_MACROS /FI../../../mzscheme/gc2/gc2.h"
"-DGC2_AS_IMPORT"
"wx.pch")))
(define wxwin-base-srcs
'("wb_canvs"
"wb_cmdlg"
"wb_data"
"wb_dc"
"wb_dialg"
"wb_frame"
"wb_gdi"
"wb_hash"
"wb_item"
"wb_list"
"wb_main"
"wb_obj"
"wb_panel"
"wb_print"
"wb_ps"
"wb_stdev"
"wb_sysev"
"wb_timer"
"wb_types"
"wb_utils"
"wb_win"))
(map (lambda (x)
(wx-try "wxwindow/src/base" "wxwin" x #t "cxx"))
wxwin-base-srcs)
(define wxwin-msw-srcs
'("wx_buttn"
"wx_canvs"
"wx_check"
"wx_choic"
"wx_clipb"
"wx_cmdlg"
"wx_dc"
"wx_dialg"
"wx_frame"
"wx_gauge"
"wx_gbox"
"wx_gdi"
"wx_graph_glue"
"wx_item"
"wx_lbox"
"wx_main"
"wx_menu"
"wx_messg"
"wx_panel"
"wx_pdf"
"wx_rbox"
"wx_slidr"
"wx_tabc"
"wx_timer"
"wx_utils"
"wx_win"
"wximgfil"))
(map (lambda (x)
(wx-try "wxwindow/src/msw" "wxwin" x #t "cxx"))
wxwin-msw-srcs)
(define wxs-srcs
'("wxs_bmap"
"wxs_butn"
"wxs_chce"
"wxs_ckbx"
"wxs_cnvs"
"wxs_dc"
"wxs_evnt"
"wxs_fram"
"wxs_gage"
"wxs_gdi"
"wxs_glob"
"wxs_item"
"wxs_lbox"
"wxs_madm"
"wxs_mede"
"wxs_medi"
"wxs_menu"
"wxs_mio"
"wxs_misc"
"wxs_mpb"
"wxs_obj"
"wxs_panl"
"wxs_rado"
"wxs_slid"
"wxs_snip"
"wxs_styl"
"wxs_tabc"
"wxs_win"
"wxscheme"))
(map (lambda (x)
(wx-try "mred/wxs" "wxs" x #t "cxx"))
wxs-srcs)
(define wxme-srcs
'("wx_cgrec"
"wx_keym"
"wx_mbuf"
"wx_medad"
"wx_media"
"wx_medio"
"wx_mline"
"wx_mpbrd"
"wx_mpriv"
"wx_msnip"
"wx_snip"
"wx_style"))
(map (lambda (x)
(wx-try "mred/wxme" "wxme" x #t "cxx"))
wxme-srcs)
(define mred-srcs
'("mred"
"mredmsw"))
(map (lambda (x)
(wx-try "mred" "libmred" x #t "cxx"))
mred-srcs)
(wx-try "wxcommon" "wxme" "wxJPEG" #t "cxx")
(wx-try "mzscheme/utils" "wxme" "xcglue" #f "c")
(compile "../../wxcommon/wxGC.cxx"
"xsrc/wxGC.obj"
(list "../../worksp/wxme/Release/wxGC.obj")
(string-append wx-inc " -DMZ_PRECISE_GC -DGC2_AS_IMPORT -Dwx_msw"))
(let ([objs (append (list
"../libmzsch/Release/uniplt.obj"
"xsrc/wxGC.obj"
"xsrc/wxJPEG.obj"
"xsrc/xcglue.obj")
(map
(lambda (n)
(format "xsrc/~a.obj" n))
(append wxwin-base-srcs
wxwin-msw-srcs
wxs-srcs
wxme-srcs
mred-srcs)))]
[libs (list
"../../../libmzsch3mxxxxxxx.lib"
"../../worksp/wxutils/Release/wxutils.lib"
"../../worksp/jpeg/Release/jpeg.lib"
"../../worksp/png/Release/png.lib"
"../../worksp/zlib/Release/zlib.lib")]
[win-libs (list
"comctl32.lib" "glu32.lib" "opengl32.lib"
"gdi32.lib" "comdlg32.lib" "advapi32.lib"
"shell32.lib" "ole32.lib" "oleaut32.lib"
"winmm.lib")])
(link-dll (append objs libs) win-libs "../../../libmred3mxxxxxxx.dll" "" #f))
(wx-try "mred" "mred" "mrmain" #f "cxx")
(unless (file-exists? "mred.res")
(system- (string-append
"rc /l 0x409 /I ../../wxwindow/include/msw /I ../../wxwindow/contrib/fafa "
"/fomred.res ../../worksp/mred/mred.rc")))
(let ([objs (list
"mred.res"
"xsrc/mrmain.obj"
"../libmzsch/Release/uniplt.obj"
"../../../libmzsch3mxxxxxxx.lib"
"../../../libmred3mxxxxxxx.lib")])
(link-dll objs (list "advapi32.lib") "../../../MrEd3m.exe" "/link /subsystem:windows" #t))
(system- "cl.exe /MT /O2 /DMZ_PRECISE_GC /I../../mzscheme/include /I.. /c ../../mzscheme/dynsrc/mzdyn.c /Fomzdyn3m.obj")
(system- "lib.exe -def:../../mzscheme/dynsrc/mzdyn.def -out:mzdyn3m.lib")
(define (copy-file/diff src dest)
(unless (and (file-exists? dest)
(string=? (with-input-from-file src (lambda () (read-string (file-size src))))
(with-input-from-file dest (lambda () (read-string (file-size dest))))))
(printf "Updating ~a~n" dest)
(when (file-exists? dest) (delete-file dest))
(copy-file src dest)))
(copy-file/diff "mzdyn3m.exp" "../../../lib/msvc/mzdyn3m.exp")
(copy-file/diff "mzdyn3m.obj" "../../../lib/msvc/mzdyn3m.obj")
(copy-file/diff "../../../libmzsch3mxxxxxxx.lib" "../../../lib/msvc/libmzsch3mxxxxxxx.lib")

44
src/worksp/mzconfig.h
View File

@ -1,22 +1,22 @@
/* This file contains information for Windows that is collected using the
* "configure" script on other platforms. See src/mzscheme/mzconfig.h.in for
* things that should be defined here.
*/
/* These are not used on Windows. */
/* The size of a `char', as computed by sizeof. */
#undef SIZEOF_CHAR
/* The size of a `int', as computed by sizeof. */
#undef SIZEOF_INT
/* The size of a `short', as computed by sizeof. */
#undef SIZEOF_SHORT
/* The size of a `long', as computed by sizeof. */
#undef SIZEOF_LONG
/* The size of a `long long', as computed by sizeof. */
#undef SIZEOF_LONG_LONG
/* This file contains information for Windows that is collected using the
* "configure" script on other platforms. See src/mzscheme/mzconfig.h.in for
* things that should be defined here.
*/
/* These are not used on Windows. */
/* The size of a `char', as computed by sizeof. */
#undef SIZEOF_CHAR
/* The size of a `int', as computed by sizeof. */
#undef SIZEOF_INT
/* The size of a `short', as computed by sizeof. */
#undef SIZEOF_SHORT
/* The size of a `long', as computed by sizeof. */
#undef SIZEOF_LONG
/* The size of a `long long', as computed by sizeof. */
#undef SIZEOF_LONG_LONG