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

78
collects/icons/help32x32.xpm
View File

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

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

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

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

@ -1,218 +1,218 @@
;;; ;;;
;;; <constructors.ss> ---- Vector constructors ;;; <constructors.ss> ---- Vector constructors
;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> ;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
;;; ;;;
;;; Copyright (C) 2005 by Zhu Chongkai. ;;; Copyright (C) 2005 by Zhu Chongkai.
;;; ;;;
;;; This file is part of SRFI-43. ;;; This file is part of SRFI-43.
;;; SRFI-43 is free software; you can redistribute it and/or ;;; SRFI-43 is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public ;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either ;;; License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version. ;;; 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, ;;; SRFI-43 is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details. ;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public ;;; You should have received a copy of the GNU Lesser General Public
;;; License along with SRFI-43; if not, write to the Free Software ;;; License along with SRFI-43; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Zhu Chongkai <mrmathematica@yahoo.com> ;;; Author: Zhu Chongkai <mrmathematica@yahoo.com>
;; ;;
;; ;;
;; Commentary: ;; Commentary:
;; Based on the reference implementation by Taylor Campbell and hence: ;; Based on the reference implementation by Taylor Campbell and hence:
;;; Copyright (C) 2003, 2004 Taylor Campbell. ;;; Copyright (C) 2003, 2004 Taylor Campbell.
;;; All rights reserved. ;;; All rights reserved.
;;; ;;;
;;; You may do as you please with this code, as long as you refrain ;;; 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_ ;;; from removing this copyright notice or holding me liable in _any_
;;; circumstances for _any_ damages that may be caused by it; and you ;;; 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. ;;; may quote sections from it as you please, as long as you credit me.
(module constructors mzscheme (module constructors mzscheme
(require (lib "receive.ss" "srfi" "8") (require (lib "receive.ss" "srfi" "8")
"util.ss" "util.ss"
(lib "etc.ss" "mzlib")) (lib "etc.ss" "mzlib"))
(provide vector-unfold (provide vector-unfold
vector-unfold-right vector-unfold-right
vector-copy vector-copy
vector-reverse-copy vector-reverse-copy
vector-append vector-append
vector-concatenate) vector-concatenate)
;;; (VECTOR-UNFOLD <f> <length> <initial-seed> ...) -> vector ;;; (VECTOR-UNFOLD <f> <length> <initial-seed> ...) -> vector
;;; (F <index> <seed> ...) -> [elt seed' ...] ;;; (F <index> <seed> ...) -> [elt seed' ...]
;;; The fundamental vector constructor. Creates a vector whose ;;; The fundamental vector constructor. Creates a vector whose
;;; length is LENGTH and iterates across each index K between 0 and ;;; length is LENGTH and iterates across each index K between 0 and
;;; LENGTH, applying F at each iteration to the current index and the ;;; 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 ;;; 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. ;;; the Kth slot and then N new seeds for the next iteration.
(define vector-unfold (define vector-unfold
(letrec ((tabulate! ; Special zero-seed case. (letrec ((tabulate! ; Special zero-seed case.
(lambda (f vec i len) (lambda (f vec i len)
(cond ((< i len) (cond ((< i len)
(vector-set! vec i (f i)) (vector-set! vec i (f i))
(tabulate! f vec (add1 i) len))))) (tabulate! f vec (add1 i) len)))))
(unfold1! ; Fast path for one seed. (unfold1! ; Fast path for one seed.
(lambda (f vec i len seed) (lambda (f vec i len seed)
(if (< i len) (if (< i len)
(receive (elt new-seed) (receive (elt new-seed)
(f i seed) (f i seed)
(vector-set! vec i elt) (vector-set! vec i elt)
(unfold1! f vec (add1 i) len new-seed))))) (unfold1! f vec (add1 i) len new-seed)))))
(unfold2+! ; Slower variant for N seeds. (unfold2+! ; Slower variant for N seeds.
(lambda (f vec i len seeds) (lambda (f vec i len seeds)
(if (< i len) (if (< i len)
(receive (elt . new-seeds) (receive (elt . new-seeds)
(apply f i seeds) (apply f i seeds)
(vector-set! vec i elt) (vector-set! vec i elt)
(unfold2+! f vec (add1 i) len new-seeds)))))) (unfold2+! f vec (add1 i) len new-seeds))))))
(lambda (f len . initial-seeds) (lambda (f len . initial-seeds)
(unless (procedure? f) (unless (procedure? f)
(apply raise-type-error (apply raise-type-error
'vector-unfold "procedure" 0 'vector-unfold "procedure" 0
f len initial-seeds)) f len initial-seeds))
(unless (nonneg-int? len) (unless (nonneg-int? len)
(apply raise-type-error (apply raise-type-error
'vector-unfold "non-negative exact integer" 1 'vector-unfold "non-negative exact integer" 1
f len initial-seeds)) f len initial-seeds))
(let ((vec (make-vector len))) (let ((vec (make-vector len)))
(cond ((null? initial-seeds) (cond ((null? initial-seeds)
(tabulate! f vec 0 len)) (tabulate! f vec 0 len))
((null? (cdr initial-seeds)) ((null? (cdr initial-seeds))
(unfold1! f vec 0 len (car initial-seeds))) (unfold1! f vec 0 len (car initial-seeds)))
(else (else
(unfold2+! f vec 0 len initial-seeds))) (unfold2+! f vec 0 len initial-seeds)))
vec)))) vec))))
;;; (VECTOR-UNFOLD-RIGHT <f> <length> <initial-seed> ...) -> vector ;;; (VECTOR-UNFOLD-RIGHT <f> <length> <initial-seed> ...) -> vector
;;; (F <seed> ...) -> [seed' ...] ;;; (F <seed> ...) -> [seed' ...]
;;; Like VECTOR-UNFOLD, but it generates elements from LENGTH to 0 ;;; Like VECTOR-UNFOLD, but it generates elements from LENGTH to 0
;;; (still exclusive with LENGTH and inclusive with 0), not 0 to ;;; (still exclusive with LENGTH and inclusive with 0), not 0 to
;;; LENGTH as with VECTOR-UNFOLD. ;;; LENGTH as with VECTOR-UNFOLD.
(define vector-unfold-right (define vector-unfold-right
(letrec ((tabulate! (letrec ((tabulate!
(lambda (f vec i) (lambda (f vec i)
(cond ((>= i 0) (cond ((>= i 0)
(vector-set! vec i (f i)) (vector-set! vec i (f i))
(tabulate! f vec (sub1 i)))))) (tabulate! f vec (sub1 i))))))
(unfold2+! (unfold2+!
(lambda (f vec i seeds) (lambda (f vec i seeds)
(if (>= i 0) (if (>= i 0)
(receive (elt . new-seeds) (receive (elt . new-seeds)
(apply f i seeds) (apply f i seeds)
(vector-set! vec i elt) (vector-set! vec i elt)
(unfold2+! f vec (sub1 i) new-seeds)))))) (unfold2+! f vec (sub1 i) new-seeds))))))
(lambda (f len . initial-seeds) (lambda (f len . initial-seeds)
(unless (procedure? f) (unless (procedure? f)
(apply raise-type-error (apply raise-type-error
'vector-unfold-right "procedure" 0 'vector-unfold-right "procedure" 0
f len initial-seeds)) f len initial-seeds))
(unless (nonneg-int? len) (unless (nonneg-int? len)
(apply raise-type-error (apply raise-type-error
'vector-unfold-right "non-negative exact integer" 1 'vector-unfold-right "non-negative exact integer" 1
f len initial-seeds)) f len initial-seeds))
(let ((vec (make-vector len)) (let ((vec (make-vector len))
(i (sub1 len))) (i (sub1 len)))
(cond ((null? initial-seeds) (cond ((null? initial-seeds)
(tabulate! f vec i)) (tabulate! f vec i))
((null? (cdr initial-seeds)) ((null? (cdr initial-seeds))
(unfold1! f vec i (car initial-seeds))) (unfold1! f vec i (car initial-seeds)))
(else (else
(unfold2+! f vec i initial-seeds))) (unfold2+! f vec i initial-seeds)))
vec)))) vec))))
;;; (VECTOR-COPY <vector> [<start> <end> <fill>]) -> vector ;;; (VECTOR-COPY <vector> [<start> <end> <fill>]) -> vector
;;; Create a newly allocated vector containing the elements from the ;;; Create a newly allocated vector containing the elements from the
;;; range [START,END) in VECTOR. START defaults to 0; END defaults ;;; range [START,END) in VECTOR. START defaults to 0; END defaults
;;; to the length of VECTOR. END may be greater than the length of ;;; 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, ;;; VECTOR, in which case the vector is enlarged; if FILL is passed,
;;; the new locations from which there is no respective element in ;;; the new locations from which there is no respective element in
;;; VECTOR are filled with FILL. ;;; VECTOR are filled with FILL.
(define (vector-copy vec . arg) (define (vector-copy vec . arg)
(unless (vector? vec) (unless (vector? vec)
(raise-type-error 'vector-copy "vector" vec)) (raise-type-error 'vector-copy "vector" vec))
(apply (apply
(opt-lambda (vec (start 0) (end (vector-length vec)) . fill) (opt-lambda (vec (start 0) (end (vector-length vec)) . fill)
(check-start vec start 'vector-copy) (check-start vec start 'vector-copy)
(unless (nonneg-int? end) (unless (nonneg-int? end)
(raise-type-error 'vector-copy "non-negative exact integer" end)) (raise-type-error 'vector-copy "non-negative exact integer" end))
(unless (<= start end) (unless (<= start end)
(raise (raise
(make-exn:fail:contract (make-exn:fail:contract
(string->immutable-string (string->immutable-string
(format "~a: indices (~a, ~a) out of range for vector: ~a" (format "~a: indices (~a, ~a) out of range for vector: ~a"
'vector-copy start end vec)) 'vector-copy start end vec))
(current-continuation-marks)))) (current-continuation-marks))))
(let ((new-vector (let ((new-vector
(apply make-vector (cons (- end start) fill)))) (apply make-vector (cons (- end start) fill))))
(%vector-copy! new-vector 0 (%vector-copy! new-vector 0
vec start vec start
(min end (vector-length vec))) (min end (vector-length vec)))
new-vector)) new-vector))
vec arg)) vec arg))
;;; (VECTOR-REVERSE-COPY <vector> [<start> <end>]) -> vector ;;; (VECTOR-REVERSE-COPY <vector> [<start> <end>]) -> vector
;;; Create a newly allocated vector whose elements are the reversed ;;; Create a newly allocated vector whose elements are the reversed
;;; sequence of elements between START and END in VECTOR. START's ;;; sequence of elements between START and END in VECTOR. START's
;;; default is 0; END's default is the length of VECTOR. ;;; default is 0; END's default is the length of VECTOR.
(define (vector-reverse-copy vec . arg) (define (vector-reverse-copy vec . arg)
(unless (vector? vec) (unless (vector? vec)
(raise-type-error 'vector-reverse-copy "vector" vec)) (raise-type-error 'vector-reverse-copy "vector" vec))
(apply (apply
(opt-lambda (vec (start 0) (end (vector-length vec))) (opt-lambda (vec (start 0) (end (vector-length vec)))
(check-indices vec start end 'vector-reverse-copy) (check-indices vec start end 'vector-reverse-copy)
(let ((new (make-vector (- end start)))) (let ((new (make-vector (- end start))))
(%vector-reverse-copy! new 0 vec start end) (%vector-reverse-copy! new 0 vec start end)
new)) new))
vec arg)) vec arg))
;;; (VECTOR-APPEND <vector> ...) -> vector ;;; (VECTOR-APPEND <vector> ...) -> vector
;;; Append VECTOR ... into a newly allocated vector and return that ;;; Append VECTOR ... into a newly allocated vector and return that
;;; new vector. ;;; new vector.
(define (vector-append . vectors) (define (vector-append . vectors)
(check-list-of-vecs vectors 'vector-append) (check-list-of-vecs vectors 'vector-append)
(vector-concatenate:aux vectors)) (vector-concatenate:aux vectors))
;;; (VECTOR-CONCATENATE <vector-list>) -> vector ;;; (VECTOR-CONCATENATE <vector-list>) -> vector
;;; Concatenate the vectors in VECTOR-LIST. This is equivalent to ;;; Concatenate the vectors in VECTOR-LIST. This is equivalent to
;;; (apply vector-append VECTOR-LIST) ;;; (apply vector-append VECTOR-LIST)
;;; Actually, they're both implemented in terms of an internal routine. ;;; Actually, they're both implemented in terms of an internal routine.
(define (vector-concatenate vector-list) (define (vector-concatenate vector-list)
(unless (and (list? vector-list) (unless (and (list? vector-list)
(andmap vector? vector-list)) (andmap vector? vector-list))
(raise-type-error 'vector-concatenate "list of vectors" vector-list)) (raise-type-error 'vector-concatenate "list of vectors" vector-list))
(vector-concatenate:aux vector-list)) (vector-concatenate:aux vector-list))
;;; Auxiliary for VECTOR-APPEND and VECTOR-CONCATENATE ;;; Auxiliary for VECTOR-APPEND and VECTOR-CONCATENATE
(define vector-concatenate:aux (define vector-concatenate:aux
(letrec ((compute-length (letrec ((compute-length
(lambda (vectors len) (lambda (vectors len)
(if (null? vectors) (if (null? vectors)
len len
(let ((vec (car vectors))) (let ((vec (car vectors)))
(compute-length (cdr vectors) (compute-length (cdr vectors)
(+ (vector-length vec) len)))))) (+ (vector-length vec) len))))))
(concatenate! (concatenate!
(lambda (vectors target to) (lambda (vectors target to)
(if (null? vectors) (if (null? vectors)
target target
(let* ((vec1 (car vectors)) (let* ((vec1 (car vectors))
(len (vector-length vec1))) (len (vector-length vec1)))
(%vector-copy! target to vec1 0 len) (%vector-copy! target to vec1 0 len)
(concatenate! (cdr vectors) target (concatenate! (cdr vectors) target
(+ to len))))))) (+ to len)))))))
(lambda (vectors) (lambda (vectors)
(let ((new-vector (let ((new-vector
(make-vector (compute-length vectors 0)))) (make-vector (compute-length vectors 0))))
(concatenate! vectors new-vector 0) (concatenate! vectors new-vector 0)
new-vector))))) new-vector)))))

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

@ -1,101 +1,101 @@
;;; ;;;
;;; <conversion.ss> ---- Vector conversion ;;; <conversion.ss> ---- Vector conversion
;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> ;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
;;; ;;;
;;; Copyright (C) 2005 by Zhu Chongkai. ;;; Copyright (C) 2005 by Zhu Chongkai.
;;; ;;;
;;; This file is part of SRFI-43. ;;; This file is part of SRFI-43.
;;; SRFI-43 is free software; you can redistribute it and/or ;;; SRFI-43 is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public ;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either ;;; License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version. ;;; 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, ;;; SRFI-43 is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details. ;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public ;;; You should have received a copy of the GNU Lesser General Public
;;; License along with SRFI-43; if not, write to the Free Software ;;; License along with SRFI-43; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Zhu Chongkai <mrmathematica@yahoo.com> ;;; Author: Zhu Chongkai <mrmathematica@yahoo.com>
;; ;;
;; ;;
;; Commentary: ;; Commentary:
;; Based on the reference implementation by Taylor Campbell and hence: ;; Based on the reference implementation by Taylor Campbell and hence:
;;; Copyright (C) 2003, 2004 Taylor Campbell. ;;; Copyright (C) 2003, 2004 Taylor Campbell.
;;; All rights reserved. ;;; All rights reserved.
;;; ;;;
;;; You may do as you please with this code, as long as you refrain ;;; 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_ ;;; from removing this copyright notice or holding me liable in _any_
;;; circumstances for _any_ damages that may be caused by it; and you ;;; 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. ;;; may quote sections from it as you please, as long as you credit me.
(module conversion mzscheme (module conversion mzscheme
(require "util.ss" (require "util.ss"
(lib "etc.ss")) (lib "etc.ss"))
(provide (rename my-vector->list vector->list) (provide (rename my-vector->list vector->list)
reverse-vector->list reverse-vector->list
reverse-list->vector) reverse-list->vector)
;;; (VECTOR->LIST <vector> [<start> <end>]) -> list ;;; (VECTOR->LIST <vector> [<start> <end>]) -> list
;;; [R5RS+] Produce a list containing the elements in the locations ;;; [R5RS+] Produce a list containing the elements in the locations
;;; between START, whose default is 0, and END, whose default is the ;;; between START, whose default is 0, and END, whose default is the
;;; length of VECTOR, from VECTOR. ;;; length of VECTOR, from VECTOR.
(define (my-vector->list vec . maybe-start+end) (define (my-vector->list vec . maybe-start+end)
(unless (vector? vec) (unless (vector? vec)
(apply raise-type-error (apply raise-type-error
'vector->list "vector" 0 'vector->list "vector" 0
vec maybe-start+end)) vec maybe-start+end))
(if (null? maybe-start+end) (if (null? maybe-start+end)
(vector->list vec) ;+++ (vector->list vec) ;+++
(apply (opt-lambda (vec (start 0) (end (vector-length vec))) (apply (opt-lambda (vec (start 0) (end (vector-length vec)))
(check-indices vec start end 'vector->list) (check-indices vec start end 'vector->list)
;(unfold (lambda (i) ; No SRFI 1. ;(unfold (lambda (i) ; No SRFI 1.
; (< i start)) ; (< i start))
; (lambda (i) (vector-ref vec i)) ; (lambda (i) (vector-ref vec i))
; (lambda (i) (sub1 i)) ; (lambda (i) (sub1 i))
; (sub1 end)) ; (sub1 end))
(do ((i (sub1 end) (sub1 i)) (do ((i (sub1 end) (sub1 i))
(result '() (cons (vector-ref vec i) result))) (result '() (cons (vector-ref vec i) result)))
((< i start) result))) ((< i start) result)))
vec maybe-start+end))) vec maybe-start+end)))
;;; (REVERSE-VECTOR->LIST <vector> [<start> <end>]) -> list ;;; (REVERSE-VECTOR->LIST <vector> [<start> <end>]) -> list
;;; Produce a list containing the elements in the locations between ;;; Produce a list containing the elements in the locations between
;;; START, whose default is 0, and END, whose default is the length ;;; START, whose default is 0, and END, whose default is the length
;;; of VECTOR, from VECTOR, in reverse order. ;;; of VECTOR, from VECTOR, in reverse order.
(define (reverse-vector->list vec . maybe-start+end) (define (reverse-vector->list vec . maybe-start+end)
(unless (vector? vec) (unless (vector? vec)
(apply raise-type-error (apply raise-type-error
'reverse-vector->list "vector" 0 'reverse-vector->list "vector" 0
vec maybe-start+end)) vec maybe-start+end))
(apply (opt-lambda (vec (start 0) (end (vector-length vec))) (apply (opt-lambda (vec (start 0) (end (vector-length vec)))
(check-indices vec start end 'reverse-vector->list) (check-indices vec start end 'reverse-vector->list)
;(unfold (lambda (i) (= i end)) ; No SRFI 1. ;(unfold (lambda (i) (= i end)) ; No SRFI 1.
; (lambda (i) (vector-ref vec i)) ; (lambda (i) (vector-ref vec i))
; (lambda (i) (add1 i)) ; (lambda (i) (add1 i))
; start) ; start)
(do ((i start (add1 i)) (do ((i start (add1 i))
(result '() (cons (vector-ref vec i) result))) (result '() (cons (vector-ref vec i) result)))
((= i end) result))) ((= i end) result)))
vec maybe-start+end)) vec maybe-start+end))
;;; (REVERSE-LIST->VECTOR <list> -> vector ;;; (REVERSE-LIST->VECTOR <list> -> vector
;;; Produce a vector containing the elements in LIST in reverse order. ;;; Produce a vector containing the elements in LIST in reverse order.
(define (reverse-list->vector lst) (define (reverse-list->vector lst)
(unless (list? lst) (unless (list? lst)
(raise-type-error 'reverse-list->vector "proper list" lst)) (raise-type-error 'reverse-list->vector "proper list" lst))
(let* ((len (length lst)) (let* ((len (length lst))
(vec (make-vector len))) (vec (make-vector len)))
(unfold1! (lambda (index l) (values (car l) (cdr l))) (unfold1! (lambda (index l) (values (car l) (cdr l)))
vec vec
(sub1 len) (sub1 len)
lst) lst)
vec))) vec)))

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

@ -1,278 +1,278 @@
;;; ;;;
;;; <iteration.ss> ---- Vector iteration ;;; <iteration.ss> ---- Vector iteration
;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> ;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
;;; ;;;
;;; Copyright (C) 2005 by Zhu Chongkai. ;;; Copyright (C) 2005 by Zhu Chongkai.
;;; ;;;
;;; This file is part of SRFI-43. ;;; This file is part of SRFI-43.
;;; SRFI-43 is free software; you can redistribute it and/or ;;; SRFI-43 is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public ;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either ;;; License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version. ;;; 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, ;;; SRFI-43 is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details. ;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public ;;; You should have received a copy of the GNU Lesser General Public
;;; License along with SRFI-43; if not, write to the Free Software ;;; License along with SRFI-43; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Zhu Chongkai <mrmathematica@yahoo.com> ;;; Author: Zhu Chongkai <mrmathematica@yahoo.com>
;; ;;
;; ;;
;; Commentary: ;; Commentary:
;; Based on the reference implementation by Taylor Campbell and hence: ;; Based on the reference implementation by Taylor Campbell and hence:
;;; Copyright (C) 2003, 2004 Taylor Campbell. ;;; Copyright (C) 2003, 2004 Taylor Campbell.
;;; All rights reserved. ;;; All rights reserved.
;;; ;;;
;;; You may do as you please with this code, as long as you refrain ;;; 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_ ;;; from removing this copyright notice or holding me liable in _any_
;;; circumstances for _any_ damages that may be caused by it; and you ;;; 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. ;;; may quote sections from it as you please, as long as you credit me.
(module iteration mzscheme (module iteration mzscheme
(require "util.ss") (require "util.ss")
(provide vector-fold (provide vector-fold
vector-fold-right vector-fold-right
vector-map vector-map
vector-map! vector-map!
vector-for-each vector-for-each
vector-count) vector-count)
;;; (VECTOR-FOLD <kons> <initial-knil> <vector> ...) -> knil ;;; (VECTOR-FOLD <kons> <initial-knil> <vector> ...) -> knil
;;; (KONS <knil> <elt> ...) -> knil' ; N vectors -> N+1 args ;;; (KONS <knil> <elt> ...) -> knil' ; N vectors -> N+1 args
;;; The fundamental vector iterator. KONS is iterated over each ;;; The fundamental vector iterator. KONS is iterated over each
;;; index in all of the vectors in parallel, stopping at the end of ;;; 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 ;;; the shortest; KONS is applied to an argument list of (list I
;;; STATE (vector-ref VEC I) ...), where STATE is the current state ;;; STATE (vector-ref VEC I) ...), where STATE is the current state
;;; value -- the state value begins with KNIL and becomes whatever ;;; value -- the state value begins with KNIL and becomes whatever
;;; KONS returned at the respective iteration --, and I is the ;;; KONS returned at the respective iteration --, and I is the
;;; current index in the iteration. The iteration is strictly left- ;;; current index in the iteration. The iteration is strictly left-
;;; to-right. ;;; to-right.
;;; (vector-fold KONS KNIL (vector E_1 E_2 ... E_N)) ;;; (vector-fold KONS KNIL (vector E_1 E_2 ... E_N))
;;; <=> ;;; <=>
;;; (KONS (... (KONS (KONS KNIL E_1) E_2) ... E_N-1) E_N) ;;; (KONS (... (KONS (KONS KNIL E_1) E_2) ... E_N-1) E_N)
(define (vector-fold kons knil vec . vectors) (define (vector-fold kons knil vec . vectors)
(unless (procedure? kons) (unless (procedure? kons)
(apply raise-type-error (apply raise-type-error
'vector-fold "procedure" 0 'vector-fold "procedure" 0
kons knil vec vectors)) kons knil vec vectors))
(unless (vector? vec) (unless (vector? vec)
(apply raise-type-error (apply raise-type-error
'vector-fold "vector" 2 'vector-fold "vector" 2
kons knil vec vectors)) kons knil vec vectors))
(if (null? vectors) (if (null? vectors)
(%vector-fold1 kons knil (vector-length vec) vec) (%vector-fold1 kons knil (vector-length vec) vec)
(begin (check-list-of-vecs vectors 'vector-fold 3 (begin (check-list-of-vecs vectors 'vector-fold 3
(list* kons knil vec vectors)) (list* kons knil vec vectors))
(%vector-fold2+ kons knil (%vector-fold2+ kons knil
(%smallest-length vectors (%smallest-length vectors
(vector-length vec)) (vector-length vec))
(cons vec vectors))))) (cons vec vectors)))))
(define %vector-fold1 (define %vector-fold1
(letrec ((loop (lambda (kons knil len vec i) (letrec ((loop (lambda (kons knil len vec i)
(if (= i len) (if (= i len)
knil knil
(loop kons (loop kons
(kons i knil (vector-ref vec i)) (kons i knil (vector-ref vec i))
len vec (add1 i)))))) len vec (add1 i))))))
(lambda (kons knil len vec) (lambda (kons knil len vec)
(loop kons knil len vec 0)))) (loop kons knil len vec 0))))
(define %vector-fold2+ (define %vector-fold2+
(letrec ((loop (lambda (kons knil len vectors i) (letrec ((loop (lambda (kons knil len vectors i)
(if (= i len) (if (= i len)
knil knil
(loop kons (loop kons
(apply kons i knil (apply kons i knil
(vectors-ref vectors i)) (vectors-ref vectors i))
len vectors (add1 i)))))) len vectors (add1 i))))))
(lambda (kons knil len vectors) (lambda (kons knil len vectors)
(loop kons knil len vectors 0)))) (loop kons knil len vectors 0))))
;;; (VECTOR-COUNT <predicate?> <vector> ...) ;;; (VECTOR-COUNT <predicate?> <vector> ...)
;;; -> exact, nonnegative integer ;;; -> exact, nonnegative integer
;;; (PREDICATE? <index> <value> ...) ; N vectors -> N+1 args ;;; (PREDICATE? <index> <value> ...) ; N vectors -> N+1 args
;;; PREDICATE? is applied element-wise to the elements of VECTOR ..., ;;; PREDICATE? is applied element-wise to the elements of VECTOR ...,
;;; and a count is tallied of the number of elements for which a ;;; and a count is tallied of the number of elements for which a
;;; true value is produced by PREDICATE?. This count is returned. ;;; true value is produced by PREDICATE?. This count is returned.
(define (vector-count pred? vec . vectors) (define (vector-count pred? vec . vectors)
(unless (procedure? pred?) (unless (procedure? pred?)
(apply raise-type-error (apply raise-type-error
'vector-count "procedure" 0 'vector-count "procedure" 0
pred? vec vectors)) pred? vec vectors))
(if (null? vectors) (if (null? vectors)
(%vector-fold1 (lambda (index count elt) (%vector-fold1 (lambda (index count elt)
(if (pred? index elt) (if (pred? index elt)
(add1 count) (add1 count)
count)) count))
0 0
(vector-length vec) (vector-length vec)
vec) vec)
(begin (check-list-of-vecs vectors 'vector-count 2 (begin (check-list-of-vecs vectors 'vector-count 2
(list* pred? vec vectors)) (list* pred? vec vectors))
(%vector-fold2+ (lambda (index count . elts) (%vector-fold2+ (lambda (index count . elts)
(if (apply pred? index elts) (if (apply pred? index elts)
(add1 count) (add1 count)
count)) count))
0 0
(%smallest-length vectors (%smallest-length vectors
(vector-length vec)) (vector-length vec))
(cons vec vectors))))) (cons vec vectors)))))
;;; (VECTOR-FOLD-RIGHT <kons> <initial-knil> <vector> ...) -> knil ;;; (VECTOR-FOLD-RIGHT <kons> <initial-knil> <vector> ...) -> knil
;;; (KONS <knil> <elt> ...) -> knil' ; N vectors => N+1 args ;;; (KONS <knil> <elt> ...) -> knil' ; N vectors => N+1 args
;;; The fundamental vector recursor. Iterates in parallel across ;;; The fundamental vector recursor. Iterates in parallel across
;;; VECTOR ... right to left, applying KONS to the elements and the ;;; VECTOR ... right to left, applying KONS to the elements and the
;;; current state value; the state value becomes what KONS returns ;;; current state value; the state value becomes what KONS returns
;;; at each next iteration. KNIL is the initial state value. ;;; at each next iteration. KNIL is the initial state value.
;;; (vector-fold-right KONS KNIL (vector E_1 E_2 ... E_N)) ;;; (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) ;;; (KONS (... (KONS (KONS KNIL E_N) E_N-1) ... E_2) E_1)
;;; ;;;
;;; Not implemented in terms of a more primitive operations that might ;;; 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 ;;; called %VECTOR-FOLD-RIGHT due to the fact that it wouldn't be very
;;; useful elsewhere. ;;; useful elsewhere.
(define vector-fold-right (define vector-fold-right
(letrec ((loop1 (lambda (kons knil vec i) (letrec ((loop1 (lambda (kons knil vec i)
(if (zero? i) (if (zero? i)
knil knil
(let ((j (sub1 i))) (let ((j (sub1 i)))
(loop1 kons (loop1 kons
(kons j knil (vector-ref vec j)) (kons j knil (vector-ref vec j))
vec vec
j))))) j)))))
(loop2+ (lambda (kons knil vectors i) (loop2+ (lambda (kons knil vectors i)
(if (zero? i) (if (zero? i)
knil knil
(let ((j (sub1 i))) (let ((j (sub1 i)))
(loop2+ kons (loop2+ kons
(apply kons j knil (apply kons j knil
(vectors-ref vectors j)) (vectors-ref vectors j))
vectors vectors
j)))))) j))))))
(lambda (kons knil vec . vectors) (lambda (kons knil vec . vectors)
(unless (procedure? kons) (unless (procedure? kons)
(apply raise-type-error (apply raise-type-error
'vector-fold-right "procedure" 0 'vector-fold-right "procedure" 0
kons knil vec vectors)) kons knil vec vectors))
(unless (vector? vec) (unless (vector? vec)
(apply raise-type-error (apply raise-type-error
'vector-fold-right "vector" 2 'vector-fold-right "vector" 2
kons knil vec vectors)) kons knil vec vectors))
(if (null? vectors) (if (null? vectors)
(loop1 kons knil vec (vector-length vec)) (loop1 kons knil vec (vector-length vec))
(begin (check-list-of-vecs vectors 'vector-fold-right 3 (begin (check-list-of-vecs vectors 'vector-fold-right 3
(list* kons knil vec vectors)) (list* kons knil vec vectors))
(loop2+ kons knil (cons vec vectors) (loop2+ kons knil (cons vec vectors)
(%smallest-length vectors (%smallest-length vectors
(vector-length vec)))))))) (vector-length vec))))))))
;;; (VECTOR-MAP <f> <vector> ...) -> vector ;;; (VECTOR-MAP <f> <vector> ...) -> vector
;;; (F <elt> ...) -> value ; N vectors -> N args ;;; (F <elt> ...) -> value ; N vectors -> N args
;;; Constructs a new vector of the shortest length of the vector ;;; Constructs a new vector of the shortest length of the vector
;;; arguments. Each element at index I of the new vector is mapped ;;; arguments. Each element at index I of the new vector is mapped
;;; from the old vectors by (F I (vector-ref VECTOR I) ...). The ;;; from the old vectors by (F I (vector-ref VECTOR I) ...). The
;;; dynamic order of application of F is unspecified. ;;; dynamic order of application of F is unspecified.
(define (vector-map f vec . vectors) (define (vector-map f vec . vectors)
(unless (procedure? f) (unless (procedure? f)
(apply raise-type-error (apply raise-type-error
'vector-map "procedure" 0 'vector-map "procedure" 0
f vec vectors)) f vec vectors))
(unless (vector? vec) (unless (vector? vec)
(apply raise-type-error (apply raise-type-error
'vector-map "vector" 1 'vector-map "vector" 1
f vec vectors)) f vec vectors))
(if (null? vectors) (if (null? vectors)
(let ((len (vector-length vec))) (let ((len (vector-length vec)))
(%vector-map1! f (make-vector len) vec len)) (%vector-map1! f (make-vector len) vec len))
(begin (check-list-of-vecs vectors 'vector-map 2 (begin (check-list-of-vecs vectors 'vector-map 2
(list* f vec vectors)) (list* f vec vectors))
(let ((len (%smallest-length vectors (let ((len (%smallest-length vectors
(vector-length vec)))) (vector-length vec))))
(%vector-map2+! f (make-vector len) (%vector-map2+! f (make-vector len)
(cons vec vectors) len))))) (cons vec vectors) len)))))
;;; (%VECTOR-MAP1! <f> <target> <length> <vector>) ;;; (%VECTOR-MAP1! <f> <target> <length> <vector>)
;;; (F <index> <elt>) -> elt' ;;; (F <index> <elt>) -> elt'
(define (%vector-map1! f target vec i) (define (%vector-map1! f target vec i)
(if (zero? i) (if (zero? i)
target target
(let ((j (sub1 i))) (let ((j (sub1 i)))
(vector-set! target j (vector-set! target j
(f j (vector-ref vec j))) (f j (vector-ref vec j)))
(%vector-map1! f target vec j)))) (%vector-map1! f target vec j))))
(define (%vector-map2+! f target vectors i) (define (%vector-map2+! f target vectors i)
(if (zero? i) (if (zero? i)
target target
(let ((j (sub1 i))) (let ((j (sub1 i)))
(vector-set! target j (vector-set! target j
(apply f j (vectors-ref vectors j))) (apply f j (vectors-ref vectors j)))
(%vector-map2+! f target vectors j)))) (%vector-map2+! f target vectors j))))
;;; (VECTOR-MAP! <f> <vector> ...) -> vector ;;; (VECTOR-MAP! <f> <vector> ...) -> vector
;;; (F <elt> ...) -> element' ; N vectors -> N args ;;; (F <elt> ...) -> element' ; N vectors -> N args
;;; Similar to VECTOR-MAP, but rather than mapping the new elements ;;; Similar to VECTOR-MAP, but rather than mapping the new elements
;;; into a new vector, the new mapped elements are destructively ;;; into a new vector, the new mapped elements are destructively
;;; inserted into the first vector. Again, the dynamic order of ;;; inserted into the first vector. Again, the dynamic order of
;;; application of F is unspecified, so it is dangerous for F to ;;; application of F is unspecified, so it is dangerous for F to
;;; manipulate the first VECTOR. ;;; manipulate the first VECTOR.
(define (vector-map! f vec . vectors) (define (vector-map! f vec . vectors)
(unless (procedure? f) (unless (procedure? f)
(apply raise-type-error (apply raise-type-error
'vector-map! "procedure" 0 'vector-map! "procedure" 0
f vec vectors)) f vec vectors))
(unless (vector? vec) (unless (vector? vec)
(apply raise-type-error (apply raise-type-error
'vector-map! "vector" 1 'vector-map! "vector" 1
f vec vectors)) f vec vectors))
(if (null? vectors) (if (null? vectors)
(%vector-map1! f vec vec (vector-length vec)) (%vector-map1! f vec vec (vector-length vec))
(begin (check-list-of-vecs vectors 'vector-map! 2 (begin (check-list-of-vecs vectors 'vector-map! 2
(list* f vec vectors)) (list* f vec vectors))
(%vector-map2+! f vec (cons vec vectors) (%vector-map2+! f vec (cons vec vectors)
(%smallest-length vectors (%smallest-length vectors
(vector-length vec)))))) (vector-length vec))))))
;;; (VECTOR-FOR-EACH <f> <vector> ...) -> void ;;; (VECTOR-FOR-EACH <f> <vector> ...) -> void
;;; (F <elt> ...) ; N vectors -> N args ;;; (F <elt> ...) ; N vectors -> N args
;;; Simple vector iterator: applies F to each index in the range [0, ;;; Simple vector iterator: applies F to each index in the range [0,
;;; LENGTH), where LENGTH is the length of the smallest vector ;;; LENGTH), where LENGTH is the length of the smallest vector
;;; argument passed, and the respective element at that index. In ;;; argument passed, and the respective element at that index. In
;;; contrast with VECTOR-MAP, F is reliably applied to each ;;; contrast with VECTOR-MAP, F is reliably applied to each
;;; subsequent elements, starting at index 0 from left to right, in ;;; subsequent elements, starting at index 0 from left to right, in
;;; the vectors. ;;; the vectors.
(define vector-for-each (define vector-for-each
(letrec ((for-each1 (letrec ((for-each1
(lambda (f vec i len) (lambda (f vec i len)
(when (< i len) (when (< i len)
(f i (vector-ref vec i)) (f i (vector-ref vec i))
(for-each1 f vec (add1 i) len)))) (for-each1 f vec (add1 i) len))))
(for-each2+ (for-each2+
(lambda (f vecs i len) (lambda (f vecs i len)
(when (< i len) (when (< i len)
(apply f i (vectors-ref vecs i)) (apply f i (vectors-ref vecs i))
(for-each2+ f vecs (add1 i) len))))) (for-each2+ f vecs (add1 i) len)))))
(lambda (f vec . vectors) (lambda (f vec . vectors)
(unless (procedure? f) (unless (procedure? f)
(apply raise-type-error (apply raise-type-error
'vector-for-each "procedure" 0 'vector-for-each "procedure" 0
f vec vectors)) f vec vectors))
(unless (vector? vec) (unless (vector? vec)
(apply raise-type-error (apply raise-type-error
'vector-for-each "vector" 1 'vector-for-each "vector" 1
f vec vectors)) f vec vectors))
(if (null? vectors) (if (null? vectors)
(for-each1 f vec 0 (vector-length vec)) (for-each1 f vec 0 (vector-length vec))
(begin (check-list-of-vecs vectors 'vector-for-each 2 (begin (check-list-of-vecs vectors 'vector-for-each 2
(list* f vec vectors)) (list* f vec vectors))
(for-each2+ f (cons vec vectors) 0 (for-each2+ f (cons vec vectors) 0
(%smallest-length vectors (%smallest-length vectors
(vector-length vec))))))))) (vector-length vec)))))))))

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

@ -1,171 +1,171 @@
;;; ;;;
;;; <mutators.ss> ---- Vector mutators ;;; <mutators.ss> ---- Vector mutators
;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> ;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
;;; ;;;
;;; Copyright (C) 2005 by Zhu Chongkai. ;;; Copyright (C) 2005 by Zhu Chongkai.
;;; ;;;
;;; This file is part of SRFI-43. ;;; This file is part of SRFI-43.
;;; SRFI-43 is free software; you can redistribute it and/or ;;; SRFI-43 is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public ;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either ;;; License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version. ;;; 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, ;;; SRFI-43 is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details. ;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public ;;; You should have received a copy of the GNU Lesser General Public
;;; License along with SRFI-43; if not, write to the Free Software ;;; License along with SRFI-43; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Zhu Chongkai <mrmathematica@yahoo.com> ;;; Author: Zhu Chongkai <mrmathematica@yahoo.com>
;; ;;
;; ;;
;; Commentary: ;; Commentary:
;; Based on the reference implementation by Taylor Campbell and hence: ;; Based on the reference implementation by Taylor Campbell and hence:
;;; Copyright (C) 2003, 2004 Taylor Campbell. ;;; Copyright (C) 2003, 2004 Taylor Campbell.
;;; All rights reserved. ;;; All rights reserved.
;;; ;;;
;;; You may do as you please with this code, as long as you refrain ;;; 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_ ;;; from removing this copyright notice or holding me liable in _any_
;;; circumstances for _any_ damages that may be caused by it; and you ;;; 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. ;;; may quote sections from it as you please, as long as you credit me.
(module mutators mzscheme (module mutators mzscheme
(require "util.ss" (require "util.ss"
(lib "etc.ss")) (lib "etc.ss"))
(provide vector-swap! (provide vector-swap!
(rename my-vector-fill! vector-fill!) (rename my-vector-fill! vector-fill!)
vector-reverse! vector-reverse!
vector-copy! vector-copy!
vector-reverse-copy!) vector-reverse-copy!)
;;; (VECTOR-SWAP! <vector> <index1> <index2>) -> void ;;; (VECTOR-SWAP! <vector> <index1> <index2>) -> void
;;; Swap the values in the locations at INDEX1 and INDEX2. ;;; Swap the values in the locations at INDEX1 and INDEX2.
(define (vector-swap! vec i j) (define (vector-swap! vec i j)
(unless (vector? vec) (unless (vector? vec)
(raise-type-error 'vector-swap! "vector" 0 (raise-type-error 'vector-swap! "vector" 0
vec i j)) vec i j))
(check-index vec i 'vector-swap!) (check-index vec i 'vector-swap!)
(check-index vec j 'vector-swap!) (check-index vec j 'vector-swap!)
(%vector-swap! vec i j)) (%vector-swap! vec i j))
(define (%vector-swap! vec i j) (define (%vector-swap! vec i j)
(let ((x (vector-ref vec i))) (let ((x (vector-ref vec i)))
(vector-set! vec i (vector-ref vec j)) (vector-set! vec i (vector-ref vec j))
(vector-set! vec j x))) (vector-set! vec j x)))
;;; (VECTOR-FILL! <vector> <value> [<start> <end>]) -> <vector> ;;; (VECTOR-FILL! <vector> <value> [<start> <end>]) -> <vector>
;;; [R5RS+] Fill the locations in VECTOR between START, whose default ;;; [R5RS+] Fill the locations in VECTOR between START, whose default
;;; is 0, and END, whose default is the length of VECTOR, with VALUE. ;;; is 0, and END, whose default is the length of VECTOR, with VALUE.
;;; ;;;
;;; This one can probably be made really fast natively. ;;; This one can probably be made really fast natively.
(define (my-vector-fill! vec value . maybe-start+end) (define (my-vector-fill! vec value . maybe-start+end)
(cond ((null? maybe-start+end) (cond ((null? maybe-start+end)
(vector-fill! vec value)) ;+++ (vector-fill! vec value)) ;+++
((not (vector? vec)) ((not (vector? vec))
(apply raise-type-error (apply raise-type-error
'vector-fill! "vector" 0 'vector-fill! "vector" 0
vec value maybe-start+end)) vec value maybe-start+end))
(else (else
(apply (opt-lambda (vec value (start 0) (end (vector-length vec))) (apply (opt-lambda (vec value (start 0) (end (vector-length vec)))
(check-indices vec start end 'vector-fill!) (check-indices vec start end 'vector-fill!)
(do ((i start (add1 i))) (do ((i start (add1 i)))
((= i end)) ((= i end))
(vector-set! vec i value)) (vector-set! vec i value))
vec) vec)
vec value maybe-start+end)))) vec value maybe-start+end))))
(define %vector-reverse! (define %vector-reverse!
(letrec ((loop (lambda (vec i j) (letrec ((loop (lambda (vec i j)
(when (< i j) (when (< i j)
(%vector-swap! vec i j) (%vector-swap! vec i j)
(loop vec (add1 i) (sub1 j)))))) (loop vec (add1 i) (sub1 j))))))
(lambda (vec start end) (lambda (vec start end)
(loop vec start (sub1 end))))) (loop vec start (sub1 end)))))
;;; (VECTOR-REVERSE! <vector> [<start> <end>]) -> void ;;; (VECTOR-REVERSE! <vector> [<start> <end>]) -> void
;;; Destructively reverse the contents of the sequence of locations ;;; Destructively reverse the contents of the sequence of locations
;;; in VECTOR between START, whose default is 0, and END, whose ;;; in VECTOR between START, whose default is 0, and END, whose
;;; default is the length of VECTOR. ;;; default is the length of VECTOR.
(define (vector-reverse! vec . maybe-start+end) (define (vector-reverse! vec . maybe-start+end)
(unless (vector? vec) (unless (vector? vec)
(apply raise-type-error (apply raise-type-error
'vector-reverse! "vector" 0 'vector-reverse! "vector" 0
vec maybe-start+end)) vec maybe-start+end))
(apply (opt-lambda (vec (start 0) (end (vector-length vec))) (apply (opt-lambda (vec (start 0) (end (vector-length vec)))
(check-indices vec start end 'vector-reverse!) (check-indices vec start end 'vector-reverse!)
(%vector-reverse! vec start end)) (%vector-reverse! vec start end))
vec maybe-start+end)) vec maybe-start+end))
;;; (VECTOR-COPY! <target> <tstart> <source> [<sstart> <send>]) ;;; (VECTOR-COPY! <target> <tstart> <source> [<sstart> <send>])
;;; -> unspecified ;;; -> unspecified
;;; Copy the values in the locations in [SSTART,SEND) from SOURCE to ;;; Copy the values in the locations in [SSTART,SEND) from SOURCE to
;;; to TARGET, starting at TSTART in TARGET. ;;; to TARGET, starting at TSTART in TARGET.
(define (vector-copy! target tstart source . maybe-sstart+send) (define (vector-copy! target tstart source . maybe-sstart+send)
(unless (vector? target) (unless (vector? target)
(apply raise-type-error (apply raise-type-error
'vector-copy! "vector" 0 'vector-copy! "vector" 0
target tstart source maybe-sstart+send)) target tstart source maybe-sstart+send))
(check-start target tstart 'vector-copy!) (check-start target tstart 'vector-copy!)
(unless (vector? source) (unless (vector? source)
(apply raise-type-error (apply raise-type-error
'vector-copy! "vector" 2 'vector-copy! "vector" 2
target tstart source maybe-sstart+send)) target tstart source maybe-sstart+send))
(apply (opt-lambda (target (apply (opt-lambda (target
tstart tstart
source source
(sstart 0) (sstart 0)
(send (vector-length source))) (send (vector-length source)))
(check-indices source sstart send 'vector-copy!) (check-indices source sstart send 'vector-copy!)
(if (< (- (vector-length target) tstart) (if (< (- (vector-length target) tstart)
(- send sstart)) (- send sstart))
(error 'vector-copy! (error 'vector-copy!
"target vector not long enough to copy")) "target vector not long enough to copy"))
(%vector-copy! target tstart source sstart send)) (%vector-copy! target tstart source sstart send))
target tstart source maybe-sstart+send)) target tstart source maybe-sstart+send))
;;; (VECTOR-REVERSE-COPY! <target> <tstart> <source> [<sstart> <send>]) ;;; (VECTOR-REVERSE-COPY! <target> <tstart> <source> [<sstart> <send>])
(define (vector-reverse-copy! target tstart source . maybe-sstart+send) (define (vector-reverse-copy! target tstart source . maybe-sstart+send)
(unless (vector? target) (unless (vector? target)
(apply raise-type-error (apply raise-type-error
'vector-reverse-copy! "vector" 0 'vector-reverse-copy! "vector" 0
target tstart source maybe-sstart+send)) target tstart source maybe-sstart+send))
(check-start target tstart 'vector-reverse-copy!) (check-start target tstart 'vector-reverse-copy!)
(unless (vector? source) (unless (vector? source)
(apply raise-type-error (apply raise-type-error
'vector-reverse-copy! "vector" 2 'vector-reverse-copy! "vector" 2
target tstart source maybe-sstart+send)) target tstart source maybe-sstart+send))
(apply (opt-lambda (target (apply (opt-lambda (target
tstart tstart
source source
(sstart 0) (sstart 0)
(send (vector-length source))) (send (vector-length source)))
(check-indices source sstart send 'vector-reverse-copy!) (check-indices source sstart send 'vector-reverse-copy!)
(cond ((< (- (vector-length target) tstart) (cond ((< (- (vector-length target) tstart)
(- send sstart)) (- send sstart))
(error 'vector-reverse-copy! (error 'vector-reverse-copy!
"target vector not long enough to copy")) "target vector not long enough to copy"))
((and (eq? target source) ((and (eq? target source)
(= sstart tstart)) (= sstart tstart))
(%vector-reverse! target tstart send)) (%vector-reverse! target tstart send))
((and (eq? target source) ((and (eq? target source)
(or (between? sstart tstart send) (or (between? sstart tstart send)
(between? tstart sstart (between? tstart sstart
(+ tstart (- send sstart))))) (+ tstart (- send sstart)))))
;an error in the reference implement here ;an error in the reference implement here
(error 'vector-reverse-copy! (error 'vector-reverse-copy!
"Vector range for self-copying overlaps")) "Vector range for self-copying overlaps"))
(else (else
(%vector-reverse-copy! target tstart (%vector-reverse-copy! target tstart
source sstart send)))) source sstart send))))
target tstart source maybe-sstart+send)) target tstart source maybe-sstart+send))
(define (between? x y z) (define (between? x y z)
(and (< x y) (and (< x y)
(<= y z)))) (<= y z))))

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

@ -1,103 +1,103 @@
;;; ;;;
;;; <predicates.ss> ---- Vector predicates ;;; <predicates.ss> ---- Vector predicates
;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> ;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
;;; ;;;
;;; Copyright (C) 2005 by Zhu Chongkai. ;;; Copyright (C) 2005 by Zhu Chongkai.
;;; ;;;
;;; This file is part of SRFI-43. ;;; This file is part of SRFI-43.
;;; SRFI-43 is free software; you can redistribute it and/or ;;; SRFI-43 is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public ;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either ;;; License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version. ;;; 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, ;;; SRFI-43 is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details. ;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public ;;; You should have received a copy of the GNU Lesser General Public
;;; License along with SRFI-43; if not, write to the Free Software ;;; License along with SRFI-43; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Zhu Chongkai <mrmathematica@yahoo.com> ;;; Author: Zhu Chongkai <mrmathematica@yahoo.com>
;; ;;
;; ;;
;; Commentary: ;; Commentary:
;; Based on the reference implementation by Taylor Campbell and hence: ;; Based on the reference implementation by Taylor Campbell and hence:
;;; Copyright (C) 2003, 2004 Taylor Campbell. ;;; Copyright (C) 2003, 2004 Taylor Campbell.
;;; All rights reserved. ;;; All rights reserved.
;;; ;;;
;;; You may do as you please with this code, as long as you refrain ;;; 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_ ;;; from removing this copyright notice or holding me liable in _any_
;;; circumstances for _any_ damages that may be caused by it; and you ;;; 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. ;;; may quote sections from it as you please, as long as you credit me.
(module predicates mzscheme (module predicates mzscheme
(require "util.ss") (require "util.ss")
(provide vector-empty? (provide vector-empty?
vector=) vector=)
;;; (VECTOR-EMPTY? <vector>) -> boolean ;;; (VECTOR-EMPTY? <vector>) -> boolean
;;; Return #T if VECTOR has zero elements in it, i.e. VECTOR's length ;;; Return #T if VECTOR has zero elements in it, i.e. VECTOR's length
;;; is 0, and #F if not. ;;; is 0, and #F if not.
(define (vector-empty? vec) (define (vector-empty? vec)
(unless (vector? vec) (unless (vector? vec)
(raise-type-error 'vector-empty? "vector" vec)) (raise-type-error 'vector-empty? "vector" vec))
(zero? (vector-length vec))) (zero? (vector-length vec)))
;;; (VECTOR= <elt=?> <vector> ...) -> boolean ;;; (VECTOR= <elt=?> <vector> ...) -> boolean
;;; (ELT=? <value> <value>) -> boolean ;;; (ELT=? <value> <value>) -> boolean
;;; Determine vector equality generalized across element comparators. ;;; Determine vector equality generalized across element comparators.
;;; Vectors A and B are equal iff their lengths are the same and for ;;; 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 ;;; 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 ;;; 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) ;;; 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 ;;; 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 ;;; true value. This may be exploited to avoid multiple unnecessary
;;; element comparisons. (This implementation does, but does not deal ;;; element comparisons. (This implementation does, but does not deal
;;; with the situation that ELEMENT=? is EQ? to avoid more unnecessary ;;; with the situation that ELEMENT=? is EQ? to avoid more unnecessary
;;; comparisons, but I believe this optimization is probably fairly ;;; comparisons, but I believe this optimization is probably fairly
;;; insignificant.) ;;; insignificant.)
;;; ;;;
;;; If the number of vector arguments is zero or one, then #T is ;;; If the number of vector arguments is zero or one, then #T is
;;; automatically returned. If there are N vector arguments, ;;; automatically returned. If there are N vector arguments,
;;; VECTOR_1 VECTOR_2 ... VECTOR_N, then VECTOR_1 & VECTOR_2 are ;;; VECTOR_1 VECTOR_2 ... VECTOR_N, then VECTOR_1 & VECTOR_2 are
;;; compared; if they are equal, the vectors VECTOR_2 ... VECTOR_N ;;; compared; if they are equal, the vectors VECTOR_2 ... VECTOR_N
;;; are compared. The precise order in which ELT=? is applied is not ;;; are compared. The precise order in which ELT=? is applied is not
;;; specified. ;;; specified.
(define (vector= elt=? . vectors) (define (vector= elt=? . vectors)
(unless (procedure-arity-includes? elt=? 2) (unless (procedure-arity-includes? elt=? 2)
(apply raise-type-error (apply raise-type-error
'vector= "procedure of arity 2" 0 'vector= "procedure of arity 2" 0
elt=? vectors)) elt=? vectors))
(cond ((null? vectors) (cond ((null? vectors)
#t) #t)
((null? (cdr vectors)) ((null? (cdr vectors))
(unless (vector? (car vectors)) (unless (vector? (car vectors))
(apply raise-type-error (apply raise-type-error
'vector= "vector" 1 'vector= "vector" 1
elt=? vectors)) elt=? vectors))
#t) #t)
(else (else
(check-list-of-vecs vectors 'vector= (check-list-of-vecs vectors 'vector=
1 (cons elt=? vectors)) 1 (cons elt=? vectors))
(let loop ((vecs vectors)) (let loop ((vecs vectors))
(let ((vec1 (car vecs)) (let ((vec1 (car vecs))
(vec2+ (cdr vecs))) (vec2+ (cdr vecs)))
(or (null? vec2+) (or (null? vec2+)
(and (binary-vector= elt=? vec1 (car vec2+)) (and (binary-vector= elt=? vec1 (car vec2+))
(loop vec2+)))))))) (loop vec2+))))))))
(define (binary-vector= elt=? vector-a vector-b) (define (binary-vector= elt=? vector-a vector-b)
(or (eq? vector-a vector-b) ;+++ (or (eq? vector-a vector-b) ;+++
(let ((length-a (vector-length vector-a))) (let ((length-a (vector-length vector-a)))
(and (= length-a (vector-length vector-b)) (and (= length-a (vector-length vector-b))
(let loop ((i 0)) (let loop ((i 0))
(or (= i length-a) (or (= i length-a)
(and (elt=? (vector-ref vector-a i) (and (elt=? (vector-ref vector-a i)
(vector-ref vector-b i)) (vector-ref vector-b i))
(loop (add1 i)))))))))) (loop (add1 i))))))))))

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

@ -1,298 +1,298 @@
;;; ;;;
;;; <searching.ss> ---- Vector searching ;;; <searching.ss> ---- Vector searching
;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> ;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
;;; ;;;
;;; Copyright (C) 2005 by Zhu Chongkai. ;;; Copyright (C) 2005 by Zhu Chongkai.
;;; ;;;
;;; This file is part of SRFI-43. ;;; This file is part of SRFI-43.
;;; SRFI-43 is free software; you can redistribute it and/or ;;; SRFI-43 is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public ;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either ;;; License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version. ;;; 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, ;;; SRFI-43 is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details. ;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public ;;; You should have received a copy of the GNU Lesser General Public
;;; License along with SRFI-43; if not, write to the Free Software ;;; License along with SRFI-43; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Zhu Chongkai <mrmathematica@yahoo.com> ;;; Author: Zhu Chongkai <mrmathematica@yahoo.com>
;; ;;
;; ;;
;; Commentary: ;; Commentary:
;; Based on the reference implementation by Taylor Campbell and hence: ;; Based on the reference implementation by Taylor Campbell and hence:
;;; Copyright (C) 2003, 2004 Taylor Campbell. ;;; Copyright (C) 2003, 2004 Taylor Campbell.
;;; All rights reserved. ;;; All rights reserved.
;;; ;;;
;;; You may do as you please with this code, as long as you refrain ;;; 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_ ;;; from removing this copyright notice or holding me liable in _any_
;;; circumstances for _any_ damages that may be caused by it; and you ;;; 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. ;;; may quote sections from it as you please, as long as you credit me.
(module searching mzscheme (module searching mzscheme
(require "util.ss") (require "util.ss")
(provide vector-index (provide vector-index
vector-index-right vector-index-right
vector-skip vector-skip
vector-skip-right vector-skip-right
vector-binary-search vector-binary-search
vector-any vector-any
vector-every) vector-every)
;; All the functions (except vector-binary-search) here can be ;; All the functions (except vector-binary-search) here can be
;; abstracted, but for performance I didn't do so. ;; abstracted, but for performance I didn't do so.
;;; (VECTOR-INDEX <predicate?> <vector> ...) ;;; (VECTOR-INDEX <predicate?> <vector> ...)
;;; -> exact, nonnegative integer or #F ;;; -> exact, nonnegative integer or #F
;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args ;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
;;; Search left-to-right across VECTOR ... in parallel, returning the ;;; Search left-to-right across VECTOR ... in parallel, returning the
;;; index of the first set of values VALUE ... such that (PREDICATE? ;;; index of the first set of values VALUE ... such that (PREDICATE?
;;; VALUE ...) returns a true value; if no such set of elements is ;;; VALUE ...) returns a true value; if no such set of elements is
;;; reached, return #F. ;;; reached, return #F.
(define vector-index (define vector-index
(letrec ((loop1 (lambda (pred? vec len i) (letrec ((loop1 (lambda (pred? vec len i)
(cond ((= i len) #f) (cond ((= i len) #f)
((pred? (vector-ref vec i)) i) ((pred? (vector-ref vec i)) i)
(else (loop1 pred? vec len (add1 i)))))) (else (loop1 pred? vec len (add1 i))))))
(loop2+ (lambda (pred? vectors len i) (loop2+ (lambda (pred? vectors len i)
(cond ((= i len) #f) (cond ((= i len) #f)
((apply pred? (vectors-ref vectors i)) i) ((apply pred? (vectors-ref vectors i)) i)
(else (loop2+ pred? vectors len (add1 i))))))) (else (loop2+ pred? vectors len (add1 i)))))))
(lambda (pred? vec . vectors) (lambda (pred? vec . vectors)
(unless (procedure? pred?) (unless (procedure? pred?)
(apply raise-type-error (apply raise-type-error
'vector-index "procedure" 0 'vector-index "procedure" 0
pred? vec vectors)) pred? vec vectors))
(unless (vector? vec) (unless (vector? vec)
(apply raise-type-error (apply raise-type-error
'vector-index "vector" 1 'vector-index "vector" 1
pred? vec vectors)) pred? vec vectors))
(if (null? vectors) (if (null? vectors)
(loop1 pred? vec (vector-length vec) 0) (loop1 pred? vec (vector-length vec) 0)
(begin (check-list-of-vecs vectors 'vector-index 2 (begin (check-list-of-vecs vectors 'vector-index 2
(list* pred? vec vectors)) (list* pred? vec vectors))
(loop2+ pred? (cons vec vectors) (loop2+ pred? (cons vec vectors)
(%smallest-length vectors (%smallest-length vectors
(vector-length vec)) (vector-length vec))
0)))))) 0))))))
;;; (VECTOR-SKIP <predicate?> <vector> ...) ;;; (VECTOR-SKIP <predicate?> <vector> ...)
;;; -> exact, nonnegative integer or #F ;;; -> exact, nonnegative integer or #F
;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args ;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
;;; (vector-index (lambda elts (not (apply PREDICATE? elts))) ;;; (vector-index (lambda elts (not (apply PREDICATE? elts)))
;;; VECTOR ...) ;;; VECTOR ...)
;;; Like VECTOR-INDEX, but find the index of the first set of values ;;; Like VECTOR-INDEX, but find the index of the first set of values
;;; that do _not_ satisfy PREDICATE?. ;;; that do _not_ satisfy PREDICATE?.
(define vector-skip (define vector-skip
(letrec ((loop1 (lambda (pred? vec len i) (letrec ((loop1 (lambda (pred? vec len i)
(cond ((= i len) #f) (cond ((= i len) #f)
((pred? (vector-ref vec i)) ((pred? (vector-ref vec i))
(loop1 pred? vec len (add1 i))) (loop1 pred? vec len (add1 i)))
(else i)))) (else i))))
(loop2+ (lambda (pred? vectors len i) (loop2+ (lambda (pred? vectors len i)
(cond ((= i len) #f) (cond ((= i len) #f)
((apply pred? (vectors-ref vectors i)) ((apply pred? (vectors-ref vectors i))
(loop2+ pred? vectors len (add1 i))) (loop2+ pred? vectors len (add1 i)))
(else i))))) (else i)))))
(lambda (pred? vec . vectors) (lambda (pred? vec . vectors)
(unless (procedure? pred?) (unless (procedure? pred?)
(apply raise-type-error (apply raise-type-error
'vector-skip "procedure" 0 'vector-skip "procedure" 0
pred? vec vectors)) pred? vec vectors))
(unless (vector? vec) (unless (vector? vec)
(apply raise-type-error (apply raise-type-error
'vector-skip "vector" 1 'vector-skip "vector" 1
pred? vec vectors)) pred? vec vectors))
(if (null? vectors) (if (null? vectors)
(loop1 pred? vec (vector-length vec) 0) (loop1 pred? vec (vector-length vec) 0)
(begin (check-list-of-vecs vectors 'vector-skip 2 (begin (check-list-of-vecs vectors 'vector-skip 2
(list* pred? vec vectors)) (list* pred? vec vectors))
(loop2+ pred? (cons vec vectors) (loop2+ pred? (cons vec vectors)
(%smallest-length vectors (%smallest-length vectors
(vector-length vec)) (vector-length vec))
0)))))) 0))))))
;;; (VECTOR-INDEX-RIGHT <predicate?> <vector> ...) ;;; (VECTOR-INDEX-RIGHT <predicate?> <vector> ...)
;;; -> exact, nonnegative integer or #F ;;; -> exact, nonnegative integer or #F
;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args ;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
;;; Right-to-left variant of VECTOR-INDEX. ;;; Right-to-left variant of VECTOR-INDEX.
(define vector-index-right (define vector-index-right
(letrec ((loop1 (lambda (pred? vec i) (letrec ((loop1 (lambda (pred? vec i)
(if (zero? i) (if (zero? i)
#f #f
(let ((i (sub1 i))) (let ((i (sub1 i)))
(if (pred? (vector-ref vec i)) (if (pred? (vector-ref vec i))
i i
(loop1 pred? vec i)))))) (loop1 pred? vec i))))))
(loop2+ (lambda (pred? vectors i) (loop2+ (lambda (pred? vectors i)
(if (zero? i) (if (zero? i)
#f #f
(let ((i (sub1 i))) (let ((i (sub1 i)))
(if (apply pred? (vectors-ref vectors i)) (if (apply pred? (vectors-ref vectors i))
i i
(loop2+ pred? vectors i))))))) (loop2+ pred? vectors i)))))))
(lambda (pred? vec . vectors) (lambda (pred? vec . vectors)
(unless (procedure? pred?) (unless (procedure? pred?)
(apply raise-type-error (apply raise-type-error
'vector-index-right "procedure" 0 'vector-index-right "procedure" 0
pred? vec vectors)) pred? vec vectors))
(unless (vector? vec) (unless (vector? vec)
(apply raise-type-error (apply raise-type-error
'vector-index-right "vector" 1 'vector-index-right "vector" 1
pred? vec vectors)) pred? vec vectors))
(if (null? vectors) (if (null? vectors)
(loop1 pred? vec (vector-length vec)) (loop1 pred? vec (vector-length vec))
(begin (check-list-of-vecs vectors 'vector-index-right 2 (begin (check-list-of-vecs vectors 'vector-index-right 2
(list* pred? vec vectors)) (list* pred? vec vectors))
(loop2+ pred? (cons vec vectors) (loop2+ pred? (cons vec vectors)
(%smallest-length vectors (%smallest-length vectors
(vector-length vec)))))))) (vector-length vec))))))))
;;; (VECTOR-SKIP-RIGHT <predicate?> <vector> ...) ;;; (VECTOR-SKIP-RIGHT <predicate?> <vector> ...)
;;; -> exact, nonnegative integer or #F ;;; -> exact, nonnegative integer or #F
;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args ;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
;;; Right-to-left variant of VECTOR-SKIP. ;;; Right-to-left variant of VECTOR-SKIP.
(define vector-skip-right (define vector-skip-right
(letrec ((loop1 (lambda (pred? vec i) (letrec ((loop1 (lambda (pred? vec i)
(if (zero? i) (if (zero? i)
#f #f
(let ((i (sub1 i))) (let ((i (sub1 i)))
(if (pred? (vector-ref vec i)) (if (pred? (vector-ref vec i))
(loop1 pred? vec i) (loop1 pred? vec i)
i))))) i)))))
(loop2+ (lambda (pred? vectors i) (loop2+ (lambda (pred? vectors i)
(if (zero? i) (if (zero? i)
#f #f
(let ((i (sub1 i))) (let ((i (sub1 i)))
(if (apply pred? (vectors-ref vectors i)) (if (apply pred? (vectors-ref vectors i))
(loop2+ pred? vectors i) (loop2+ pred? vectors i)
i)))))) i))))))
(lambda (pred? vec . vectors) (lambda (pred? vec . vectors)
(unless (procedure? pred?) (unless (procedure? pred?)
(apply raise-type-error (apply raise-type-error
'vector-skip-right "procedure" 0 'vector-skip-right "procedure" 0
pred? vec vectors)) pred? vec vectors))
(unless (vector? vec) (unless (vector? vec)
(apply raise-type-error (apply raise-type-error
'vector-skip-right "vector" 1 'vector-skip-right "vector" 1
pred? vec vectors)) pred? vec vectors))
(if (null? vectors) (if (null? vectors)
(loop1 pred? vec (vector-length vec)) (loop1 pred? vec (vector-length vec))
(begin (check-list-of-vecs vectors 'vector-skip-right 2 (begin (check-list-of-vecs vectors 'vector-skip-right 2
(list* pred? vec vectors)) (list* pred? vec vectors))
(loop2+ pred? (cons vec vectors) (loop2+ pred? (cons vec vectors)
(%smallest-length vectors (%smallest-length vectors
(vector-length vec)))))))) (vector-length vec))))))))
;;; (VECTOR-BINARY-SEARCH <vector> <value> <cmp>) ;;; (VECTOR-BINARY-SEARCH <vector> <value> <cmp>)
;;; -> exact, nonnegative integer or #F ;;; -> exact, nonnegative integer or #F
;;; (CMP <value1> <value2>) -> integer ;;; (CMP <value1> <value2>) -> integer
;;; positive -> VALUE1 > VALUE2 ;;; positive -> VALUE1 > VALUE2
;;; zero -> VALUE1 = VALUE2 ;;; zero -> VALUE1 = VALUE2
;;; negative -> VALUE1 < VALUE2 ;;; negative -> VALUE1 < VALUE2
;;; Perform a binary search through VECTOR for VALUE, comparing each ;;; Perform a binary search through VECTOR for VALUE, comparing each
;;; element to VALUE with CMP. ;;; element to VALUE with CMP.
(define (vector-binary-search vec value cmp) (define (vector-binary-search vec value cmp)
(unless (vector? vec) (unless (vector? vec)
(raise-type-error 'vector-binary-search "vector" 0 (raise-type-error 'vector-binary-search "vector" 0
vec value cmp)) vec value cmp))
(unless (procedure-arity-includes? cmp 2) (unless (procedure-arity-includes? cmp 2)
(raise-type-error 'vector-binary-search "procedure of arity 2" 2 (raise-type-error 'vector-binary-search "procedure of arity 2" 2
vec value cmp)) vec value cmp))
(let loop ((start 0) (let loop ((start 0)
(end (vector-length vec)) (end (vector-length vec))
(j -1)) (j -1))
(let ((i (quotient (+ start end) 2))) (let ((i (quotient (+ start end) 2)))
(if (= i j) (if (= i j)
#f #f
(let ((comparison (cmp (vector-ref vec i) value))) (let ((comparison (cmp (vector-ref vec i) value)))
(unless (integer? comparison) (unless (integer? comparison)
(raise-type-error 'vector-binary-search (raise-type-error 'vector-binary-search
"procedure that returns an integer" "procedure that returns an integer"
2 2
vec value cmp)) vec value cmp))
(cond ((zero? comparison) i) (cond ((zero? comparison) i)
((positive? comparison) (loop start i i)) ((positive? comparison) (loop start i i))
(else (loop i end i)))))))) (else (loop i end i))))))))
;;; (VECTOR-ANY <pred?> <vector> ...) -> value ;;; (VECTOR-ANY <pred?> <vector> ...) -> value
;;; Apply PRED? to each parallel element in each VECTOR ...; if PRED? ;;; Apply PRED? to each parallel element in each VECTOR ...; if PRED?
;;; should ever return a true value, immediately stop and return that ;;; should ever return a true value, immediately stop and return that
;;; value; otherwise, when the shortest vector runs out, return #F. ;;; value; otherwise, when the shortest vector runs out, return #F.
;;; The iteration and order of application of PRED? across elements ;;; The iteration and order of application of PRED? across elements
;;; is of the vectors is strictly left-to-right. ;;; is of the vectors is strictly left-to-right.
(define vector-any (define vector-any
(letrec ((loop1 (lambda (pred? vec i len) (letrec ((loop1 (lambda (pred? vec i len)
(and (not (= i len)) (and (not (= i len))
(or (pred? (vector-ref vec i)) (or (pred? (vector-ref vec i))
(loop1 pred? vec (add1 i) len))))) (loop1 pred? vec (add1 i) len)))))
(loop2+ (lambda (pred? vectors i len) (loop2+ (lambda (pred? vectors i len)
(and (not (= i len)) (and (not (= i len))
(or (apply pred? (vectors-ref vectors i)) (or (apply pred? (vectors-ref vectors i))
(loop2+ pred? vectors (add1 i) len)))))) (loop2+ pred? vectors (add1 i) len))))))
(lambda (pred? vec . vectors) (lambda (pred? vec . vectors)
(unless (procedure? pred?) (unless (procedure? pred?)
(apply raise-type-error (apply raise-type-error
'vector-any "procedure" 0 'vector-any "procedure" 0
pred? vec vectors)) pred? vec vectors))
(unless (vector? vec) (unless (vector? vec)
(apply raise-type-error (apply raise-type-error
'vector-any "vector" 1 'vector-any "vector" 1
pred? vec vectors)) pred? vec vectors))
(if (null? vectors) (if (null? vectors)
(loop1 pred? vec 0 (vector-length vec)) (loop1 pred? vec 0 (vector-length vec))
(begin (check-list-of-vecs vectors 'vector-any 2 (begin (check-list-of-vecs vectors 'vector-any 2
(list* pred? vec vectors)) (list* pred? vec vectors))
(loop2+ pred? (cons vec vectors) (loop2+ pred? (cons vec vectors)
0 (%smallest-length vectors 0 (%smallest-length vectors
(vector-length vec)))))))) (vector-length vec))))))))
;;; (VECTOR-EVERY <pred?> <vector> ...) -> value ;;; (VECTOR-EVERY <pred?> <vector> ...) -> value
;;; Apply PRED? to each parallel value in each VECTOR ...; if PRED? ;;; Apply PRED? to each parallel value in each VECTOR ...; if PRED?
;;; should ever return #F, immediately stop and return #F; otherwise, ;;; should ever return #F, immediately stop and return #F; otherwise,
;;; if PRED? should return a true value for each element, stopping at ;;; if PRED? should return a true value for each element, stopping at
;;; the end of the shortest vector, return the last value that PRED? ;;; the end of the shortest vector, return the last value that PRED?
;;; returned. In the case that there is an empty vector, return #T. ;;; returned. In the case that there is an empty vector, return #T.
;;; The iteration and order of application of PRED? across elements ;;; The iteration and order of application of PRED? across elements
;;; is of the vectors is strictly left-to-right. ;;; is of the vectors is strictly left-to-right.
(define vector-every (define vector-every
(letrec ((loop1 (lambda (pred? vec i len) (letrec ((loop1 (lambda (pred? vec i len)
(or (> i len) (or (> i len)
(if (= i len) (if (= i len)
(pred? (vector-ref vec i)) (pred? (vector-ref vec i))
(and (pred? (vector-ref vec i)) (and (pred? (vector-ref vec i))
(loop1 pred? vec (add1 i) len)))))) (loop1 pred? vec (add1 i) len))))))
(loop2+ (lambda (pred? vectors i len) (loop2+ (lambda (pred? vectors i len)
(or (> i len) (or (> i len)
(if (= i len) (if (= i len)
(apply pred? (vectors-ref vectors i)) (apply pred? (vectors-ref vectors i))
(and (apply pred? (vectors-ref vectors i)) (and (apply pred? (vectors-ref vectors i))
(loop2+ pred? vectors (add1 i) len))))))) (loop2+ pred? vectors (add1 i) len)))))))
(lambda (pred? vec . vectors) (lambda (pred? vec . vectors)
(unless (procedure? pred?) (unless (procedure? pred?)
(apply raise-type-error (apply raise-type-error
'vector-every "procedure" 0 'vector-every "procedure" 0
pred? vec vectors)) pred? vec vectors))
(unless (vector? vec) (unless (vector? vec)
(apply raise-type-error (apply raise-type-error
'vector-every "vector" 1 'vector-every "vector" 1
pred? vec vectors)) pred? vec vectors))
(if (null? vectors) (if (null? vectors)
(loop1 pred? vec 0 (sub1 (vector-length vec))) (loop1 pred? vec 0 (sub1 (vector-length vec)))
(begin (check-list-of-vecs vectors 'vector-every 2 (begin (check-list-of-vecs vectors 'vector-every 2
(list* pred? vec vectors)) (list* pred? vec vectors))
(loop2+ pred? (loop2+ pred?
(cons vec vectors) (cons vec vectors)
0 0
(sub1 (sub1
(%smallest-length vectors (%smallest-length vectors
(vector-length vec)))))))))) (vector-length vec))))))))))

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

@ -1,162 +1,162 @@
;;; ;;;
;;; <util.ss> ---- Utility functions ;;; <util.ss> ---- Utility functions
;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> ;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai>
;;; ;;;
;;; Copyright (C) 2005 by Zhu Chongkai. ;;; Copyright (C) 2005 by Zhu Chongkai.
;;; ;;;
;;; This file is part of SRFI-43. ;;; This file is part of SRFI-43.
;;; SRFI-43 is free software; you can redistribute it and/or ;;; SRFI-43 is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public ;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either ;;; License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version. ;;; 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, ;;; SRFI-43 is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details. ;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public ;;; You should have received a copy of the GNU Lesser General Public
;;; License along with SRFI-43; if not, write to the Free Software ;;; License along with SRFI-43; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Zhu Chongkai <mrmathematica@yahoo.com> ;;; Author: Zhu Chongkai <mrmathematica@yahoo.com>
;; ;;
;; ;;
;; Commentary: ;; Commentary:
;; Based on the reference implementation by Taylor Campbell and hence: ;; Based on the reference implementation by Taylor Campbell and hence:
;;; Copyright (C) 2003, 2004 Taylor Campbell. ;;; Copyright (C) 2003, 2004 Taylor Campbell.
;;; All rights reserved. ;;; All rights reserved.
;;; ;;;
;;; You may do as you please with this code, as long as you refrain ;;; 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_ ;;; from removing this copyright notice or holding me liable in _any_
;;; circumstances for _any_ damages that may be caused by it; and you ;;; 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. ;;; may quote sections from it as you please, as long as you credit me.
(module util mzscheme (module util mzscheme
(require (lib "etc.ss" "mzlib") (require (lib "etc.ss" "mzlib")
(lib "receive.ss" "srfi" "8")) (lib "receive.ss" "srfi" "8"))
(provide (all-defined)) (provide (all-defined))
;;; (CHECK-INDEX <vector> <index> <callee>) -> ;;; (CHECK-INDEX <vector> <index> <callee>) ->
;;; Ensure that INDEX is a valid index into VECTOR; if not, signal an ;;; 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 ;;; 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 ;;; CALLEE. (Note that this does NOT check that VECTOR is indeed a
;;; vector.) ;;; vector.)
(define (check-index vec index callee) (define (check-index vec index callee)
(unless (nonneg-int? index) (unless (nonneg-int? index)
(raise-type-error callee "non-negative exact integer" index)) (raise-type-error callee "non-negative exact integer" index))
(unless (and (<= 0 index) (unless (and (<= 0 index)
(< index (vector-length vec))) (< index (vector-length vec)))
(raise (raise
(make-exn:fail:contract (make-exn:fail:contract
(string->immutable-string (string->immutable-string
(format "~a: index ~a out of range for vector: ~a" (format "~a: index ~a out of range for vector: ~a"
callee index vec)) callee index vec))
(current-continuation-marks))))) (current-continuation-marks)))))
;;; (CHECK-START <vector> <index> <callee>) -> ;;; (CHECK-START <vector> <index> <callee>) ->
;;; Ensure that INDEX is a valid bound of VECTOR; if not, signal an ;;; 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 ;;; 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 ;;; CALLEE. (Note that this does NOT check that VECTOR is indeed a
;;; vector.) ;;; vector.)
(define (check-start vec index callee) (define (check-start vec index callee)
(unless (nonneg-int? index) (unless (nonneg-int? index)
(raise-type-error callee "non-negative exact integer" index)) (raise-type-error callee "non-negative exact integer" index))
(unless (<= 0 index (vector-length vec)) (unless (<= 0 index (vector-length vec))
(raise (raise
(make-exn:fail:contract (make-exn:fail:contract
(string->immutable-string (string->immutable-string
(format "~a: index ~a out of range for vector: ~a" (format "~a: index ~a out of range for vector: ~a"
callee index vec)) callee index vec))
(current-continuation-marks))))) (current-continuation-marks)))))
;;; (CHECK-INDICES <vector> <start> <end> <caller>) -> ;;; (CHECK-INDICES <vector> <start> <end> <caller>) ->
;;; Ensure that START and END are valid bounds of a range within ;;; Ensure that START and END are valid bounds of a range within
;;; VECTOR; if not, signal an error stating that they are not ;;; VECTOR; if not, signal an error stating that they are not
;;; while calling CALLEE. ;;; while calling CALLEE.
(define (check-indices vec start end callee) (define (check-indices vec start end callee)
(unless (nonneg-int? start) (unless (nonneg-int? start)
(raise-type-error callee "non-negative exact integer" start)) (raise-type-error callee "non-negative exact integer" start))
(unless (nonneg-int? end) (unless (nonneg-int? end)
(raise-type-error callee "non-negative exact integer" end)) (raise-type-error callee "non-negative exact integer" end))
(unless (<= 0 start end (vector-length vec)) (unless (<= 0 start end (vector-length vec))
(raise (raise
(make-exn:fail:contract (make-exn:fail:contract
(string->immutable-string (string->immutable-string
(format "~a: indices (~a, ~a) out of range for vector: ~a" (format "~a: indices (~a, ~a) out of range for vector: ~a"
callee start end vec)) callee start end vec))
(current-continuation-marks))))) (current-continuation-marks)))))
(define (nonneg-int? x) (define (nonneg-int? x)
(and (integer? x) (and (integer? x)
(exact? x) (exact? x)
(not (negative? x)))) (not (negative? x))))
;;; (%VECTOR-COPY! <target> <tstart> <source> <sstart> <send>) ;;; (%VECTOR-COPY! <target> <tstart> <source> <sstart> <send>)
;;; Copy elements at locations SSTART to SEND from SOURCE to TARGET, ;;; Copy elements at locations SSTART to SEND from SOURCE to TARGET,
;;; starting at TSTART in TARGET. ;;; starting at TSTART in TARGET.
(define (%vector-copy! target tstart source sstart send) (define (%vector-copy! target tstart source sstart send)
(let loop ((i sstart) (let loop ((i sstart)
(j tstart)) (j tstart))
(cond ((< i send) (cond ((< i send)
(vector-set! target j (vector-set! target j
(vector-ref source i)) (vector-ref source i))
(loop (add1 i) (add1 j)))))) (loop (add1 i) (add1 j))))))
;;; (%VECTOR-REVERSE-COPY! <target> <tstart> <source> <sstart> <send>) ;;; (%VECTOR-REVERSE-COPY! <target> <tstart> <source> <sstart> <send>)
;;; Copy elements from SSTART to SEND from SOURCE to TARGET, in the ;;; Copy elements from SSTART to SEND from SOURCE to TARGET, in the
;;; reverse order. ;;; reverse order.
(define %vector-reverse-copy! (define %vector-reverse-copy!
(letrec ((loop (lambda (target source sstart i j) (letrec ((loop (lambda (target source sstart i j)
(cond ((>= i sstart) (cond ((>= i sstart)
(vector-set! target j (vector-ref source i)) (vector-set! target j (vector-ref source i))
(loop target source sstart (loop target source sstart
(sub1 i) (sub1 i)
(add1 j))))))) (add1 j)))))))
(lambda (target tstart source sstart send) (lambda (target tstart source sstart send)
(loop target source sstart (loop target source sstart
(sub1 send) (sub1 send)
tstart)))) tstart))))
;; type-check : check whether list-of-vecs is list of VECTORs ;; type-check : check whether list-of-vecs is list of VECTORs
(define check-list-of-vecs (define check-list-of-vecs
(opt-lambda (list-of-vecs caller (n 0) (all-args list-of-vecs)) (opt-lambda (list-of-vecs caller (n 0) (all-args list-of-vecs))
(let loop ((l list-of-vecs) (let loop ((l list-of-vecs)
(i 0)) (i 0))
(unless (null? l) (unless (null? l)
(if (vector? (car l)) (if (vector? (car l))
(loop (cdr l) (add1 i)) (loop (cdr l) (add1 i))
(apply raise-type-error (apply raise-type-error
caller "vector" caller "vector"
(+ n i) (+ n i)
all-args)))))) all-args))))))
;;; (%SMALLEST-LENGTH <vector-list> <default-length>) ;;; (%SMALLEST-LENGTH <vector-list> <default-length>)
;;; -> exact, nonnegative integer ;;; -> exact, nonnegative integer
;;; Compute the smallest length of VECTOR-LIST. DEFAULT-LENGTH is ;;; Compute the smallest length of VECTOR-LIST. DEFAULT-LENGTH is
;;; the length that is returned if VECTOR-LIST is empty. Common use ;;; the length that is returned if VECTOR-LIST is empty. Common use
;;; of this is in n-ary vector routines: ;;; of this is in n-ary vector routines:
;;; (define (f vec . vectors) ;;; (define (f vec . vectors)
(define (%smallest-length vector-list length) (define (%smallest-length vector-list length)
(if (null? vector-list) (if (null? vector-list)
length length
(%smallest-length (cdr vector-list) (%smallest-length (cdr vector-list)
(min length (min length
(vector-length (car vector-list)))))) (vector-length (car vector-list))))))
(define (vectors-ref vectors i) (define (vectors-ref vectors i)
(map (lambda (v) (vector-ref v i)) vectors)) (map (lambda (v) (vector-ref v i)) vectors))
;;; from vector-unfold-right ;;; from vector-unfold-right
(define (unfold1! f vec i seed) (define (unfold1! f vec i seed)
(if (>= i 0) (if (>= i 0)
(receive (elt new-seed) (receive (elt new-seed)
(f i seed) (f i seed)
(vector-set! vec i elt) (vector-set! vec i elt)
(unfold1! f vec (sub1 i) new-seed))))) (unfold1! f vec (sub1 i) new-seed)))))

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

@ -1,43 +1,43 @@
;;; ;;;
;;; <util.ss> ---- Utility functions ;;; <util.ss> ---- Utility functions
;;; Time-stamp: <05/03/07 18:21:41 Zhu Chongkai> ;;; Time-stamp: <05/03/07 18:21:41 Zhu Chongkai>
;;; ;;;
;;; Copyright (C) 2005 by Zhu Chongkai. ;;; Copyright (C) 2005 by Zhu Chongkai.
;;; ;;;
;;; This file is part of SRFI-43. ;;; This file is part of SRFI-43.
;;; SRFI-43 is free software; you can redistribute it and/or ;;; SRFI-43 is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public ;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either ;;; License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version. ;;; 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, ;;; SRFI-43 is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details. ;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public ;;; You should have received a copy of the GNU Lesser General Public
;;; License along with SRFI-43; if not, write to the Free Software ;;; License along with SRFI-43; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Zhu Chongkai <mrmathematica@yahoo.com> ;;; Author: Zhu Chongkai <mrmathematica@yahoo.com>
;; ;;
(module vector-lib mzscheme (module vector-lib mzscheme
(require "constructors.ss" (require "constructors.ss"
"predicates.ss" "predicates.ss"
"iteration.ss" "iteration.ss"
"searching.ss" "searching.ss"
(all-except "mutators.ss" vector-fill!) (all-except "mutators.ss" vector-fill!)
(rename "mutators.ss" s:vector-fill! vector-fill!) (rename "mutators.ss" s:vector-fill! vector-fill!)
(all-except "conversion.ss" vector->list) (all-except "conversion.ss" vector->list)
(rename "conversion.ss" s:vector->list vector->list)) (rename "conversion.ss" s:vector->list vector->list))
(provide (provide
(all-from "constructors.ss") (all-from "constructors.ss")
(all-from "predicates.ss") (all-from "predicates.ss")
(all-from "iteration.ss") (all-from "iteration.ss")
(all-from "searching.ss") (all-from "searching.ss")
(all-from "mutators.ss") (all-from "mutators.ss")
(all-from "conversion.ss"))) (all-from "conversion.ss")))

332
src/worksp/README
View File

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

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

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