diff --git a/collects/icons/help16x16.xpm b/collects/icons/help16x16.xpm index 73bbe672fc..62f764fb32 100644 --- a/collects/icons/help16x16.xpm +++ b/collects/icons/help16x16.xpm @@ -1,23 +1,23 @@ -/* XPM */ -static char * mred[] = { -"16 16 4 1", -" c #000000", -". c #0000ff", -"X c #ffffff", -"o c #ff0000", -" ", -" .XXXX. ", -" ooXXXXXX.. ", -" ooXXXooXXX.. ", -" ooXXooooXX.. ", -" oooooooooXX... ", -" ooooooooXXX... ", -" oooooooXXX.... ", -" ooooooXXX..... ", -" ooooooXX...... ", -" ooooooXX...... ", -" oooooXX..... ", -" oooooo...... ", -" ooooXX.... ", -" ooXX.. ", -" "}; +/* XPM */ +static char * mred[] = { +"16 16 4 1", +" c #000000", +". c #0000ff", +"X c #ffffff", +"o c #ff0000", +" ", +" .XXXX. ", +" ooXXXXXX.. ", +" ooXXXooXXX.. ", +" ooXXooooXX.. ", +" oooooooooXX... ", +" ooooooooXXX... ", +" oooooooXXX.... ", +" ooooooXXX..... ", +" ooooooXX...... ", +" ooooooXX...... ", +" oooooXX..... ", +" oooooo...... ", +" ooooXX.... ", +" ooXX.. ", +" "}; diff --git a/collects/icons/help32x32.xpm b/collects/icons/help32x32.xpm index 744dbb45df..e8be0098c6 100644 --- a/collects/icons/help32x32.xpm +++ b/collects/icons/help32x32.xpm @@ -1,39 +1,39 @@ -/* XPM */ -static char * mred[] = { -"32 32 4 1", -" c #000000", -". c #ff0000", -"X c #0000ff", -"o c #ffffff", -" ", -" .. XX ", -" .. ooooooo XX ", -" .. ooooooooooo XXX ", -" .. ooooooooooooo XXX ", -" .. ooooooooooooooo XXX ", -" .. ooooo ooooo XXX ", -" ... oooo ....... oooo XXXX ", -" ... oooo ....... oooo XXXX ", -" .... oooo ....... oooo XXXXX ", -" ..... ........ oooo XXXXX ", -" ................. ooooo XXXXXX ", -" ................ oooooo XXXXXX ", -" ............... oooooo XXXXXXX ", -" .............. oooooo XXXXXXXX ", -" ............. oooooo XXXXXXXXX ", -" ............ oooooo XXXXXXXXXX ", -" ............ ooooo XXXXXXXXXXX ", -" ............ oooo XXXXXXXXXXXX ", -" ............ oooo XXXXXXXXXXXX ", -" ............ oooo XXXXXXXXXXXX ", -" ........... oooo XXXXXXXXXXX ", -" ............ oo XXXXXXXXXXXX ", -" ............ XXXXXXXXXXXX ", -" .............XXXXXXXXXXXXX ", -" ........... XXXXXXXXXXX ", -" ........ oo XXXXXXXX ", -" ...... oooooo XXXXXX ", -" .... oooooo XXXX ", -" .... oo XXXX ", -" .... XXXX ", -" "}; +/* XPM */ +static char * mred[] = { +"32 32 4 1", +" c #000000", +". c #ff0000", +"X c #0000ff", +"o c #ffffff", +" ", +" .. XX ", +" .. ooooooo XX ", +" .. ooooooooooo XXX ", +" .. ooooooooooooo XXX ", +" .. ooooooooooooooo XXX ", +" .. ooooo ooooo XXX ", +" ... oooo ....... oooo XXXX ", +" ... oooo ....... oooo XXXX ", +" .... oooo ....... oooo XXXXX ", +" ..... ........ oooo XXXXX ", +" ................. ooooo XXXXXX ", +" ................ oooooo XXXXXX ", +" ............... oooooo XXXXXXX ", +" .............. oooooo XXXXXXXX ", +" ............. oooooo XXXXXXXXX ", +" ............ oooooo XXXXXXXXXX ", +" ............ ooooo XXXXXXXXXXX ", +" ............ oooo XXXXXXXXXXXX ", +" ............ oooo XXXXXXXXXXXX ", +" ............ oooo XXXXXXXXXXXX ", +" ........... oooo XXXXXXXXXXX ", +" ............ oo XXXXXXXXXXXX ", +" ............ XXXXXXXXXXXX ", +" .............XXXXXXXXXXXXX ", +" ........... XXXXXXXXXXX ", +" ........ oo XXXXXXXX ", +" ...... oooooo XXXXXX ", +" .... oooooo XXXX ", +" .... oo XXXX ", +" .... XXXX ", +" "}; diff --git a/collects/plot/src/all/resource.h b/collects/plot/src/all/resource.h index 0ea8298b8a..f21f20f302 100644 --- a/collects/plot/src/all/resource.h +++ b/collects/plot/src/all/resource.h @@ -1,24 +1,24 @@ -//{{NO_DEPENDENCIES}} -// Microsoft Developer Studio generated include file. -// Used by plplot.rc -// -#define IDR_MENU1 101 -#define IDI_ICON1 102 -#define PLCOMMANDS 106 -#define PLICON 107 -#define CM_NEXTPLOT 40002 -#define CM_PRINTPLOT 40003 -#define CM_EDITCOPY 40004 -#define CM_ABOUT 40005 - -// Next default values for new objects -// -#ifdef APSTUDIO_INVOKED -#ifndef APSTUDIO_READONLY_SYMBOLS -#define _APS_NO_MFC 1 -#define _APS_NEXT_RESOURCE_VALUE 108 -#define _APS_NEXT_COMMAND_VALUE 40006 -#define _APS_NEXT_CONTROL_VALUE 1000 -#define _APS_NEXT_SYMED_VALUE 101 -#endif -#endif +//{{NO_DEPENDENCIES}} +// Microsoft Developer Studio generated include file. +// Used by plplot.rc +// +#define IDR_MENU1 101 +#define IDI_ICON1 102 +#define PLCOMMANDS 106 +#define PLICON 107 +#define CM_NEXTPLOT 40002 +#define CM_PRINTPLOT 40003 +#define CM_EDITCOPY 40004 +#define CM_ABOUT 40005 + +// Next default values for new objects +// +#ifdef APSTUDIO_INVOKED +#ifndef APSTUDIO_READONLY_SYMBOLS +#define _APS_NO_MFC 1 +#define _APS_NEXT_RESOURCE_VALUE 108 +#define _APS_NEXT_COMMAND_VALUE 40006 +#define _APS_NEXT_CONTROL_VALUE 1000 +#define _APS_NEXT_SYMED_VALUE 101 +#endif +#endif diff --git a/collects/srfi/43/constructors.ss b/collects/srfi/43/constructors.ss index 52f4a68556..f00f6ce2e8 100644 --- a/collects/srfi/43/constructors.ss +++ b/collects/srfi/43/constructors.ss @@ -1,218 +1,218 @@ -;;; -;;; ---- Vector constructors -;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> -;;; -;;; Copyright (C) 2005 by Zhu Chongkai. -;;; -;;; This file is part of SRFI-43. - -;;; SRFI-43 is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public -;;; License as published by the Free Software Foundation; either -;;; version 2.1 of the License, or (at your option) any later version. - -;;; SRFI-43 is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. - -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with SRFI-43; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -;;; Author: Zhu Chongkai -;; -;; -;; Commentary: - -;; Based on the reference implementation by Taylor Campbell and hence: - -;;; Copyright (C) 2003, 2004 Taylor Campbell. -;;; All rights reserved. -;;; -;;; You may do as you please with this code, as long as you refrain -;;; from removing this copyright notice or holding me liable in _any_ -;;; circumstances for _any_ damages that may be caused by it; and you -;;; may quote sections from it as you please, as long as you credit me. - - -(module constructors mzscheme - - (require (lib "receive.ss" "srfi" "8") - "util.ss" - (lib "etc.ss" "mzlib")) - - (provide vector-unfold - vector-unfold-right - vector-copy - vector-reverse-copy - vector-append - vector-concatenate) - - ;;; (VECTOR-UNFOLD ...) -> vector - ;;; (F ...) -> [elt seed' ...] - ;;; The fundamental vector constructor. Creates a vector whose - ;;; length is LENGTH and iterates across each index K between 0 and - ;;; LENGTH, applying F at each iteration to the current index and the - ;;; current seeds to receive N+1 values: first, the element to put in - ;;; the Kth slot and then N new seeds for the next iteration. - (define vector-unfold - (letrec ((tabulate! ; Special zero-seed case. - (lambda (f vec i len) - (cond ((< i len) - (vector-set! vec i (f i)) - (tabulate! f vec (add1 i) len))))) - (unfold1! ; Fast path for one seed. - (lambda (f vec i len seed) - (if (< i len) - (receive (elt new-seed) - (f i seed) - (vector-set! vec i elt) - (unfold1! f vec (add1 i) len new-seed))))) - (unfold2+! ; Slower variant for N seeds. - (lambda (f vec i len seeds) - (if (< i len) - (receive (elt . new-seeds) - (apply f i seeds) - (vector-set! vec i elt) - (unfold2+! f vec (add1 i) len new-seeds)))))) - (lambda (f len . initial-seeds) - (unless (procedure? f) - (apply raise-type-error - 'vector-unfold "procedure" 0 - f len initial-seeds)) - (unless (nonneg-int? len) - (apply raise-type-error - 'vector-unfold "non-negative exact integer" 1 - f len initial-seeds)) - (let ((vec (make-vector len))) - (cond ((null? initial-seeds) - (tabulate! f vec 0 len)) - ((null? (cdr initial-seeds)) - (unfold1! f vec 0 len (car initial-seeds))) - (else - (unfold2+! f vec 0 len initial-seeds))) - vec)))) - - ;;; (VECTOR-UNFOLD-RIGHT ...) -> vector - ;;; (F ...) -> [seed' ...] - ;;; Like VECTOR-UNFOLD, but it generates elements from LENGTH to 0 - ;;; (still exclusive with LENGTH and inclusive with 0), not 0 to - ;;; LENGTH as with VECTOR-UNFOLD. - (define vector-unfold-right - (letrec ((tabulate! - (lambda (f vec i) - (cond ((>= i 0) - (vector-set! vec i (f i)) - (tabulate! f vec (sub1 i)))))) - (unfold2+! - (lambda (f vec i seeds) - (if (>= i 0) - (receive (elt . new-seeds) - (apply f i seeds) - (vector-set! vec i elt) - (unfold2+! f vec (sub1 i) new-seeds)))))) - (lambda (f len . initial-seeds) - (unless (procedure? f) - (apply raise-type-error - 'vector-unfold-right "procedure" 0 - f len initial-seeds)) - (unless (nonneg-int? len) - (apply raise-type-error - 'vector-unfold-right "non-negative exact integer" 1 - f len initial-seeds)) - (let ((vec (make-vector len)) - (i (sub1 len))) - (cond ((null? initial-seeds) - (tabulate! f vec i)) - ((null? (cdr initial-seeds)) - (unfold1! f vec i (car initial-seeds))) - (else - (unfold2+! f vec i initial-seeds))) - vec)))) - - ;;; (VECTOR-COPY [ ]) -> vector - ;;; Create a newly allocated vector containing the elements from the - ;;; range [START,END) in VECTOR. START defaults to 0; END defaults - ;;; to the length of VECTOR. END may be greater than the length of - ;;; VECTOR, in which case the vector is enlarged; if FILL is passed, - ;;; the new locations from which there is no respective element in - ;;; VECTOR are filled with FILL. - (define (vector-copy vec . arg) - (unless (vector? vec) - (raise-type-error 'vector-copy "vector" vec)) - (apply - (opt-lambda (vec (start 0) (end (vector-length vec)) . fill) - (check-start vec start 'vector-copy) - (unless (nonneg-int? end) - (raise-type-error 'vector-copy "non-negative exact integer" end)) - (unless (<= start end) - (raise - (make-exn:fail:contract - (string->immutable-string - (format "~a: indices (~a, ~a) out of range for vector: ~a" - 'vector-copy start end vec)) - (current-continuation-marks)))) - (let ((new-vector - (apply make-vector (cons (- end start) fill)))) - (%vector-copy! new-vector 0 - vec start - (min end (vector-length vec))) - new-vector)) - vec arg)) - - ;;; (VECTOR-REVERSE-COPY [ ]) -> vector - ;;; Create a newly allocated vector whose elements are the reversed - ;;; sequence of elements between START and END in VECTOR. START's - ;;; default is 0; END's default is the length of VECTOR. - (define (vector-reverse-copy vec . arg) - (unless (vector? vec) - (raise-type-error 'vector-reverse-copy "vector" vec)) - (apply - (opt-lambda (vec (start 0) (end (vector-length vec))) - (check-indices vec start end 'vector-reverse-copy) - (let ((new (make-vector (- end start)))) - (%vector-reverse-copy! new 0 vec start end) - new)) - vec arg)) - - ;;; (VECTOR-APPEND ...) -> vector - ;;; Append VECTOR ... into a newly allocated vector and return that - ;;; new vector. - (define (vector-append . vectors) - (check-list-of-vecs vectors 'vector-append) - (vector-concatenate:aux vectors)) - - ;;; (VECTOR-CONCATENATE ) -> vector - ;;; Concatenate the vectors in VECTOR-LIST. This is equivalent to - ;;; (apply vector-append VECTOR-LIST) - ;;; Actually, they're both implemented in terms of an internal routine. - (define (vector-concatenate vector-list) - (unless (and (list? vector-list) - (andmap vector? vector-list)) - (raise-type-error 'vector-concatenate "list of vectors" vector-list)) - (vector-concatenate:aux vector-list)) - - ;;; Auxiliary for VECTOR-APPEND and VECTOR-CONCATENATE - (define vector-concatenate:aux - (letrec ((compute-length - (lambda (vectors len) - (if (null? vectors) - len - (let ((vec (car vectors))) - (compute-length (cdr vectors) - (+ (vector-length vec) len)))))) - (concatenate! - (lambda (vectors target to) - (if (null? vectors) - target - (let* ((vec1 (car vectors)) - (len (vector-length vec1))) - (%vector-copy! target to vec1 0 len) - (concatenate! (cdr vectors) target - (+ to len))))))) - (lambda (vectors) - (let ((new-vector - (make-vector (compute-length vectors 0)))) - (concatenate! vectors new-vector 0) - new-vector))))) +;;; +;;; ---- Vector constructors +;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> +;;; +;;; Copyright (C) 2005 by Zhu Chongkai. +;;; +;;; This file is part of SRFI-43. + +;;; SRFI-43 is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 2.1 of the License, or (at your option) any later version. + +;;; SRFI-43 is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. + +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with SRFI-43; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +;;; Author: Zhu Chongkai +;; +;; +;; Commentary: + +;; Based on the reference implementation by Taylor Campbell and hence: + +;;; Copyright (C) 2003, 2004 Taylor Campbell. +;;; All rights reserved. +;;; +;;; You may do as you please with this code, as long as you refrain +;;; from removing this copyright notice or holding me liable in _any_ +;;; circumstances for _any_ damages that may be caused by it; and you +;;; may quote sections from it as you please, as long as you credit me. + + +(module constructors mzscheme + + (require (lib "receive.ss" "srfi" "8") + "util.ss" + (lib "etc.ss" "mzlib")) + + (provide vector-unfold + vector-unfold-right + vector-copy + vector-reverse-copy + vector-append + vector-concatenate) + + ;;; (VECTOR-UNFOLD ...) -> vector + ;;; (F ...) -> [elt seed' ...] + ;;; The fundamental vector constructor. Creates a vector whose + ;;; length is LENGTH and iterates across each index K between 0 and + ;;; LENGTH, applying F at each iteration to the current index and the + ;;; current seeds to receive N+1 values: first, the element to put in + ;;; the Kth slot and then N new seeds for the next iteration. + (define vector-unfold + (letrec ((tabulate! ; Special zero-seed case. + (lambda (f vec i len) + (cond ((< i len) + (vector-set! vec i (f i)) + (tabulate! f vec (add1 i) len))))) + (unfold1! ; Fast path for one seed. + (lambda (f vec i len seed) + (if (< i len) + (receive (elt new-seed) + (f i seed) + (vector-set! vec i elt) + (unfold1! f vec (add1 i) len new-seed))))) + (unfold2+! ; Slower variant for N seeds. + (lambda (f vec i len seeds) + (if (< i len) + (receive (elt . new-seeds) + (apply f i seeds) + (vector-set! vec i elt) + (unfold2+! f vec (add1 i) len new-seeds)))))) + (lambda (f len . initial-seeds) + (unless (procedure? f) + (apply raise-type-error + 'vector-unfold "procedure" 0 + f len initial-seeds)) + (unless (nonneg-int? len) + (apply raise-type-error + 'vector-unfold "non-negative exact integer" 1 + f len initial-seeds)) + (let ((vec (make-vector len))) + (cond ((null? initial-seeds) + (tabulate! f vec 0 len)) + ((null? (cdr initial-seeds)) + (unfold1! f vec 0 len (car initial-seeds))) + (else + (unfold2+! f vec 0 len initial-seeds))) + vec)))) + + ;;; (VECTOR-UNFOLD-RIGHT ...) -> vector + ;;; (F ...) -> [seed' ...] + ;;; Like VECTOR-UNFOLD, but it generates elements from LENGTH to 0 + ;;; (still exclusive with LENGTH and inclusive with 0), not 0 to + ;;; LENGTH as with VECTOR-UNFOLD. + (define vector-unfold-right + (letrec ((tabulate! + (lambda (f vec i) + (cond ((>= i 0) + (vector-set! vec i (f i)) + (tabulate! f vec (sub1 i)))))) + (unfold2+! + (lambda (f vec i seeds) + (if (>= i 0) + (receive (elt . new-seeds) + (apply f i seeds) + (vector-set! vec i elt) + (unfold2+! f vec (sub1 i) new-seeds)))))) + (lambda (f len . initial-seeds) + (unless (procedure? f) + (apply raise-type-error + 'vector-unfold-right "procedure" 0 + f len initial-seeds)) + (unless (nonneg-int? len) + (apply raise-type-error + 'vector-unfold-right "non-negative exact integer" 1 + f len initial-seeds)) + (let ((vec (make-vector len)) + (i (sub1 len))) + (cond ((null? initial-seeds) + (tabulate! f vec i)) + ((null? (cdr initial-seeds)) + (unfold1! f vec i (car initial-seeds))) + (else + (unfold2+! f vec i initial-seeds))) + vec)))) + + ;;; (VECTOR-COPY [ ]) -> vector + ;;; Create a newly allocated vector containing the elements from the + ;;; range [START,END) in VECTOR. START defaults to 0; END defaults + ;;; to the length of VECTOR. END may be greater than the length of + ;;; VECTOR, in which case the vector is enlarged; if FILL is passed, + ;;; the new locations from which there is no respective element in + ;;; VECTOR are filled with FILL. + (define (vector-copy vec . arg) + (unless (vector? vec) + (raise-type-error 'vector-copy "vector" vec)) + (apply + (opt-lambda (vec (start 0) (end (vector-length vec)) . fill) + (check-start vec start 'vector-copy) + (unless (nonneg-int? end) + (raise-type-error 'vector-copy "non-negative exact integer" end)) + (unless (<= start end) + (raise + (make-exn:fail:contract + (string->immutable-string + (format "~a: indices (~a, ~a) out of range for vector: ~a" + 'vector-copy start end vec)) + (current-continuation-marks)))) + (let ((new-vector + (apply make-vector (cons (- end start) fill)))) + (%vector-copy! new-vector 0 + vec start + (min end (vector-length vec))) + new-vector)) + vec arg)) + + ;;; (VECTOR-REVERSE-COPY [ ]) -> vector + ;;; Create a newly allocated vector whose elements are the reversed + ;;; sequence of elements between START and END in VECTOR. START's + ;;; default is 0; END's default is the length of VECTOR. + (define (vector-reverse-copy vec . arg) + (unless (vector? vec) + (raise-type-error 'vector-reverse-copy "vector" vec)) + (apply + (opt-lambda (vec (start 0) (end (vector-length vec))) + (check-indices vec start end 'vector-reverse-copy) + (let ((new (make-vector (- end start)))) + (%vector-reverse-copy! new 0 vec start end) + new)) + vec arg)) + + ;;; (VECTOR-APPEND ...) -> vector + ;;; Append VECTOR ... into a newly allocated vector and return that + ;;; new vector. + (define (vector-append . vectors) + (check-list-of-vecs vectors 'vector-append) + (vector-concatenate:aux vectors)) + + ;;; (VECTOR-CONCATENATE ) -> vector + ;;; Concatenate the vectors in VECTOR-LIST. This is equivalent to + ;;; (apply vector-append VECTOR-LIST) + ;;; Actually, they're both implemented in terms of an internal routine. + (define (vector-concatenate vector-list) + (unless (and (list? vector-list) + (andmap vector? vector-list)) + (raise-type-error 'vector-concatenate "list of vectors" vector-list)) + (vector-concatenate:aux vector-list)) + + ;;; Auxiliary for VECTOR-APPEND and VECTOR-CONCATENATE + (define vector-concatenate:aux + (letrec ((compute-length + (lambda (vectors len) + (if (null? vectors) + len + (let ((vec (car vectors))) + (compute-length (cdr vectors) + (+ (vector-length vec) len)))))) + (concatenate! + (lambda (vectors target to) + (if (null? vectors) + target + (let* ((vec1 (car vectors)) + (len (vector-length vec1))) + (%vector-copy! target to vec1 0 len) + (concatenate! (cdr vectors) target + (+ to len))))))) + (lambda (vectors) + (let ((new-vector + (make-vector (compute-length vectors 0)))) + (concatenate! vectors new-vector 0) + new-vector))))) diff --git a/collects/srfi/43/conversion.ss b/collects/srfi/43/conversion.ss index 0a020c8271..a4adc1a9e2 100644 --- a/collects/srfi/43/conversion.ss +++ b/collects/srfi/43/conversion.ss @@ -1,101 +1,101 @@ -;;; -;;; ---- Vector conversion -;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> -;;; -;;; Copyright (C) 2005 by Zhu Chongkai. -;;; -;;; This file is part of SRFI-43. - -;;; SRFI-43 is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public -;;; License as published by the Free Software Foundation; either -;;; version 2.1 of the License, or (at your option) any later version. - -;;; SRFI-43 is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. - -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with SRFI-43; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -;;; Author: Zhu Chongkai -;; -;; -;; Commentary: - -;; Based on the reference implementation by Taylor Campbell and hence: - -;;; Copyright (C) 2003, 2004 Taylor Campbell. -;;; All rights reserved. -;;; -;;; You may do as you please with this code, as long as you refrain -;;; from removing this copyright notice or holding me liable in _any_ -;;; circumstances for _any_ damages that may be caused by it; and you -;;; may quote sections from it as you please, as long as you credit me. - -(module conversion mzscheme - - (require "util.ss" - (lib "etc.ss")) - - (provide (rename my-vector->list vector->list) - reverse-vector->list - reverse-list->vector) - - ;;; (VECTOR->LIST [ ]) -> list - ;;; [R5RS+] Produce a list containing the elements in the locations - ;;; between START, whose default is 0, and END, whose default is the - ;;; length of VECTOR, from VECTOR. - (define (my-vector->list vec . maybe-start+end) - (unless (vector? vec) - (apply raise-type-error - 'vector->list "vector" 0 - vec maybe-start+end)) - (if (null? maybe-start+end) - (vector->list vec) ;+++ - (apply (opt-lambda (vec (start 0) (end (vector-length vec))) - (check-indices vec start end 'vector->list) - ;(unfold (lambda (i) ; No SRFI 1. - ; (< i start)) - ; (lambda (i) (vector-ref vec i)) - ; (lambda (i) (sub1 i)) - ; (sub1 end)) - (do ((i (sub1 end) (sub1 i)) - (result '() (cons (vector-ref vec i) result))) - ((< i start) result))) - vec maybe-start+end))) - - ;;; (REVERSE-VECTOR->LIST [ ]) -> list - ;;; Produce a list containing the elements in the locations between - ;;; START, whose default is 0, and END, whose default is the length - ;;; of VECTOR, from VECTOR, in reverse order. - (define (reverse-vector->list vec . maybe-start+end) - (unless (vector? vec) - (apply raise-type-error - 'reverse-vector->list "vector" 0 - vec maybe-start+end)) - (apply (opt-lambda (vec (start 0) (end (vector-length vec))) - (check-indices vec start end 'reverse-vector->list) - ;(unfold (lambda (i) (= i end)) ; No SRFI 1. - ; (lambda (i) (vector-ref vec i)) - ; (lambda (i) (add1 i)) - ; start) - (do ((i start (add1 i)) - (result '() (cons (vector-ref vec i) result))) - ((= i end) result))) - vec maybe-start+end)) - - ;;; (REVERSE-LIST->VECTOR -> vector - ;;; Produce a vector containing the elements in LIST in reverse order. - (define (reverse-list->vector lst) - (unless (list? lst) - (raise-type-error 'reverse-list->vector "proper list" lst)) - (let* ((len (length lst)) - (vec (make-vector len))) - (unfold1! (lambda (index l) (values (car l) (cdr l))) - vec - (sub1 len) - lst) - vec))) +;;; +;;; ---- Vector conversion +;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> +;;; +;;; Copyright (C) 2005 by Zhu Chongkai. +;;; +;;; This file is part of SRFI-43. + +;;; SRFI-43 is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 2.1 of the License, or (at your option) any later version. + +;;; SRFI-43 is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. + +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with SRFI-43; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +;;; Author: Zhu Chongkai +;; +;; +;; Commentary: + +;; Based on the reference implementation by Taylor Campbell and hence: + +;;; Copyright (C) 2003, 2004 Taylor Campbell. +;;; All rights reserved. +;;; +;;; You may do as you please with this code, as long as you refrain +;;; from removing this copyright notice or holding me liable in _any_ +;;; circumstances for _any_ damages that may be caused by it; and you +;;; may quote sections from it as you please, as long as you credit me. + +(module conversion mzscheme + + (require "util.ss" + (lib "etc.ss")) + + (provide (rename my-vector->list vector->list) + reverse-vector->list + reverse-list->vector) + + ;;; (VECTOR->LIST [ ]) -> list + ;;; [R5RS+] Produce a list containing the elements in the locations + ;;; between START, whose default is 0, and END, whose default is the + ;;; length of VECTOR, from VECTOR. + (define (my-vector->list vec . maybe-start+end) + (unless (vector? vec) + (apply raise-type-error + 'vector->list "vector" 0 + vec maybe-start+end)) + (if (null? maybe-start+end) + (vector->list vec) ;+++ + (apply (opt-lambda (vec (start 0) (end (vector-length vec))) + (check-indices vec start end 'vector->list) + ;(unfold (lambda (i) ; No SRFI 1. + ; (< i start)) + ; (lambda (i) (vector-ref vec i)) + ; (lambda (i) (sub1 i)) + ; (sub1 end)) + (do ((i (sub1 end) (sub1 i)) + (result '() (cons (vector-ref vec i) result))) + ((< i start) result))) + vec maybe-start+end))) + + ;;; (REVERSE-VECTOR->LIST [ ]) -> list + ;;; Produce a list containing the elements in the locations between + ;;; START, whose default is 0, and END, whose default is the length + ;;; of VECTOR, from VECTOR, in reverse order. + (define (reverse-vector->list vec . maybe-start+end) + (unless (vector? vec) + (apply raise-type-error + 'reverse-vector->list "vector" 0 + vec maybe-start+end)) + (apply (opt-lambda (vec (start 0) (end (vector-length vec))) + (check-indices vec start end 'reverse-vector->list) + ;(unfold (lambda (i) (= i end)) ; No SRFI 1. + ; (lambda (i) (vector-ref vec i)) + ; (lambda (i) (add1 i)) + ; start) + (do ((i start (add1 i)) + (result '() (cons (vector-ref vec i) result))) + ((= i end) result))) + vec maybe-start+end)) + + ;;; (REVERSE-LIST->VECTOR -> vector + ;;; Produce a vector containing the elements in LIST in reverse order. + (define (reverse-list->vector lst) + (unless (list? lst) + (raise-type-error 'reverse-list->vector "proper list" lst)) + (let* ((len (length lst)) + (vec (make-vector len))) + (unfold1! (lambda (index l) (values (car l) (cdr l))) + vec + (sub1 len) + lst) + vec))) diff --git a/collects/srfi/43/iteration.ss b/collects/srfi/43/iteration.ss index 1f475bf3cc..bb31e9d7f1 100644 --- a/collects/srfi/43/iteration.ss +++ b/collects/srfi/43/iteration.ss @@ -1,278 +1,278 @@ -;;; -;;; ---- Vector iteration -;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> -;;; -;;; Copyright (C) 2005 by Zhu Chongkai. -;;; -;;; This file is part of SRFI-43. - -;;; SRFI-43 is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public -;;; License as published by the Free Software Foundation; either -;;; version 2.1 of the License, or (at your option) any later version. - -;;; SRFI-43 is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. - -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with SRFI-43; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -;;; Author: Zhu Chongkai -;; -;; -;; Commentary: - -;; Based on the reference implementation by Taylor Campbell and hence: - -;;; Copyright (C) 2003, 2004 Taylor Campbell. -;;; All rights reserved. -;;; -;;; You may do as you please with this code, as long as you refrain -;;; from removing this copyright notice or holding me liable in _any_ -;;; circumstances for _any_ damages that may be caused by it; and you -;;; may quote sections from it as you please, as long as you credit me. - -(module iteration mzscheme - - (require "util.ss") - - (provide vector-fold - vector-fold-right - vector-map - vector-map! - vector-for-each - vector-count) - - ;;; (VECTOR-FOLD ...) -> knil - ;;; (KONS ...) -> knil' ; N vectors -> N+1 args - ;;; The fundamental vector iterator. KONS is iterated over each - ;;; index in all of the vectors in parallel, stopping at the end of - ;;; the shortest; KONS is applied to an argument list of (list I - ;;; STATE (vector-ref VEC I) ...), where STATE is the current state - ;;; value -- the state value begins with KNIL and becomes whatever - ;;; KONS returned at the respective iteration --, and I is the - ;;; current index in the iteration. The iteration is strictly left- - ;;; to-right. - ;;; (vector-fold KONS KNIL (vector E_1 E_2 ... E_N)) - ;;; <=> - ;;; (KONS (... (KONS (KONS KNIL E_1) E_2) ... E_N-1) E_N) - (define (vector-fold kons knil vec . vectors) - (unless (procedure? kons) - (apply raise-type-error - 'vector-fold "procedure" 0 - kons knil vec vectors)) - (unless (vector? vec) - (apply raise-type-error - 'vector-fold "vector" 2 - kons knil vec vectors)) - (if (null? vectors) - (%vector-fold1 kons knil (vector-length vec) vec) - (begin (check-list-of-vecs vectors 'vector-fold 3 - (list* kons knil vec vectors)) - (%vector-fold2+ kons knil - (%smallest-length vectors - (vector-length vec)) - (cons vec vectors))))) - - (define %vector-fold1 - (letrec ((loop (lambda (kons knil len vec i) - (if (= i len) - knil - (loop kons - (kons i knil (vector-ref vec i)) - len vec (add1 i)))))) - (lambda (kons knil len vec) - (loop kons knil len vec 0)))) - (define %vector-fold2+ - (letrec ((loop (lambda (kons knil len vectors i) - (if (= i len) - knil - (loop kons - (apply kons i knil - (vectors-ref vectors i)) - len vectors (add1 i)))))) - (lambda (kons knil len vectors) - (loop kons knil len vectors 0)))) - - ;;; (VECTOR-COUNT ...) - ;;; -> exact, nonnegative integer - ;;; (PREDICATE? ...) ; N vectors -> N+1 args - ;;; PREDICATE? is applied element-wise to the elements of VECTOR ..., - ;;; and a count is tallied of the number of elements for which a - ;;; true value is produced by PREDICATE?. This count is returned. - (define (vector-count pred? vec . vectors) - (unless (procedure? pred?) - (apply raise-type-error - 'vector-count "procedure" 0 - pred? vec vectors)) - (if (null? vectors) - (%vector-fold1 (lambda (index count elt) - (if (pred? index elt) - (add1 count) - count)) - 0 - (vector-length vec) - vec) - (begin (check-list-of-vecs vectors 'vector-count 2 - (list* pred? vec vectors)) - (%vector-fold2+ (lambda (index count . elts) - (if (apply pred? index elts) - (add1 count) - count)) - 0 - (%smallest-length vectors - (vector-length vec)) - (cons vec vectors))))) - - ;;; (VECTOR-FOLD-RIGHT ...) -> knil - ;;; (KONS ...) -> knil' ; N vectors => N+1 args - ;;; The fundamental vector recursor. Iterates in parallel across - ;;; VECTOR ... right to left, applying KONS to the elements and the - ;;; current state value; the state value becomes what KONS returns - ;;; at each next iteration. KNIL is the initial state value. - ;;; (vector-fold-right KONS KNIL (vector E_1 E_2 ... E_N)) - ;;; <=> - ;;; (KONS (... (KONS (KONS KNIL E_N) E_N-1) ... E_2) E_1) - ;;; - ;;; Not implemented in terms of a more primitive operations that might - ;;; called %VECTOR-FOLD-RIGHT due to the fact that it wouldn't be very - ;;; useful elsewhere. - (define vector-fold-right - (letrec ((loop1 (lambda (kons knil vec i) - (if (zero? i) - knil - (let ((j (sub1 i))) - (loop1 kons - (kons j knil (vector-ref vec j)) - vec - j))))) - (loop2+ (lambda (kons knil vectors i) - (if (zero? i) - knil - (let ((j (sub1 i))) - (loop2+ kons - (apply kons j knil - (vectors-ref vectors j)) - vectors - j)))))) - (lambda (kons knil vec . vectors) - (unless (procedure? kons) - (apply raise-type-error - 'vector-fold-right "procedure" 0 - kons knil vec vectors)) - (unless (vector? vec) - (apply raise-type-error - 'vector-fold-right "vector" 2 - kons knil vec vectors)) - (if (null? vectors) - (loop1 kons knil vec (vector-length vec)) - (begin (check-list-of-vecs vectors 'vector-fold-right 3 - (list* kons knil vec vectors)) - (loop2+ kons knil (cons vec vectors) - (%smallest-length vectors - (vector-length vec)))))))) - - ;;; (VECTOR-MAP ...) -> vector - ;;; (F ...) -> value ; N vectors -> N args - ;;; Constructs a new vector of the shortest length of the vector - ;;; arguments. Each element at index I of the new vector is mapped - ;;; from the old vectors by (F I (vector-ref VECTOR I) ...). The - ;;; dynamic order of application of F is unspecified. - (define (vector-map f vec . vectors) - (unless (procedure? f) - (apply raise-type-error - 'vector-map "procedure" 0 - f vec vectors)) - (unless (vector? vec) - (apply raise-type-error - 'vector-map "vector" 1 - f vec vectors)) - (if (null? vectors) - (let ((len (vector-length vec))) - (%vector-map1! f (make-vector len) vec len)) - (begin (check-list-of-vecs vectors 'vector-map 2 - (list* f vec vectors)) - (let ((len (%smallest-length vectors - (vector-length vec)))) - (%vector-map2+! f (make-vector len) - (cons vec vectors) len))))) - - ;;; (%VECTOR-MAP1! ) - ;;; (F ) -> elt' - (define (%vector-map1! f target vec i) - (if (zero? i) - target - (let ((j (sub1 i))) - (vector-set! target j - (f j (vector-ref vec j))) - (%vector-map1! f target vec j)))) - (define (%vector-map2+! f target vectors i) - (if (zero? i) - target - (let ((j (sub1 i))) - (vector-set! target j - (apply f j (vectors-ref vectors j))) - (%vector-map2+! f target vectors j)))) - - ;;; (VECTOR-MAP! ...) -> vector - ;;; (F ...) -> element' ; N vectors -> N args - ;;; Similar to VECTOR-MAP, but rather than mapping the new elements - ;;; into a new vector, the new mapped elements are destructively - ;;; inserted into the first vector. Again, the dynamic order of - ;;; application of F is unspecified, so it is dangerous for F to - ;;; manipulate the first VECTOR. - (define (vector-map! f vec . vectors) - (unless (procedure? f) - (apply raise-type-error - 'vector-map! "procedure" 0 - f vec vectors)) - (unless (vector? vec) - (apply raise-type-error - 'vector-map! "vector" 1 - f vec vectors)) - (if (null? vectors) - (%vector-map1! f vec vec (vector-length vec)) - (begin (check-list-of-vecs vectors 'vector-map! 2 - (list* f vec vectors)) - (%vector-map2+! f vec (cons vec vectors) - (%smallest-length vectors - (vector-length vec)))))) - - ;;; (VECTOR-FOR-EACH ...) -> void - ;;; (F ...) ; N vectors -> N args - ;;; Simple vector iterator: applies F to each index in the range [0, - ;;; LENGTH), where LENGTH is the length of the smallest vector - ;;; argument passed, and the respective element at that index. In - ;;; contrast with VECTOR-MAP, F is reliably applied to each - ;;; subsequent elements, starting at index 0 from left to right, in - ;;; the vectors. - (define vector-for-each - (letrec ((for-each1 - (lambda (f vec i len) - (when (< i len) - (f i (vector-ref vec i)) - (for-each1 f vec (add1 i) len)))) - (for-each2+ - (lambda (f vecs i len) - (when (< i len) - (apply f i (vectors-ref vecs i)) - (for-each2+ f vecs (add1 i) len))))) - (lambda (f vec . vectors) - (unless (procedure? f) - (apply raise-type-error - 'vector-for-each "procedure" 0 - f vec vectors)) - (unless (vector? vec) - (apply raise-type-error - 'vector-for-each "vector" 1 - f vec vectors)) - (if (null? vectors) - (for-each1 f vec 0 (vector-length vec)) - (begin (check-list-of-vecs vectors 'vector-for-each 2 - (list* f vec vectors)) - (for-each2+ f (cons vec vectors) 0 - (%smallest-length vectors - (vector-length vec))))))))) +;;; +;;; ---- Vector iteration +;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> +;;; +;;; Copyright (C) 2005 by Zhu Chongkai. +;;; +;;; This file is part of SRFI-43. + +;;; SRFI-43 is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 2.1 of the License, or (at your option) any later version. + +;;; SRFI-43 is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. + +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with SRFI-43; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +;;; Author: Zhu Chongkai +;; +;; +;; Commentary: + +;; Based on the reference implementation by Taylor Campbell and hence: + +;;; Copyright (C) 2003, 2004 Taylor Campbell. +;;; All rights reserved. +;;; +;;; You may do as you please with this code, as long as you refrain +;;; from removing this copyright notice or holding me liable in _any_ +;;; circumstances for _any_ damages that may be caused by it; and you +;;; may quote sections from it as you please, as long as you credit me. + +(module iteration mzscheme + + (require "util.ss") + + (provide vector-fold + vector-fold-right + vector-map + vector-map! + vector-for-each + vector-count) + + ;;; (VECTOR-FOLD ...) -> knil + ;;; (KONS ...) -> knil' ; N vectors -> N+1 args + ;;; The fundamental vector iterator. KONS is iterated over each + ;;; index in all of the vectors in parallel, stopping at the end of + ;;; the shortest; KONS is applied to an argument list of (list I + ;;; STATE (vector-ref VEC I) ...), where STATE is the current state + ;;; value -- the state value begins with KNIL and becomes whatever + ;;; KONS returned at the respective iteration --, and I is the + ;;; current index in the iteration. The iteration is strictly left- + ;;; to-right. + ;;; (vector-fold KONS KNIL (vector E_1 E_2 ... E_N)) + ;;; <=> + ;;; (KONS (... (KONS (KONS KNIL E_1) E_2) ... E_N-1) E_N) + (define (vector-fold kons knil vec . vectors) + (unless (procedure? kons) + (apply raise-type-error + 'vector-fold "procedure" 0 + kons knil vec vectors)) + (unless (vector? vec) + (apply raise-type-error + 'vector-fold "vector" 2 + kons knil vec vectors)) + (if (null? vectors) + (%vector-fold1 kons knil (vector-length vec) vec) + (begin (check-list-of-vecs vectors 'vector-fold 3 + (list* kons knil vec vectors)) + (%vector-fold2+ kons knil + (%smallest-length vectors + (vector-length vec)) + (cons vec vectors))))) + + (define %vector-fold1 + (letrec ((loop (lambda (kons knil len vec i) + (if (= i len) + knil + (loop kons + (kons i knil (vector-ref vec i)) + len vec (add1 i)))))) + (lambda (kons knil len vec) + (loop kons knil len vec 0)))) + (define %vector-fold2+ + (letrec ((loop (lambda (kons knil len vectors i) + (if (= i len) + knil + (loop kons + (apply kons i knil + (vectors-ref vectors i)) + len vectors (add1 i)))))) + (lambda (kons knil len vectors) + (loop kons knil len vectors 0)))) + + ;;; (VECTOR-COUNT ...) + ;;; -> exact, nonnegative integer + ;;; (PREDICATE? ...) ; N vectors -> N+1 args + ;;; PREDICATE? is applied element-wise to the elements of VECTOR ..., + ;;; and a count is tallied of the number of elements for which a + ;;; true value is produced by PREDICATE?. This count is returned. + (define (vector-count pred? vec . vectors) + (unless (procedure? pred?) + (apply raise-type-error + 'vector-count "procedure" 0 + pred? vec vectors)) + (if (null? vectors) + (%vector-fold1 (lambda (index count elt) + (if (pred? index elt) + (add1 count) + count)) + 0 + (vector-length vec) + vec) + (begin (check-list-of-vecs vectors 'vector-count 2 + (list* pred? vec vectors)) + (%vector-fold2+ (lambda (index count . elts) + (if (apply pred? index elts) + (add1 count) + count)) + 0 + (%smallest-length vectors + (vector-length vec)) + (cons vec vectors))))) + + ;;; (VECTOR-FOLD-RIGHT ...) -> knil + ;;; (KONS ...) -> knil' ; N vectors => N+1 args + ;;; The fundamental vector recursor. Iterates in parallel across + ;;; VECTOR ... right to left, applying KONS to the elements and the + ;;; current state value; the state value becomes what KONS returns + ;;; at each next iteration. KNIL is the initial state value. + ;;; (vector-fold-right KONS KNIL (vector E_1 E_2 ... E_N)) + ;;; <=> + ;;; (KONS (... (KONS (KONS KNIL E_N) E_N-1) ... E_2) E_1) + ;;; + ;;; Not implemented in terms of a more primitive operations that might + ;;; called %VECTOR-FOLD-RIGHT due to the fact that it wouldn't be very + ;;; useful elsewhere. + (define vector-fold-right + (letrec ((loop1 (lambda (kons knil vec i) + (if (zero? i) + knil + (let ((j (sub1 i))) + (loop1 kons + (kons j knil (vector-ref vec j)) + vec + j))))) + (loop2+ (lambda (kons knil vectors i) + (if (zero? i) + knil + (let ((j (sub1 i))) + (loop2+ kons + (apply kons j knil + (vectors-ref vectors j)) + vectors + j)))))) + (lambda (kons knil vec . vectors) + (unless (procedure? kons) + (apply raise-type-error + 'vector-fold-right "procedure" 0 + kons knil vec vectors)) + (unless (vector? vec) + (apply raise-type-error + 'vector-fold-right "vector" 2 + kons knil vec vectors)) + (if (null? vectors) + (loop1 kons knil vec (vector-length vec)) + (begin (check-list-of-vecs vectors 'vector-fold-right 3 + (list* kons knil vec vectors)) + (loop2+ kons knil (cons vec vectors) + (%smallest-length vectors + (vector-length vec)))))))) + + ;;; (VECTOR-MAP ...) -> vector + ;;; (F ...) -> value ; N vectors -> N args + ;;; Constructs a new vector of the shortest length of the vector + ;;; arguments. Each element at index I of the new vector is mapped + ;;; from the old vectors by (F I (vector-ref VECTOR I) ...). The + ;;; dynamic order of application of F is unspecified. + (define (vector-map f vec . vectors) + (unless (procedure? f) + (apply raise-type-error + 'vector-map "procedure" 0 + f vec vectors)) + (unless (vector? vec) + (apply raise-type-error + 'vector-map "vector" 1 + f vec vectors)) + (if (null? vectors) + (let ((len (vector-length vec))) + (%vector-map1! f (make-vector len) vec len)) + (begin (check-list-of-vecs vectors 'vector-map 2 + (list* f vec vectors)) + (let ((len (%smallest-length vectors + (vector-length vec)))) + (%vector-map2+! f (make-vector len) + (cons vec vectors) len))))) + + ;;; (%VECTOR-MAP1! ) + ;;; (F ) -> elt' + (define (%vector-map1! f target vec i) + (if (zero? i) + target + (let ((j (sub1 i))) + (vector-set! target j + (f j (vector-ref vec j))) + (%vector-map1! f target vec j)))) + (define (%vector-map2+! f target vectors i) + (if (zero? i) + target + (let ((j (sub1 i))) + (vector-set! target j + (apply f j (vectors-ref vectors j))) + (%vector-map2+! f target vectors j)))) + + ;;; (VECTOR-MAP! ...) -> vector + ;;; (F ...) -> element' ; N vectors -> N args + ;;; Similar to VECTOR-MAP, but rather than mapping the new elements + ;;; into a new vector, the new mapped elements are destructively + ;;; inserted into the first vector. Again, the dynamic order of + ;;; application of F is unspecified, so it is dangerous for F to + ;;; manipulate the first VECTOR. + (define (vector-map! f vec . vectors) + (unless (procedure? f) + (apply raise-type-error + 'vector-map! "procedure" 0 + f vec vectors)) + (unless (vector? vec) + (apply raise-type-error + 'vector-map! "vector" 1 + f vec vectors)) + (if (null? vectors) + (%vector-map1! f vec vec (vector-length vec)) + (begin (check-list-of-vecs vectors 'vector-map! 2 + (list* f vec vectors)) + (%vector-map2+! f vec (cons vec vectors) + (%smallest-length vectors + (vector-length vec)))))) + + ;;; (VECTOR-FOR-EACH ...) -> void + ;;; (F ...) ; N vectors -> N args + ;;; Simple vector iterator: applies F to each index in the range [0, + ;;; LENGTH), where LENGTH is the length of the smallest vector + ;;; argument passed, and the respective element at that index. In + ;;; contrast with VECTOR-MAP, F is reliably applied to each + ;;; subsequent elements, starting at index 0 from left to right, in + ;;; the vectors. + (define vector-for-each + (letrec ((for-each1 + (lambda (f vec i len) + (when (< i len) + (f i (vector-ref vec i)) + (for-each1 f vec (add1 i) len)))) + (for-each2+ + (lambda (f vecs i len) + (when (< i len) + (apply f i (vectors-ref vecs i)) + (for-each2+ f vecs (add1 i) len))))) + (lambda (f vec . vectors) + (unless (procedure? f) + (apply raise-type-error + 'vector-for-each "procedure" 0 + f vec vectors)) + (unless (vector? vec) + (apply raise-type-error + 'vector-for-each "vector" 1 + f vec vectors)) + (if (null? vectors) + (for-each1 f vec 0 (vector-length vec)) + (begin (check-list-of-vecs vectors 'vector-for-each 2 + (list* f vec vectors)) + (for-each2+ f (cons vec vectors) 0 + (%smallest-length vectors + (vector-length vec))))))))) diff --git a/collects/srfi/43/mutators.ss b/collects/srfi/43/mutators.ss index a9957c27f6..2eaf2defdc 100644 --- a/collects/srfi/43/mutators.ss +++ b/collects/srfi/43/mutators.ss @@ -1,171 +1,171 @@ -;;; -;;; ---- Vector mutators -;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> -;;; -;;; Copyright (C) 2005 by Zhu Chongkai. -;;; -;;; This file is part of SRFI-43. - -;;; SRFI-43 is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public -;;; License as published by the Free Software Foundation; either -;;; version 2.1 of the License, or (at your option) any later version. - -;;; SRFI-43 is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. - -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with SRFI-43; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -;;; Author: Zhu Chongkai -;; -;; -;; Commentary: - -;; Based on the reference implementation by Taylor Campbell and hence: - -;;; Copyright (C) 2003, 2004 Taylor Campbell. -;;; All rights reserved. -;;; -;;; You may do as you please with this code, as long as you refrain -;;; from removing this copyright notice or holding me liable in _any_ -;;; circumstances for _any_ damages that may be caused by it; and you -;;; may quote sections from it as you please, as long as you credit me. - -(module mutators mzscheme - - (require "util.ss" - (lib "etc.ss")) - - (provide vector-swap! - (rename my-vector-fill! vector-fill!) - vector-reverse! - vector-copy! - vector-reverse-copy!) - - ;;; (VECTOR-SWAP! ) -> void - ;;; Swap the values in the locations at INDEX1 and INDEX2. - (define (vector-swap! vec i j) - (unless (vector? vec) - (raise-type-error 'vector-swap! "vector" 0 - vec i j)) - (check-index vec i 'vector-swap!) - (check-index vec j 'vector-swap!) - (%vector-swap! vec i j)) - - (define (%vector-swap! vec i j) - (let ((x (vector-ref vec i))) - (vector-set! vec i (vector-ref vec j)) - (vector-set! vec j x))) - - ;;; (VECTOR-FILL! [ ]) -> - ;;; [R5RS+] Fill the locations in VECTOR between START, whose default - ;;; is 0, and END, whose default is the length of VECTOR, with VALUE. - ;;; - ;;; This one can probably be made really fast natively. - (define (my-vector-fill! vec value . maybe-start+end) - (cond ((null? maybe-start+end) - (vector-fill! vec value)) ;+++ - ((not (vector? vec)) - (apply raise-type-error - 'vector-fill! "vector" 0 - vec value maybe-start+end)) - (else - (apply (opt-lambda (vec value (start 0) (end (vector-length vec))) - (check-indices vec start end 'vector-fill!) - (do ((i start (add1 i))) - ((= i end)) - (vector-set! vec i value)) - vec) - vec value maybe-start+end)))) - - (define %vector-reverse! - (letrec ((loop (lambda (vec i j) - (when (< i j) - (%vector-swap! vec i j) - (loop vec (add1 i) (sub1 j)))))) - (lambda (vec start end) - (loop vec start (sub1 end))))) - - ;;; (VECTOR-REVERSE! [ ]) -> void - ;;; Destructively reverse the contents of the sequence of locations - ;;; in VECTOR between START, whose default is 0, and END, whose - ;;; default is the length of VECTOR. - (define (vector-reverse! vec . maybe-start+end) - (unless (vector? vec) - (apply raise-type-error - 'vector-reverse! "vector" 0 - vec maybe-start+end)) - (apply (opt-lambda (vec (start 0) (end (vector-length vec))) - (check-indices vec start end 'vector-reverse!) - (%vector-reverse! vec start end)) - vec maybe-start+end)) - - ;;; (VECTOR-COPY! [ ]) - ;;; -> unspecified - ;;; Copy the values in the locations in [SSTART,SEND) from SOURCE to - ;;; to TARGET, starting at TSTART in TARGET. - (define (vector-copy! target tstart source . maybe-sstart+send) - (unless (vector? target) - (apply raise-type-error - 'vector-copy! "vector" 0 - target tstart source maybe-sstart+send)) - (check-start target tstart 'vector-copy!) - (unless (vector? source) - (apply raise-type-error - 'vector-copy! "vector" 2 - target tstart source maybe-sstart+send)) - (apply (opt-lambda (target - tstart - source - (sstart 0) - (send (vector-length source))) - (check-indices source sstart send 'vector-copy!) - (if (< (- (vector-length target) tstart) - (- send sstart)) - (error 'vector-copy! - "target vector not long enough to copy")) - (%vector-copy! target tstart source sstart send)) - target tstart source maybe-sstart+send)) - - ;;; (VECTOR-REVERSE-COPY! [ ]) - (define (vector-reverse-copy! target tstart source . maybe-sstart+send) - (unless (vector? target) - (apply raise-type-error - 'vector-reverse-copy! "vector" 0 - target tstart source maybe-sstart+send)) - (check-start target tstart 'vector-reverse-copy!) - (unless (vector? source) - (apply raise-type-error - 'vector-reverse-copy! "vector" 2 - target tstart source maybe-sstart+send)) - (apply (opt-lambda (target - tstart - source - (sstart 0) - (send (vector-length source))) - (check-indices source sstart send 'vector-reverse-copy!) - (cond ((< (- (vector-length target) tstart) - (- send sstart)) - (error 'vector-reverse-copy! - "target vector not long enough to copy")) - ((and (eq? target source) - (= sstart tstart)) - (%vector-reverse! target tstart send)) - ((and (eq? target source) - (or (between? sstart tstart send) - (between? tstart sstart - (+ tstart (- send sstart))))) - ;an error in the reference implement here - (error 'vector-reverse-copy! - "Vector range for self-copying overlaps")) - (else - (%vector-reverse-copy! target tstart - source sstart send)))) - target tstart source maybe-sstart+send)) - (define (between? x y z) - (and (< x y) +;;; +;;; ---- Vector mutators +;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> +;;; +;;; Copyright (C) 2005 by Zhu Chongkai. +;;; +;;; This file is part of SRFI-43. + +;;; SRFI-43 is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 2.1 of the License, or (at your option) any later version. + +;;; SRFI-43 is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. + +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with SRFI-43; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +;;; Author: Zhu Chongkai +;; +;; +;; Commentary: + +;; Based on the reference implementation by Taylor Campbell and hence: + +;;; Copyright (C) 2003, 2004 Taylor Campbell. +;;; All rights reserved. +;;; +;;; You may do as you please with this code, as long as you refrain +;;; from removing this copyright notice or holding me liable in _any_ +;;; circumstances for _any_ damages that may be caused by it; and you +;;; may quote sections from it as you please, as long as you credit me. + +(module mutators mzscheme + + (require "util.ss" + (lib "etc.ss")) + + (provide vector-swap! + (rename my-vector-fill! vector-fill!) + vector-reverse! + vector-copy! + vector-reverse-copy!) + + ;;; (VECTOR-SWAP! ) -> void + ;;; Swap the values in the locations at INDEX1 and INDEX2. + (define (vector-swap! vec i j) + (unless (vector? vec) + (raise-type-error 'vector-swap! "vector" 0 + vec i j)) + (check-index vec i 'vector-swap!) + (check-index vec j 'vector-swap!) + (%vector-swap! vec i j)) + + (define (%vector-swap! vec i j) + (let ((x (vector-ref vec i))) + (vector-set! vec i (vector-ref vec j)) + (vector-set! vec j x))) + + ;;; (VECTOR-FILL! [ ]) -> + ;;; [R5RS+] Fill the locations in VECTOR between START, whose default + ;;; is 0, and END, whose default is the length of VECTOR, with VALUE. + ;;; + ;;; This one can probably be made really fast natively. + (define (my-vector-fill! vec value . maybe-start+end) + (cond ((null? maybe-start+end) + (vector-fill! vec value)) ;+++ + ((not (vector? vec)) + (apply raise-type-error + 'vector-fill! "vector" 0 + vec value maybe-start+end)) + (else + (apply (opt-lambda (vec value (start 0) (end (vector-length vec))) + (check-indices vec start end 'vector-fill!) + (do ((i start (add1 i))) + ((= i end)) + (vector-set! vec i value)) + vec) + vec value maybe-start+end)))) + + (define %vector-reverse! + (letrec ((loop (lambda (vec i j) + (when (< i j) + (%vector-swap! vec i j) + (loop vec (add1 i) (sub1 j)))))) + (lambda (vec start end) + (loop vec start (sub1 end))))) + + ;;; (VECTOR-REVERSE! [ ]) -> void + ;;; Destructively reverse the contents of the sequence of locations + ;;; in VECTOR between START, whose default is 0, and END, whose + ;;; default is the length of VECTOR. + (define (vector-reverse! vec . maybe-start+end) + (unless (vector? vec) + (apply raise-type-error + 'vector-reverse! "vector" 0 + vec maybe-start+end)) + (apply (opt-lambda (vec (start 0) (end (vector-length vec))) + (check-indices vec start end 'vector-reverse!) + (%vector-reverse! vec start end)) + vec maybe-start+end)) + + ;;; (VECTOR-COPY! [ ]) + ;;; -> unspecified + ;;; Copy the values in the locations in [SSTART,SEND) from SOURCE to + ;;; to TARGET, starting at TSTART in TARGET. + (define (vector-copy! target tstart source . maybe-sstart+send) + (unless (vector? target) + (apply raise-type-error + 'vector-copy! "vector" 0 + target tstart source maybe-sstart+send)) + (check-start target tstart 'vector-copy!) + (unless (vector? source) + (apply raise-type-error + 'vector-copy! "vector" 2 + target tstart source maybe-sstart+send)) + (apply (opt-lambda (target + tstart + source + (sstart 0) + (send (vector-length source))) + (check-indices source sstart send 'vector-copy!) + (if (< (- (vector-length target) tstart) + (- send sstart)) + (error 'vector-copy! + "target vector not long enough to copy")) + (%vector-copy! target tstart source sstart send)) + target tstart source maybe-sstart+send)) + + ;;; (VECTOR-REVERSE-COPY! [ ]) + (define (vector-reverse-copy! target tstart source . maybe-sstart+send) + (unless (vector? target) + (apply raise-type-error + 'vector-reverse-copy! "vector" 0 + target tstart source maybe-sstart+send)) + (check-start target tstart 'vector-reverse-copy!) + (unless (vector? source) + (apply raise-type-error + 'vector-reverse-copy! "vector" 2 + target tstart source maybe-sstart+send)) + (apply (opt-lambda (target + tstart + source + (sstart 0) + (send (vector-length source))) + (check-indices source sstart send 'vector-reverse-copy!) + (cond ((< (- (vector-length target) tstart) + (- send sstart)) + (error 'vector-reverse-copy! + "target vector not long enough to copy")) + ((and (eq? target source) + (= sstart tstart)) + (%vector-reverse! target tstart send)) + ((and (eq? target source) + (or (between? sstart tstart send) + (between? tstart sstart + (+ tstart (- send sstart))))) + ;an error in the reference implement here + (error 'vector-reverse-copy! + "Vector range for self-copying overlaps")) + (else + (%vector-reverse-copy! target tstart + source sstart send)))) + target tstart source maybe-sstart+send)) + (define (between? x y z) + (and (< x y) (<= y z)))) \ No newline at end of file diff --git a/collects/srfi/43/predicates.ss b/collects/srfi/43/predicates.ss index d703cae72c..e817ad25c1 100644 --- a/collects/srfi/43/predicates.ss +++ b/collects/srfi/43/predicates.ss @@ -1,103 +1,103 @@ -;;; -;;; ---- Vector predicates -;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> -;;; -;;; Copyright (C) 2005 by Zhu Chongkai. -;;; -;;; This file is part of SRFI-43. - -;;; SRFI-43 is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public -;;; License as published by the Free Software Foundation; either -;;; version 2.1 of the License, or (at your option) any later version. - -;;; SRFI-43 is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. - -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with SRFI-43; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -;;; Author: Zhu Chongkai -;; -;; -;; Commentary: - -;; Based on the reference implementation by Taylor Campbell and hence: - -;;; Copyright (C) 2003, 2004 Taylor Campbell. -;;; All rights reserved. -;;; -;;; You may do as you please with this code, as long as you refrain -;;; from removing this copyright notice or holding me liable in _any_ -;;; circumstances for _any_ damages that may be caused by it; and you -;;; may quote sections from it as you please, as long as you credit me. - -(module predicates mzscheme - - (require "util.ss") - - (provide vector-empty? - vector=) - - ;;; (VECTOR-EMPTY? ) -> boolean - ;;; Return #T if VECTOR has zero elements in it, i.e. VECTOR's length - ;;; is 0, and #F if not. - (define (vector-empty? vec) - (unless (vector? vec) - (raise-type-error 'vector-empty? "vector" vec)) - (zero? (vector-length vec))) - - ;;; (VECTOR= ...) -> boolean - ;;; (ELT=? ) -> boolean - ;;; Determine vector equality generalized across element comparators. - ;;; Vectors A and B are equal iff their lengths are the same and for - ;;; each respective elements E_a and E_b (element=? E_a E_b) returns - ;;; a true value. ELT=? is always applied to two arguments. Element - ;;; comparison must be consistent wtih EQ?; that is, if (eq? E_a E_b) - ;;; results in a true value, then (ELEMENT=? E_a E_b) must result in a - ;;; true value. This may be exploited to avoid multiple unnecessary - ;;; element comparisons. (This implementation does, but does not deal - ;;; with the situation that ELEMENT=? is EQ? to avoid more unnecessary - ;;; comparisons, but I believe this optimization is probably fairly - ;;; insignificant.) - ;;; - ;;; If the number of vector arguments is zero or one, then #T is - ;;; automatically returned. If there are N vector arguments, - ;;; VECTOR_1 VECTOR_2 ... VECTOR_N, then VECTOR_1 & VECTOR_2 are - ;;; compared; if they are equal, the vectors VECTOR_2 ... VECTOR_N - ;;; are compared. The precise order in which ELT=? is applied is not - ;;; specified. - (define (vector= elt=? . vectors) - (unless (procedure-arity-includes? elt=? 2) - (apply raise-type-error - 'vector= "procedure of arity 2" 0 - elt=? vectors)) - (cond ((null? vectors) - #t) - ((null? (cdr vectors)) - (unless (vector? (car vectors)) - (apply raise-type-error - 'vector= "vector" 1 - elt=? vectors)) - #t) - (else - (check-list-of-vecs vectors 'vector= - 1 (cons elt=? vectors)) - (let loop ((vecs vectors)) - (let ((vec1 (car vecs)) - (vec2+ (cdr vecs))) - (or (null? vec2+) - (and (binary-vector= elt=? vec1 (car vec2+)) - (loop vec2+)))))))) - (define (binary-vector= elt=? vector-a vector-b) - (or (eq? vector-a vector-b) ;+++ - (let ((length-a (vector-length vector-a))) - (and (= length-a (vector-length vector-b)) - (let loop ((i 0)) - (or (= i length-a) - (and (elt=? (vector-ref vector-a i) - (vector-ref vector-b i)) +;;; +;;; ---- Vector predicates +;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> +;;; +;;; Copyright (C) 2005 by Zhu Chongkai. +;;; +;;; This file is part of SRFI-43. + +;;; SRFI-43 is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 2.1 of the License, or (at your option) any later version. + +;;; SRFI-43 is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. + +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with SRFI-43; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +;;; Author: Zhu Chongkai +;; +;; +;; Commentary: + +;; Based on the reference implementation by Taylor Campbell and hence: + +;;; Copyright (C) 2003, 2004 Taylor Campbell. +;;; All rights reserved. +;;; +;;; You may do as you please with this code, as long as you refrain +;;; from removing this copyright notice or holding me liable in _any_ +;;; circumstances for _any_ damages that may be caused by it; and you +;;; may quote sections from it as you please, as long as you credit me. + +(module predicates mzscheme + + (require "util.ss") + + (provide vector-empty? + vector=) + + ;;; (VECTOR-EMPTY? ) -> boolean + ;;; Return #T if VECTOR has zero elements in it, i.e. VECTOR's length + ;;; is 0, and #F if not. + (define (vector-empty? vec) + (unless (vector? vec) + (raise-type-error 'vector-empty? "vector" vec)) + (zero? (vector-length vec))) + + ;;; (VECTOR= ...) -> boolean + ;;; (ELT=? ) -> boolean + ;;; Determine vector equality generalized across element comparators. + ;;; Vectors A and B are equal iff their lengths are the same and for + ;;; each respective elements E_a and E_b (element=? E_a E_b) returns + ;;; a true value. ELT=? is always applied to two arguments. Element + ;;; comparison must be consistent wtih EQ?; that is, if (eq? E_a E_b) + ;;; results in a true value, then (ELEMENT=? E_a E_b) must result in a + ;;; true value. This may be exploited to avoid multiple unnecessary + ;;; element comparisons. (This implementation does, but does not deal + ;;; with the situation that ELEMENT=? is EQ? to avoid more unnecessary + ;;; comparisons, but I believe this optimization is probably fairly + ;;; insignificant.) + ;;; + ;;; If the number of vector arguments is zero or one, then #T is + ;;; automatically returned. If there are N vector arguments, + ;;; VECTOR_1 VECTOR_2 ... VECTOR_N, then VECTOR_1 & VECTOR_2 are + ;;; compared; if they are equal, the vectors VECTOR_2 ... VECTOR_N + ;;; are compared. The precise order in which ELT=? is applied is not + ;;; specified. + (define (vector= elt=? . vectors) + (unless (procedure-arity-includes? elt=? 2) + (apply raise-type-error + 'vector= "procedure of arity 2" 0 + elt=? vectors)) + (cond ((null? vectors) + #t) + ((null? (cdr vectors)) + (unless (vector? (car vectors)) + (apply raise-type-error + 'vector= "vector" 1 + elt=? vectors)) + #t) + (else + (check-list-of-vecs vectors 'vector= + 1 (cons elt=? vectors)) + (let loop ((vecs vectors)) + (let ((vec1 (car vecs)) + (vec2+ (cdr vecs))) + (or (null? vec2+) + (and (binary-vector= elt=? vec1 (car vec2+)) + (loop vec2+)))))))) + (define (binary-vector= elt=? vector-a vector-b) + (or (eq? vector-a vector-b) ;+++ + (let ((length-a (vector-length vector-a))) + (and (= length-a (vector-length vector-b)) + (let loop ((i 0)) + (or (= i length-a) + (and (elt=? (vector-ref vector-a i) + (vector-ref vector-b i)) (loop (add1 i)))))))))) \ No newline at end of file diff --git a/collects/srfi/43/searching.ss b/collects/srfi/43/searching.ss index 702c4b07ca..96e566c168 100644 --- a/collects/srfi/43/searching.ss +++ b/collects/srfi/43/searching.ss @@ -1,298 +1,298 @@ -;;; -;;; ---- Vector searching -;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> -;;; -;;; Copyright (C) 2005 by Zhu Chongkai. -;;; -;;; This file is part of SRFI-43. - -;;; SRFI-43 is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public -;;; License as published by the Free Software Foundation; either -;;; version 2.1 of the License, or (at your option) any later version. - -;;; SRFI-43 is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. - -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with SRFI-43; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -;;; Author: Zhu Chongkai -;; -;; -;; Commentary: - -;; Based on the reference implementation by Taylor Campbell and hence: - -;;; Copyright (C) 2003, 2004 Taylor Campbell. -;;; All rights reserved. -;;; -;;; You may do as you please with this code, as long as you refrain -;;; from removing this copyright notice or holding me liable in _any_ -;;; circumstances for _any_ damages that may be caused by it; and you -;;; may quote sections from it as you please, as long as you credit me. - -(module searching mzscheme - - (require "util.ss") - - (provide vector-index - vector-index-right - vector-skip - vector-skip-right - vector-binary-search - vector-any - vector-every) - - ;; All the functions (except vector-binary-search) here can be - ;; abstracted, but for performance I didn't do so. - - ;;; (VECTOR-INDEX ...) - ;;; -> exact, nonnegative integer or #F - ;;; (PREDICATE? ...) -> boolean ; N vectors -> N args - ;;; Search left-to-right across VECTOR ... in parallel, returning the - ;;; index of the first set of values VALUE ... such that (PREDICATE? - ;;; VALUE ...) returns a true value; if no such set of elements is - ;;; reached, return #F. - (define vector-index - (letrec ((loop1 (lambda (pred? vec len i) - (cond ((= i len) #f) - ((pred? (vector-ref vec i)) i) - (else (loop1 pred? vec len (add1 i)))))) - (loop2+ (lambda (pred? vectors len i) - (cond ((= i len) #f) - ((apply pred? (vectors-ref vectors i)) i) - (else (loop2+ pred? vectors len (add1 i))))))) - (lambda (pred? vec . vectors) - (unless (procedure? pred?) - (apply raise-type-error - 'vector-index "procedure" 0 - pred? vec vectors)) - (unless (vector? vec) - (apply raise-type-error - 'vector-index "vector" 1 - pred? vec vectors)) - (if (null? vectors) - (loop1 pred? vec (vector-length vec) 0) - (begin (check-list-of-vecs vectors 'vector-index 2 - (list* pred? vec vectors)) - (loop2+ pred? (cons vec vectors) - (%smallest-length vectors - (vector-length vec)) - 0)))))) - - ;;; (VECTOR-SKIP ...) - ;;; -> exact, nonnegative integer or #F - ;;; (PREDICATE? ...) -> boolean ; N vectors -> N args - ;;; (vector-index (lambda elts (not (apply PREDICATE? elts))) - ;;; VECTOR ...) - ;;; Like VECTOR-INDEX, but find the index of the first set of values - ;;; that do _not_ satisfy PREDICATE?. - (define vector-skip - (letrec ((loop1 (lambda (pred? vec len i) - (cond ((= i len) #f) - ((pred? (vector-ref vec i)) - (loop1 pred? vec len (add1 i))) - (else i)))) - (loop2+ (lambda (pred? vectors len i) - (cond ((= i len) #f) - ((apply pred? (vectors-ref vectors i)) - (loop2+ pred? vectors len (add1 i))) - (else i))))) - (lambda (pred? vec . vectors) - (unless (procedure? pred?) - (apply raise-type-error - 'vector-skip "procedure" 0 - pred? vec vectors)) - (unless (vector? vec) - (apply raise-type-error - 'vector-skip "vector" 1 - pred? vec vectors)) - (if (null? vectors) - (loop1 pred? vec (vector-length vec) 0) - (begin (check-list-of-vecs vectors 'vector-skip 2 - (list* pred? vec vectors)) - (loop2+ pred? (cons vec vectors) - (%smallest-length vectors - (vector-length vec)) - 0)))))) - - ;;; (VECTOR-INDEX-RIGHT ...) - ;;; -> exact, nonnegative integer or #F - ;;; (PREDICATE? ...) -> boolean ; N vectors -> N args - ;;; Right-to-left variant of VECTOR-INDEX. - (define vector-index-right - (letrec ((loop1 (lambda (pred? vec i) - (if (zero? i) - #f - (let ((i (sub1 i))) - (if (pred? (vector-ref vec i)) - i - (loop1 pred? vec i)))))) - (loop2+ (lambda (pred? vectors i) - (if (zero? i) - #f - (let ((i (sub1 i))) - (if (apply pred? (vectors-ref vectors i)) - i - (loop2+ pred? vectors i))))))) - (lambda (pred? vec . vectors) - (unless (procedure? pred?) - (apply raise-type-error - 'vector-index-right "procedure" 0 - pred? vec vectors)) - (unless (vector? vec) - (apply raise-type-error - 'vector-index-right "vector" 1 - pred? vec vectors)) - (if (null? vectors) - (loop1 pred? vec (vector-length vec)) - (begin (check-list-of-vecs vectors 'vector-index-right 2 - (list* pred? vec vectors)) - (loop2+ pred? (cons vec vectors) - (%smallest-length vectors - (vector-length vec)))))))) - - ;;; (VECTOR-SKIP-RIGHT ...) - ;;; -> exact, nonnegative integer or #F - ;;; (PREDICATE? ...) -> boolean ; N vectors -> N args - ;;; Right-to-left variant of VECTOR-SKIP. - (define vector-skip-right - (letrec ((loop1 (lambda (pred? vec i) - (if (zero? i) - #f - (let ((i (sub1 i))) - (if (pred? (vector-ref vec i)) - (loop1 pred? vec i) - i))))) - (loop2+ (lambda (pred? vectors i) - (if (zero? i) - #f - (let ((i (sub1 i))) - (if (apply pred? (vectors-ref vectors i)) - (loop2+ pred? vectors i) - i)))))) - (lambda (pred? vec . vectors) - (unless (procedure? pred?) - (apply raise-type-error - 'vector-skip-right "procedure" 0 - pred? vec vectors)) - (unless (vector? vec) - (apply raise-type-error - 'vector-skip-right "vector" 1 - pred? vec vectors)) - (if (null? vectors) - (loop1 pred? vec (vector-length vec)) - (begin (check-list-of-vecs vectors 'vector-skip-right 2 - (list* pred? vec vectors)) - (loop2+ pred? (cons vec vectors) - (%smallest-length vectors - (vector-length vec)))))))) - - ;;; (VECTOR-BINARY-SEARCH ) - ;;; -> exact, nonnegative integer or #F - ;;; (CMP ) -> integer - ;;; positive -> VALUE1 > VALUE2 - ;;; zero -> VALUE1 = VALUE2 - ;;; negative -> VALUE1 < VALUE2 - ;;; Perform a binary search through VECTOR for VALUE, comparing each - ;;; element to VALUE with CMP. - (define (vector-binary-search vec value cmp) - (unless (vector? vec) - (raise-type-error 'vector-binary-search "vector" 0 - vec value cmp)) - (unless (procedure-arity-includes? cmp 2) - (raise-type-error 'vector-binary-search "procedure of arity 2" 2 - vec value cmp)) - (let loop ((start 0) - (end (vector-length vec)) - (j -1)) - (let ((i (quotient (+ start end) 2))) - (if (= i j) - #f - (let ((comparison (cmp (vector-ref vec i) value))) - (unless (integer? comparison) - (raise-type-error 'vector-binary-search - "procedure that returns an integer" - 2 - vec value cmp)) - (cond ((zero? comparison) i) - ((positive? comparison) (loop start i i)) - (else (loop i end i)))))))) - - ;;; (VECTOR-ANY ...) -> value - ;;; Apply PRED? to each parallel element in each VECTOR ...; if PRED? - ;;; should ever return a true value, immediately stop and return that - ;;; value; otherwise, when the shortest vector runs out, return #F. - ;;; The iteration and order of application of PRED? across elements - ;;; is of the vectors is strictly left-to-right. - (define vector-any - (letrec ((loop1 (lambda (pred? vec i len) - (and (not (= i len)) - (or (pred? (vector-ref vec i)) - (loop1 pred? vec (add1 i) len))))) - (loop2+ (lambda (pred? vectors i len) - (and (not (= i len)) - (or (apply pred? (vectors-ref vectors i)) - (loop2+ pred? vectors (add1 i) len)))))) - (lambda (pred? vec . vectors) - (unless (procedure? pred?) - (apply raise-type-error - 'vector-any "procedure" 0 - pred? vec vectors)) - (unless (vector? vec) - (apply raise-type-error - 'vector-any "vector" 1 - pred? vec vectors)) - (if (null? vectors) - (loop1 pred? vec 0 (vector-length vec)) - (begin (check-list-of-vecs vectors 'vector-any 2 - (list* pred? vec vectors)) - (loop2+ pred? (cons vec vectors) - 0 (%smallest-length vectors - (vector-length vec)))))))) - - ;;; (VECTOR-EVERY ...) -> value - ;;; Apply PRED? to each parallel value in each VECTOR ...; if PRED? - ;;; should ever return #F, immediately stop and return #F; otherwise, - ;;; if PRED? should return a true value for each element, stopping at - ;;; the end of the shortest vector, return the last value that PRED? - ;;; returned. In the case that there is an empty vector, return #T. - ;;; The iteration and order of application of PRED? across elements - ;;; is of the vectors is strictly left-to-right. - (define vector-every - (letrec ((loop1 (lambda (pred? vec i len) - (or (> i len) - (if (= i len) - (pred? (vector-ref vec i)) - (and (pred? (vector-ref vec i)) - (loop1 pred? vec (add1 i) len)))))) - (loop2+ (lambda (pred? vectors i len) - (or (> i len) - (if (= i len) - (apply pred? (vectors-ref vectors i)) - (and (apply pred? (vectors-ref vectors i)) - (loop2+ pred? vectors (add1 i) len))))))) - (lambda (pred? vec . vectors) - (unless (procedure? pred?) - (apply raise-type-error - 'vector-every "procedure" 0 - pred? vec vectors)) - (unless (vector? vec) - (apply raise-type-error - 'vector-every "vector" 1 - pred? vec vectors)) - (if (null? vectors) - (loop1 pred? vec 0 (sub1 (vector-length vec))) - (begin (check-list-of-vecs vectors 'vector-every 2 - (list* pred? vec vectors)) - (loop2+ pred? - (cons vec vectors) - 0 - (sub1 - (%smallest-length vectors - (vector-length vec)))))))))) - +;;; +;;; ---- Vector searching +;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> +;;; +;;; Copyright (C) 2005 by Zhu Chongkai. +;;; +;;; This file is part of SRFI-43. + +;;; SRFI-43 is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 2.1 of the License, or (at your option) any later version. + +;;; SRFI-43 is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. + +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with SRFI-43; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +;;; Author: Zhu Chongkai +;; +;; +;; Commentary: + +;; Based on the reference implementation by Taylor Campbell and hence: + +;;; Copyright (C) 2003, 2004 Taylor Campbell. +;;; All rights reserved. +;;; +;;; You may do as you please with this code, as long as you refrain +;;; from removing this copyright notice or holding me liable in _any_ +;;; circumstances for _any_ damages that may be caused by it; and you +;;; may quote sections from it as you please, as long as you credit me. + +(module searching mzscheme + + (require "util.ss") + + (provide vector-index + vector-index-right + vector-skip + vector-skip-right + vector-binary-search + vector-any + vector-every) + + ;; All the functions (except vector-binary-search) here can be + ;; abstracted, but for performance I didn't do so. + + ;;; (VECTOR-INDEX ...) + ;;; -> exact, nonnegative integer or #F + ;;; (PREDICATE? ...) -> boolean ; N vectors -> N args + ;;; Search left-to-right across VECTOR ... in parallel, returning the + ;;; index of the first set of values VALUE ... such that (PREDICATE? + ;;; VALUE ...) returns a true value; if no such set of elements is + ;;; reached, return #F. + (define vector-index + (letrec ((loop1 (lambda (pred? vec len i) + (cond ((= i len) #f) + ((pred? (vector-ref vec i)) i) + (else (loop1 pred? vec len (add1 i)))))) + (loop2+ (lambda (pred? vectors len i) + (cond ((= i len) #f) + ((apply pred? (vectors-ref vectors i)) i) + (else (loop2+ pred? vectors len (add1 i))))))) + (lambda (pred? vec . vectors) + (unless (procedure? pred?) + (apply raise-type-error + 'vector-index "procedure" 0 + pred? vec vectors)) + (unless (vector? vec) + (apply raise-type-error + 'vector-index "vector" 1 + pred? vec vectors)) + (if (null? vectors) + (loop1 pred? vec (vector-length vec) 0) + (begin (check-list-of-vecs vectors 'vector-index 2 + (list* pred? vec vectors)) + (loop2+ pred? (cons vec vectors) + (%smallest-length vectors + (vector-length vec)) + 0)))))) + + ;;; (VECTOR-SKIP ...) + ;;; -> exact, nonnegative integer or #F + ;;; (PREDICATE? ...) -> boolean ; N vectors -> N args + ;;; (vector-index (lambda elts (not (apply PREDICATE? elts))) + ;;; VECTOR ...) + ;;; Like VECTOR-INDEX, but find the index of the first set of values + ;;; that do _not_ satisfy PREDICATE?. + (define vector-skip + (letrec ((loop1 (lambda (pred? vec len i) + (cond ((= i len) #f) + ((pred? (vector-ref vec i)) + (loop1 pred? vec len (add1 i))) + (else i)))) + (loop2+ (lambda (pred? vectors len i) + (cond ((= i len) #f) + ((apply pred? (vectors-ref vectors i)) + (loop2+ pred? vectors len (add1 i))) + (else i))))) + (lambda (pred? vec . vectors) + (unless (procedure? pred?) + (apply raise-type-error + 'vector-skip "procedure" 0 + pred? vec vectors)) + (unless (vector? vec) + (apply raise-type-error + 'vector-skip "vector" 1 + pred? vec vectors)) + (if (null? vectors) + (loop1 pred? vec (vector-length vec) 0) + (begin (check-list-of-vecs vectors 'vector-skip 2 + (list* pred? vec vectors)) + (loop2+ pred? (cons vec vectors) + (%smallest-length vectors + (vector-length vec)) + 0)))))) + + ;;; (VECTOR-INDEX-RIGHT ...) + ;;; -> exact, nonnegative integer or #F + ;;; (PREDICATE? ...) -> boolean ; N vectors -> N args + ;;; Right-to-left variant of VECTOR-INDEX. + (define vector-index-right + (letrec ((loop1 (lambda (pred? vec i) + (if (zero? i) + #f + (let ((i (sub1 i))) + (if (pred? (vector-ref vec i)) + i + (loop1 pred? vec i)))))) + (loop2+ (lambda (pred? vectors i) + (if (zero? i) + #f + (let ((i (sub1 i))) + (if (apply pred? (vectors-ref vectors i)) + i + (loop2+ pred? vectors i))))))) + (lambda (pred? vec . vectors) + (unless (procedure? pred?) + (apply raise-type-error + 'vector-index-right "procedure" 0 + pred? vec vectors)) + (unless (vector? vec) + (apply raise-type-error + 'vector-index-right "vector" 1 + pred? vec vectors)) + (if (null? vectors) + (loop1 pred? vec (vector-length vec)) + (begin (check-list-of-vecs vectors 'vector-index-right 2 + (list* pred? vec vectors)) + (loop2+ pred? (cons vec vectors) + (%smallest-length vectors + (vector-length vec)))))))) + + ;;; (VECTOR-SKIP-RIGHT ...) + ;;; -> exact, nonnegative integer or #F + ;;; (PREDICATE? ...) -> boolean ; N vectors -> N args + ;;; Right-to-left variant of VECTOR-SKIP. + (define vector-skip-right + (letrec ((loop1 (lambda (pred? vec i) + (if (zero? i) + #f + (let ((i (sub1 i))) + (if (pred? (vector-ref vec i)) + (loop1 pred? vec i) + i))))) + (loop2+ (lambda (pred? vectors i) + (if (zero? i) + #f + (let ((i (sub1 i))) + (if (apply pred? (vectors-ref vectors i)) + (loop2+ pred? vectors i) + i)))))) + (lambda (pred? vec . vectors) + (unless (procedure? pred?) + (apply raise-type-error + 'vector-skip-right "procedure" 0 + pred? vec vectors)) + (unless (vector? vec) + (apply raise-type-error + 'vector-skip-right "vector" 1 + pred? vec vectors)) + (if (null? vectors) + (loop1 pred? vec (vector-length vec)) + (begin (check-list-of-vecs vectors 'vector-skip-right 2 + (list* pred? vec vectors)) + (loop2+ pred? (cons vec vectors) + (%smallest-length vectors + (vector-length vec)))))))) + + ;;; (VECTOR-BINARY-SEARCH ) + ;;; -> exact, nonnegative integer or #F + ;;; (CMP ) -> integer + ;;; positive -> VALUE1 > VALUE2 + ;;; zero -> VALUE1 = VALUE2 + ;;; negative -> VALUE1 < VALUE2 + ;;; Perform a binary search through VECTOR for VALUE, comparing each + ;;; element to VALUE with CMP. + (define (vector-binary-search vec value cmp) + (unless (vector? vec) + (raise-type-error 'vector-binary-search "vector" 0 + vec value cmp)) + (unless (procedure-arity-includes? cmp 2) + (raise-type-error 'vector-binary-search "procedure of arity 2" 2 + vec value cmp)) + (let loop ((start 0) + (end (vector-length vec)) + (j -1)) + (let ((i (quotient (+ start end) 2))) + (if (= i j) + #f + (let ((comparison (cmp (vector-ref vec i) value))) + (unless (integer? comparison) + (raise-type-error 'vector-binary-search + "procedure that returns an integer" + 2 + vec value cmp)) + (cond ((zero? comparison) i) + ((positive? comparison) (loop start i i)) + (else (loop i end i)))))))) + + ;;; (VECTOR-ANY ...) -> value + ;;; Apply PRED? to each parallel element in each VECTOR ...; if PRED? + ;;; should ever return a true value, immediately stop and return that + ;;; value; otherwise, when the shortest vector runs out, return #F. + ;;; The iteration and order of application of PRED? across elements + ;;; is of the vectors is strictly left-to-right. + (define vector-any + (letrec ((loop1 (lambda (pred? vec i len) + (and (not (= i len)) + (or (pred? (vector-ref vec i)) + (loop1 pred? vec (add1 i) len))))) + (loop2+ (lambda (pred? vectors i len) + (and (not (= i len)) + (or (apply pred? (vectors-ref vectors i)) + (loop2+ pred? vectors (add1 i) len)))))) + (lambda (pred? vec . vectors) + (unless (procedure? pred?) + (apply raise-type-error + 'vector-any "procedure" 0 + pred? vec vectors)) + (unless (vector? vec) + (apply raise-type-error + 'vector-any "vector" 1 + pred? vec vectors)) + (if (null? vectors) + (loop1 pred? vec 0 (vector-length vec)) + (begin (check-list-of-vecs vectors 'vector-any 2 + (list* pred? vec vectors)) + (loop2+ pred? (cons vec vectors) + 0 (%smallest-length vectors + (vector-length vec)))))))) + + ;;; (VECTOR-EVERY ...) -> value + ;;; Apply PRED? to each parallel value in each VECTOR ...; if PRED? + ;;; should ever return #F, immediately stop and return #F; otherwise, + ;;; if PRED? should return a true value for each element, stopping at + ;;; the end of the shortest vector, return the last value that PRED? + ;;; returned. In the case that there is an empty vector, return #T. + ;;; The iteration and order of application of PRED? across elements + ;;; is of the vectors is strictly left-to-right. + (define vector-every + (letrec ((loop1 (lambda (pred? vec i len) + (or (> i len) + (if (= i len) + (pred? (vector-ref vec i)) + (and (pred? (vector-ref vec i)) + (loop1 pred? vec (add1 i) len)))))) + (loop2+ (lambda (pred? vectors i len) + (or (> i len) + (if (= i len) + (apply pred? (vectors-ref vectors i)) + (and (apply pred? (vectors-ref vectors i)) + (loop2+ pred? vectors (add1 i) len))))))) + (lambda (pred? vec . vectors) + (unless (procedure? pred?) + (apply raise-type-error + 'vector-every "procedure" 0 + pred? vec vectors)) + (unless (vector? vec) + (apply raise-type-error + 'vector-every "vector" 1 + pred? vec vectors)) + (if (null? vectors) + (loop1 pred? vec 0 (sub1 (vector-length vec))) + (begin (check-list-of-vecs vectors 'vector-every 2 + (list* pred? vec vectors)) + (loop2+ pred? + (cons vec vectors) + 0 + (sub1 + (%smallest-length vectors + (vector-length vec)))))))))) + diff --git a/collects/srfi/43/util.ss b/collects/srfi/43/util.ss index 7d083b451b..2b9da90083 100644 --- a/collects/srfi/43/util.ss +++ b/collects/srfi/43/util.ss @@ -1,162 +1,162 @@ -;;; -;;; ---- Utility functions -;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> -;;; -;;; Copyright (C) 2005 by Zhu Chongkai. -;;; -;;; This file is part of SRFI-43. - -;;; SRFI-43 is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public -;;; License as published by the Free Software Foundation; either -;;; version 2.1 of the License, or (at your option) any later version. - -;;; SRFI-43 is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. - -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with SRFI-43; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -;;; Author: Zhu Chongkai -;; -;; -;; Commentary: - -;; Based on the reference implementation by Taylor Campbell and hence: - -;;; Copyright (C) 2003, 2004 Taylor Campbell. -;;; All rights reserved. -;;; -;;; You may do as you please with this code, as long as you refrain -;;; from removing this copyright notice or holding me liable in _any_ -;;; circumstances for _any_ damages that may be caused by it; and you -;;; may quote sections from it as you please, as long as you credit me. - -(module util mzscheme - - (require (lib "etc.ss" "mzlib") - (lib "receive.ss" "srfi" "8")) - - (provide (all-defined)) - - ;;; (CHECK-INDEX ) -> - ;;; Ensure that INDEX is a valid index into VECTOR; if not, signal an - ;;; error stating that it is not and that this happened in a call to - ;;; CALLEE. (Note that this does NOT check that VECTOR is indeed a - ;;; vector.) - (define (check-index vec index callee) - (unless (nonneg-int? index) - (raise-type-error callee "non-negative exact integer" index)) - (unless (and (<= 0 index) - (< index (vector-length vec))) - (raise - (make-exn:fail:contract - (string->immutable-string - (format "~a: index ~a out of range for vector: ~a" - callee index vec)) - (current-continuation-marks))))) - - - ;;; (CHECK-START ) -> - ;;; Ensure that INDEX is a valid bound of VECTOR; if not, signal an - ;;; error stating that it is not and that this happened in a call to - ;;; CALLEE. (Note that this does NOT check that VECTOR is indeed a - ;;; vector.) - (define (check-start vec index callee) - (unless (nonneg-int? index) - (raise-type-error callee "non-negative exact integer" index)) - (unless (<= 0 index (vector-length vec)) - (raise - (make-exn:fail:contract - (string->immutable-string - (format "~a: index ~a out of range for vector: ~a" - callee index vec)) - (current-continuation-marks))))) - - ;;; (CHECK-INDICES ) -> - ;;; Ensure that START and END are valid bounds of a range within - ;;; VECTOR; if not, signal an error stating that they are not - ;;; while calling CALLEE. - (define (check-indices vec start end callee) - (unless (nonneg-int? start) - (raise-type-error callee "non-negative exact integer" start)) - (unless (nonneg-int? end) - (raise-type-error callee "non-negative exact integer" end)) - (unless (<= 0 start end (vector-length vec)) - (raise - (make-exn:fail:contract - (string->immutable-string - (format "~a: indices (~a, ~a) out of range for vector: ~a" - callee start end vec)) - (current-continuation-marks))))) - - (define (nonneg-int? x) - (and (integer? x) - (exact? x) - (not (negative? x)))) - - ;;; (%VECTOR-COPY! ) - ;;; Copy elements at locations SSTART to SEND from SOURCE to TARGET, - ;;; starting at TSTART in TARGET. - (define (%vector-copy! target tstart source sstart send) - (let loop ((i sstart) - (j tstart)) - (cond ((< i send) - (vector-set! target j - (vector-ref source i)) - (loop (add1 i) (add1 j)))))) - - ;;; (%VECTOR-REVERSE-COPY! ) - ;;; Copy elements from SSTART to SEND from SOURCE to TARGET, in the - ;;; reverse order. - (define %vector-reverse-copy! - (letrec ((loop (lambda (target source sstart i j) - (cond ((>= i sstart) - (vector-set! target j (vector-ref source i)) - (loop target source sstart - (sub1 i) - (add1 j))))))) - (lambda (target tstart source sstart send) - (loop target source sstart - (sub1 send) - tstart)))) - - ;; type-check : check whether list-of-vecs is list of VECTORs - (define check-list-of-vecs - (opt-lambda (list-of-vecs caller (n 0) (all-args list-of-vecs)) - (let loop ((l list-of-vecs) - (i 0)) - (unless (null? l) - (if (vector? (car l)) - (loop (cdr l) (add1 i)) - (apply raise-type-error - caller "vector" - (+ n i) - all-args)))))) - - ;;; (%SMALLEST-LENGTH ) - ;;; -> exact, nonnegative integer - ;;; Compute the smallest length of VECTOR-LIST. DEFAULT-LENGTH is - ;;; the length that is returned if VECTOR-LIST is empty. Common use - ;;; of this is in n-ary vector routines: - ;;; (define (f vec . vectors) - (define (%smallest-length vector-list length) - (if (null? vector-list) - length - (%smallest-length (cdr vector-list) - (min length - (vector-length (car vector-list)))))) - - (define (vectors-ref vectors i) - (map (lambda (v) (vector-ref v i)) vectors)) - - ;;; from vector-unfold-right - (define (unfold1! f vec i seed) - (if (>= i 0) - (receive (elt new-seed) - (f i seed) - (vector-set! vec i elt) +;;; +;;; ---- Utility functions +;;; Time-stamp: <05/03/07 18:19:59 Zhu Chongkai> +;;; +;;; Copyright (C) 2005 by Zhu Chongkai. +;;; +;;; This file is part of SRFI-43. + +;;; SRFI-43 is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 2.1 of the License, or (at your option) any later version. + +;;; SRFI-43 is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. + +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with SRFI-43; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +;;; Author: Zhu Chongkai +;; +;; +;; Commentary: + +;; Based on the reference implementation by Taylor Campbell and hence: + +;;; Copyright (C) 2003, 2004 Taylor Campbell. +;;; All rights reserved. +;;; +;;; You may do as you please with this code, as long as you refrain +;;; from removing this copyright notice or holding me liable in _any_ +;;; circumstances for _any_ damages that may be caused by it; and you +;;; may quote sections from it as you please, as long as you credit me. + +(module util mzscheme + + (require (lib "etc.ss" "mzlib") + (lib "receive.ss" "srfi" "8")) + + (provide (all-defined)) + + ;;; (CHECK-INDEX ) -> + ;;; Ensure that INDEX is a valid index into VECTOR; if not, signal an + ;;; error stating that it is not and that this happened in a call to + ;;; CALLEE. (Note that this does NOT check that VECTOR is indeed a + ;;; vector.) + (define (check-index vec index callee) + (unless (nonneg-int? index) + (raise-type-error callee "non-negative exact integer" index)) + (unless (and (<= 0 index) + (< index (vector-length vec))) + (raise + (make-exn:fail:contract + (string->immutable-string + (format "~a: index ~a out of range for vector: ~a" + callee index vec)) + (current-continuation-marks))))) + + + ;;; (CHECK-START ) -> + ;;; Ensure that INDEX is a valid bound of VECTOR; if not, signal an + ;;; error stating that it is not and that this happened in a call to + ;;; CALLEE. (Note that this does NOT check that VECTOR is indeed a + ;;; vector.) + (define (check-start vec index callee) + (unless (nonneg-int? index) + (raise-type-error callee "non-negative exact integer" index)) + (unless (<= 0 index (vector-length vec)) + (raise + (make-exn:fail:contract + (string->immutable-string + (format "~a: index ~a out of range for vector: ~a" + callee index vec)) + (current-continuation-marks))))) + + ;;; (CHECK-INDICES ) -> + ;;; Ensure that START and END are valid bounds of a range within + ;;; VECTOR; if not, signal an error stating that they are not + ;;; while calling CALLEE. + (define (check-indices vec start end callee) + (unless (nonneg-int? start) + (raise-type-error callee "non-negative exact integer" start)) + (unless (nonneg-int? end) + (raise-type-error callee "non-negative exact integer" end)) + (unless (<= 0 start end (vector-length vec)) + (raise + (make-exn:fail:contract + (string->immutable-string + (format "~a: indices (~a, ~a) out of range for vector: ~a" + callee start end vec)) + (current-continuation-marks))))) + + (define (nonneg-int? x) + (and (integer? x) + (exact? x) + (not (negative? x)))) + + ;;; (%VECTOR-COPY! ) + ;;; Copy elements at locations SSTART to SEND from SOURCE to TARGET, + ;;; starting at TSTART in TARGET. + (define (%vector-copy! target tstart source sstart send) + (let loop ((i sstart) + (j tstart)) + (cond ((< i send) + (vector-set! target j + (vector-ref source i)) + (loop (add1 i) (add1 j)))))) + + ;;; (%VECTOR-REVERSE-COPY! ) + ;;; Copy elements from SSTART to SEND from SOURCE to TARGET, in the + ;;; reverse order. + (define %vector-reverse-copy! + (letrec ((loop (lambda (target source sstart i j) + (cond ((>= i sstart) + (vector-set! target j (vector-ref source i)) + (loop target source sstart + (sub1 i) + (add1 j))))))) + (lambda (target tstart source sstart send) + (loop target source sstart + (sub1 send) + tstart)))) + + ;; type-check : check whether list-of-vecs is list of VECTORs + (define check-list-of-vecs + (opt-lambda (list-of-vecs caller (n 0) (all-args list-of-vecs)) + (let loop ((l list-of-vecs) + (i 0)) + (unless (null? l) + (if (vector? (car l)) + (loop (cdr l) (add1 i)) + (apply raise-type-error + caller "vector" + (+ n i) + all-args)))))) + + ;;; (%SMALLEST-LENGTH ) + ;;; -> exact, nonnegative integer + ;;; Compute the smallest length of VECTOR-LIST. DEFAULT-LENGTH is + ;;; the length that is returned if VECTOR-LIST is empty. Common use + ;;; of this is in n-ary vector routines: + ;;; (define (f vec . vectors) + (define (%smallest-length vector-list length) + (if (null? vector-list) + length + (%smallest-length (cdr vector-list) + (min length + (vector-length (car vector-list)))))) + + (define (vectors-ref vectors i) + (map (lambda (v) (vector-ref v i)) vectors)) + + ;;; from vector-unfold-right + (define (unfold1! f vec i seed) + (if (>= i 0) + (receive (elt new-seed) + (f i seed) + (vector-set! vec i elt) (unfold1! f vec (sub1 i) new-seed))))) \ No newline at end of file diff --git a/collects/srfi/43/vector-lib.ss b/collects/srfi/43/vector-lib.ss index 09dd42e43a..eaa491a5ad 100644 --- a/collects/srfi/43/vector-lib.ss +++ b/collects/srfi/43/vector-lib.ss @@ -1,43 +1,43 @@ -;;; -;;; ---- Utility functions -;;; Time-stamp: <05/03/07 18:21:41 Zhu Chongkai> -;;; -;;; Copyright (C) 2005 by Zhu Chongkai. -;;; -;;; This file is part of SRFI-43. - -;;; SRFI-43 is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public -;;; License as published by the Free Software Foundation; either -;;; version 2.1 of the License, or (at your option) any later version. - -;;; SRFI-43 is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. - -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with SRFI-43; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -;;; Author: Zhu Chongkai -;; - -(module vector-lib mzscheme - - (require "constructors.ss" - "predicates.ss" - "iteration.ss" - "searching.ss" - (all-except "mutators.ss" vector-fill!) - (rename "mutators.ss" s:vector-fill! vector-fill!) - (all-except "conversion.ss" vector->list) - (rename "conversion.ss" s:vector->list vector->list)) - - (provide - (all-from "constructors.ss") - (all-from "predicates.ss") - (all-from "iteration.ss") - (all-from "searching.ss") - (all-from "mutators.ss") - (all-from "conversion.ss"))) +;;; +;;; ---- Utility functions +;;; Time-stamp: <05/03/07 18:21:41 Zhu Chongkai> +;;; +;;; Copyright (C) 2005 by Zhu Chongkai. +;;; +;;; This file is part of SRFI-43. + +;;; SRFI-43 is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 2.1 of the License, or (at your option) any later version. + +;;; SRFI-43 is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. + +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with SRFI-43; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +;;; Author: Zhu Chongkai +;; + +(module vector-lib mzscheme + + (require "constructors.ss" + "predicates.ss" + "iteration.ss" + "searching.ss" + (all-except "mutators.ss" vector-fill!) + (rename "mutators.ss" s:vector-fill! vector-fill!) + (all-except "conversion.ss" vector->list) + (rename "conversion.ss" s:vector->list vector->list)) + + (provide + (all-from "constructors.ss") + (all-from "predicates.ss") + (all-from "iteration.ss") + (all-from "searching.ss") + (all-from "mutators.ss") + (all-from "conversion.ss"))) diff --git a/src/worksp/README b/src/worksp/README index 2e8243255e..d58910a384 100644 --- a/src/worksp/README +++ b/src/worksp/README @@ -1,166 +1,166 @@ -This directory contains - - - solution files and project files for building MzScheme and - MrEd with Microsoft Visual Studio (which work with the .NET - and Express 2005 versions of Visual Studio); - - - mzconfig.h which is a manual version of information that is - gathered automatically when using the "configure" script. - -If you have downloaded MzCOM, the directory also contains Visual -Studio files for MzCOM. - -Visual Studio Express is available for free from Microsoft, and it is -the recommended compiler for building PLT Scheme. - -MzScheme (but not MzCOM or MrEd) also compiles with Cygwin gcc (a -free compiler from GNU and Cygnus Solutions); to compile with gcc, -follow the instructions in plt\src\README (there is a short -Windows-specific section in that file). - - -As always, please report bugs via one of the following: - - Help Desk's "submit bug report" link (preferred) - - http://bugs.plt-scheme.org/ - - bugs@plt-scheme.org (last resort) - --PLT - scheme@plt-scheme.org - ----------------------------------------------------------------------- -Building MzScheme, MzCOM, and MrEd ----------------------------------------------------------------------- - -The source code for MzScheme, MzCOM, and MrEd is split into several -projects that are grouped into a few solutions. To make the `X' -solution with Visual Studio, open the file plt\src\worksp\X\X.sln. -[When you open a solution, the selected configuration will most likely -be "Debug". Consider changing to "Release" before you build to enable -optimization.] - -To build MzScheme, make the MzScheme solution in - plt\src\worksp\mzscheme - makes plt\mzscheme.exe - -To build MzCOM, make the MzCOM solution in - plt\src\worksp\mzcom - makes plt\collects\mzcom\mzcom.exe - -To build MrEd, make the MrEd solution: - plt\src\worksp\mred - makes plt\mred.exe - -The make processes for MzScheme and MzCOM automatically build - libmzgc - makes plt\libmzgcxxxxxxx.dll and - plt\src\worksp\libmzgc\Release\libmzgcxxxxxxx.lib - mzsrc - makes plt\libmzschxxxxxxx.dll and - plt\src\worksp\mzsrc\Release\mzsrcxxxxxxx.lib - -The make process for MrEd automatically builds - libmzgc - as above - libmzsch - as above - libmred - makes plt\libmredxxxxxxx.dll and - plt\src\worksp\libmred\Release\libmredxxxxxxx.lib - pltdgi - makes plt\pltgdi_xxxxxxx.dll - wxutils - makes plt\src\worksp\wxutils\Release\wxutils.lib - wxwin - makes plt\src\worksp\wxwin\Release\wxwin.lib - wxs - makes plt\src\worksp\wxs\Release\wxs.lib - wxme - makes plt\src\worksp\wxme\Release\wxme.lib - jpeg - makes plt\src\worksp\jpeg\Release\jpeg.lib - png - makes plt\src\worksp\jpeg\Release\png.lib - zlib - makes plt\src\worksp\jpeg\Release\zlib.lib - -In addition, building MzScheme executes - plt\src\mzscheme\dynsrc\mkmzdyn.bat -which copies .exp, .obj, and .lib files into plt\lib\, and also copies -uniplt_xxxxxxx.dll to plt\. The DLL is used only under Windows -95/98/Me for Unicode. - -The pltgdi_xxxxxxx.dll is used for smoothed (i.e., anti-aliased) -drawing, but only when gdiplus.dll is available. If pltgdi_xxxxxxx.dll -or gdiplus.dll is not found by MrEd at run-time, smooth drawing is -disabled. - -To complete a build, run the versioning script described in the next -section. - ----------------------------------------------------------------------- -Versioning ----------------------------------------------------------------------- - -The obnoxious "xxxxxxx" in the DLL names is a placeholder for a -version number. Embedding a version number in a DLL name appears to -be the simplest and surest way to avoid version confusion. - -For local testing, you can use the "xxxxxxx" libraries directly. For -any binaries that will be distributed, however, the placeholder should -be replaced with a specific version. - -To replace the "xxxxxxx" with a specific version, run - - mzscheme -mvqL winvers.ss setup - -in a shell. The "winvers.ss" program will have to make a temporary -copy of mzscheme.exe, libmzschxxxxxxx.dll, and libmzgcxxxxxxx.dll (in -the temporary directory), and it will re-launch MzScheme a couple of -times. The resulting conversions are - plt\mzscheme.exe -> plt\mzscheme.exe (updated) - plt\mred.exe -> plt\mred.exe (updated) - plt\mzcom.exe -> plt\mzcom.exe (updated) - plt\libmzgcxxxxxxx.dll -> plt\libmzgc.dll - plt\libmzschxxxxxxx.dll -> plt\libmzsch.dll - plt\libmredxxxxxxx.dll -> plt\libmred.dll - plt\src\worksp\libmzsch\Release\libmzschxxxxxxx.lib - -> plt\lib\win32\msvc\libmzsch.lib - plt\src\worksp\libmzgc\Release\libmzgcxxxxxxx.lib - -> plt\lib\win32\msvc\libmzgc.lib - plt\pltgdi_xxxxxxx.dll -> plt\pltgdi_.dll - plt\uniplt_xxxxxxx.dll -> plt\uniplt_.dll - ----------------------------------------------------------------------- -Extra stuff for MzScheme and MrEd ----------------------------------------------------------------------- - -If you're building from scratch, you'll also want the starter -programs used by the launcher collection to make drscheme.exe -and mzc.exe: - - mzstart - makes plt\collects\launcher\mzstart.exe - mrstart - makes plt\collects\launcher\mrstart.exe - -Then, set up all the other executables (besides mred.exe -and mzscheme.exe) by running - - mzscheme.exe -mvqM- setup - -(This makes the .zo files, too. To skip compiling .zos, -add -n to the end of the above command.) - ----------------------------------------------------------------------- -Embedding MzScheme ----------------------------------------------------------------------- - -The MzScheme DLLs can be used within an embedding application. - -The libraries - - plt\src\worksp\libmzsch\Release\libmzschxxxxxxx.lib - plt\src\worksp\libmzgc\Release\libmzgcxxxxxxx.lib - -which are created by the mzsrc and gc projects, provide linking -information for using the libmzschxxxxxxx.dll and libmzgcxxxxxxx.dll -DLLs. The versioning script adjusts the names and puts them in - plt\lib\msvc\libmzsch.lib - plt\lib\msvc\libmzgc.lib - -See the "Inside PLT MzScheme" manual for more information about using -these libraries to embed MzScheme in an application. - - -If you need MzScheme to link to a DLL-based C library (instead of -statically linking to the C library within the MzScheme DLL), then: - - 1. Compile MzScheme with the /MD flag. - - 2. Define the pre-processor symbol USE_MSVC_MD_LIBRARY while - compiling the GC with /MD. - - 3. In your embedding application, call GC_pre_init() before calling - any MzScheme and GC function. +This directory contains + + - solution files and project files for building MzScheme and + MrEd with Microsoft Visual Studio (which work with the .NET + and Express 2005 versions of Visual Studio); + + - mzconfig.h which is a manual version of information that is + gathered automatically when using the "configure" script. + +If you have downloaded MzCOM, the directory also contains Visual +Studio files for MzCOM. + +Visual Studio Express is available for free from Microsoft, and it is +the recommended compiler for building PLT Scheme. + +MzScheme (but not MzCOM or MrEd) also compiles with Cygwin gcc (a +free compiler from GNU and Cygnus Solutions); to compile with gcc, +follow the instructions in plt\src\README (there is a short +Windows-specific section in that file). + + +As always, please report bugs via one of the following: + - Help Desk's "submit bug report" link (preferred) + - http://bugs.plt-scheme.org/ + - bugs@plt-scheme.org (last resort) + +-PLT + scheme@plt-scheme.org + +---------------------------------------------------------------------- +Building MzScheme, MzCOM, and MrEd +---------------------------------------------------------------------- + +The source code for MzScheme, MzCOM, and MrEd is split into several +projects that are grouped into a few solutions. To make the `X' +solution with Visual Studio, open the file plt\src\worksp\X\X.sln. +[When you open a solution, the selected configuration will most likely +be "Debug". Consider changing to "Release" before you build to enable +optimization.] + +To build MzScheme, make the MzScheme solution in + plt\src\worksp\mzscheme - makes plt\mzscheme.exe + +To build MzCOM, make the MzCOM solution in + plt\src\worksp\mzcom - makes plt\collects\mzcom\mzcom.exe + +To build MrEd, make the MrEd solution: + plt\src\worksp\mred - makes plt\mred.exe + +The make processes for MzScheme and MzCOM automatically build + libmzgc - makes plt\libmzgcxxxxxxx.dll and + plt\src\worksp\libmzgc\Release\libmzgcxxxxxxx.lib + mzsrc - makes plt\libmzschxxxxxxx.dll and + plt\src\worksp\mzsrc\Release\mzsrcxxxxxxx.lib + +The make process for MrEd automatically builds + libmzgc - as above + libmzsch - as above + libmred - makes plt\libmredxxxxxxx.dll and + plt\src\worksp\libmred\Release\libmredxxxxxxx.lib + pltdgi - makes plt\pltgdi_xxxxxxx.dll + wxutils - makes plt\src\worksp\wxutils\Release\wxutils.lib + wxwin - makes plt\src\worksp\wxwin\Release\wxwin.lib + wxs - makes plt\src\worksp\wxs\Release\wxs.lib + wxme - makes plt\src\worksp\wxme\Release\wxme.lib + jpeg - makes plt\src\worksp\jpeg\Release\jpeg.lib + png - makes plt\src\worksp\jpeg\Release\png.lib + zlib - makes plt\src\worksp\jpeg\Release\zlib.lib + +In addition, building MzScheme executes + plt\src\mzscheme\dynsrc\mkmzdyn.bat +which copies .exp, .obj, and .lib files into plt\lib\, and also copies +uniplt_xxxxxxx.dll to plt\. The DLL is used only under Windows +95/98/Me for Unicode. + +The pltgdi_xxxxxxx.dll is used for smoothed (i.e., anti-aliased) +drawing, but only when gdiplus.dll is available. If pltgdi_xxxxxxx.dll +or gdiplus.dll is not found by MrEd at run-time, smooth drawing is +disabled. + +To complete a build, run the versioning script described in the next +section. + +---------------------------------------------------------------------- +Versioning +---------------------------------------------------------------------- + +The obnoxious "xxxxxxx" in the DLL names is a placeholder for a +version number. Embedding a version number in a DLL name appears to +be the simplest and surest way to avoid version confusion. + +For local testing, you can use the "xxxxxxx" libraries directly. For +any binaries that will be distributed, however, the placeholder should +be replaced with a specific version. + +To replace the "xxxxxxx" with a specific version, run + + mzscheme -mvqL winvers.ss setup + +in a shell. The "winvers.ss" program will have to make a temporary +copy of mzscheme.exe, libmzschxxxxxxx.dll, and libmzgcxxxxxxx.dll (in +the temporary directory), and it will re-launch MzScheme a couple of +times. The resulting conversions are + plt\mzscheme.exe -> plt\mzscheme.exe (updated) + plt\mred.exe -> plt\mred.exe (updated) + plt\mzcom.exe -> plt\mzcom.exe (updated) + plt\libmzgcxxxxxxx.dll -> plt\libmzgc.dll + plt\libmzschxxxxxxx.dll -> plt\libmzsch.dll + plt\libmredxxxxxxx.dll -> plt\libmred.dll + plt\src\worksp\libmzsch\Release\libmzschxxxxxxx.lib + -> plt\lib\win32\msvc\libmzsch.lib + plt\src\worksp\libmzgc\Release\libmzgcxxxxxxx.lib + -> plt\lib\win32\msvc\libmzgc.lib + plt\pltgdi_xxxxxxx.dll -> plt\pltgdi_.dll + plt\uniplt_xxxxxxx.dll -> plt\uniplt_.dll + +---------------------------------------------------------------------- +Extra stuff for MzScheme and MrEd +---------------------------------------------------------------------- + +If you're building from scratch, you'll also want the starter +programs used by the launcher collection to make drscheme.exe +and mzc.exe: + + mzstart - makes plt\collects\launcher\mzstart.exe + mrstart - makes plt\collects\launcher\mrstart.exe + +Then, set up all the other executables (besides mred.exe +and mzscheme.exe) by running + + mzscheme.exe -mvqM- setup + +(This makes the .zo files, too. To skip compiling .zos, +add -n to the end of the above command.) + +---------------------------------------------------------------------- +Embedding MzScheme +---------------------------------------------------------------------- + +The MzScheme DLLs can be used within an embedding application. + +The libraries + + plt\src\worksp\libmzsch\Release\libmzschxxxxxxx.lib + plt\src\worksp\libmzgc\Release\libmzgcxxxxxxx.lib + +which are created by the mzsrc and gc projects, provide linking +information for using the libmzschxxxxxxx.dll and libmzgcxxxxxxx.dll +DLLs. The versioning script adjusts the names and puts them in + plt\lib\msvc\libmzsch.lib + plt\lib\msvc\libmzgc.lib + +See the "Inside PLT MzScheme" manual for more information about using +these libraries to embed MzScheme in an application. + + +If you need MzScheme to link to a DLL-based C library (instead of +statically linking to the C library within the MzScheme DLL), then: + + 1. Compile MzScheme with the /MD flag. + + 2. Define the pre-processor symbol USE_MSVC_MD_LIBRARY while + compiling the GC with /MD. + + 3. In your embedding application, call GC_pre_init() before calling + any MzScheme and GC function. diff --git a/src/worksp/gc2/make.ss b/src/worksp/gc2/make.ss index aed8bdf4e0..4d43cddedb 100644 --- a/src/worksp/gc2/make.ss +++ b/src/worksp/gc2/make.ss @@ -1,446 +1,446 @@ - -(use-compiled-file-paths null) - -(require (lib "restart.ss") - (lib "process.ss")) - -(define (system- s) - (fprintf (current-error-port) "~a~n" s) - (system s)) - -(define accounting-gc? #t) -(define opt-flags "/O2") -(define re:only #f) - -(unless (directory-exists? "xsrc") - (make-directory "xsrc")) - -(define srcs - '("salloc" - "bignum" - "bool" - "builtin" - "char" - "complex" - "dynext" - "env" - "error" - "eval" - "file" - "fun" - "hash" - "image" - "list" - "module" - "network" - "numarith" - "number" - "numcomp" - "numstr" - "port" - "portfun" - "print" - "rational" - "read" - "regexp" - "sema" - "setjmpup" - "string" - "struct" - "symbol" - "syntax" - "stxobj" - "thread" - "type" - "vector")) - -(define (try src deps dest objdest includes use-precomp extra-compile-flags expand-extra-flags msvc-pch) - (when (or (not re:only) (regexp-match re:only dest)) - (unless (and (file-exists? dest) - (let ([t (file-or-directory-modify-seconds dest)]) - (andmap - (lambda (dep) - (let ([dep (cond - [(bytes? dep) (bytes->path dep)] - [else dep])]) - (> t (file-or-directory-modify-seconds dep)))) - (append deps - (if use-precomp (list use-precomp) null) - (let ([deps (path-replace-suffix dest #".sdep")]) - (if (file-exists? deps) - (with-input-from-file deps read) - null)))))) - (unless (parameterize - ([use-compiled-file-paths (list "compiled")]) - (restart-mzscheme #() (lambda (x) x) - (list->vector - (append - (list "-r" - "../../mzscheme/gc2/xform.ss" - "--setup") - (if objdest - (if use-precomp - (list "--precompiled" use-precomp) - null) - (list "--precompile")) - (list - "--depends" - (format "cl.exe /MT /E ~a ~a" expand-extra-flags includes) - src - dest))) - void)) - (when (file-exists? dest) - (delete-file dest)) - (error "error xforming"))) - (when objdest - (compile dest objdest null (string-append - extra-compile-flags - (if msvc-pch - (format " /Fp~a" msvc-pch) - "")))))) - -(define (compile c o deps flags) - (unless (and (file-exists? o) - (let ([t (file-or-directory-modify-seconds o)]) - (and (>= t (file-or-directory-modify-seconds c)) - (andmap - (lambda (f) - (>= t (file-or-directory-modify-seconds f))) - deps)))) - (unless (system- (format "cl.exe ~a /MT /Zi ~a /c ~a /Fdxsrc/ /Fo~a" flags opt-flags c o)) - (error "failed compile")))) - -(define common-deps (list "../../mzscheme/gc2/xform.ss" - "../../mzscheme/gc2/xform-mod.ss")) - -(define (find-obj f d) (format "../../worksp/~a/release/~a.obj" d f)) - -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define mz-inc "/I ../../mzscheme/include /I .. ") - -(try "precomp.c" (list* "../../mzscheme/src/schvers.h" - common-deps) - "xsrc/precomp.h" #f - (string-append mz-inc "/I ../../mzscheme/src") - #f "" "" #f) - -(for-each - (lambda (x) - (try (format "../../mzscheme/src/~a.c" x) - (list* ; (find-obj x "libmzsch") - (format "../../mzscheme/src/~a.c" x) - common-deps) - (format "xsrc/~a.c" x) - (format "xsrc/~a.obj" x) - mz-inc - "xsrc/precomp.h" - "" - "" - "mz.pch")) - srcs) - -(try "../../mzscheme/main.c" - (list* ; (find-obj "main" "mzscheme") - "../../mzscheme/main.c" - common-deps) - "xsrc/main.c" - "xsrc/main.obj" - mz-inc - #f - "" - "" - #f) - -(try "../../foreign/foreign.c" - (list* ; (find-obj "main" "mzscheme") - "../../foreign/foreign.c" - common-deps) - "xsrc/foreign.c" - "xsrc/foreign.obj" - (string-append - mz-inc - "/I../../foreign/libffi_msvc " - "/I../../mzscheme/src ") - #f - "" - "" - #f) - -(compile "../../mzscheme/gc2/gc2.c" "xsrc/gc2.obj" - (map (lambda (f) (build-path "../../mzscheme/gc2/" f)) - '("gc2.c" - "compact.c" - "newgc.c" - "vm_win.c" - "sighand.c" - "msgprint.c")) - (string-append - "/D GC2_AS_EXPORT " - (if accounting-gc? - "/D NEWGC_BTC_ACCOUNT " - "/D USE_COMPACT_3M_GC") - mz-inc)) -(compile "../../mzscheme/src/mzsj86.c" "xsrc/mzsj86.obj" '() mz-inc) - -(define dll "../../../libmzsch3mxxxxxxx.dll") -(define exe "../../../MzScheme3m.exe") - -(define libs "kernel32.lib user32.lib wsock32.lib shell32.lib advapi32.lib") - -(define (link-dll objs sys-libs dll link-options exe?) - (let ([ms (if (file-exists? dll) - (file-or-directory-modify-seconds dll) - 0)]) - (when (ormap - (lambda (f) - (> (file-or-directory-modify-seconds f) - ms)) - objs) - (unless (system- (format "cl.exe ~a /MT /Zi /Fe~a unicows.lib ~a ~a ~a" - (if exe? "" "/LD /DLL") - dll - (let loop ([objs (append objs sys-libs)]) - (if (null? objs) - "" - (string-append - (car objs) - " " - (loop (cdr objs))))) - libs - link-options)) - (error 'winmake "~a link failed" (if exe? "EXE" "DLL")))))) - -(let ([objs (list* - "../libmzsch/Release/uniplt.obj" - "xsrc/gc2.obj" - "xsrc/mzsj86.obj" - "xsrc/foreign.obj" - (find-obj "gmp" "libmzsch") - (find-obj "ffi" "libmzsch") - (find-obj "win32" "libmzsch") - (find-obj "prep_cif" "libmzsch") - (find-obj "types" "libmzsch") - (map - (lambda (n) - (format "xsrc/~a.obj" n)) - srcs))]) - (link-dll objs null dll "" #f)) - -(let ([objs (list - "xsrc/main.obj" - "../libmzsch/Release/uniplt.obj" - "../../../libmzsch3mxxxxxxx.lib")]) - (link-dll objs null exe "" #t)) - -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define wx-inc (string-append "/I ../../mzscheme/include " - "/I .. " - "/I ../../mzscheme/gc2 " - "/I ../../wxwindow/include/msw " - "/I ../../wxwindow/include/base " - "/I ../../mred/wxme " - "/I ../../wxwindow/contrib/wxxpm/libxpm.34b/lib " - "/I ../../wxWindow/contrib/fafa " - "/I ../../wxcommon/jpeg /I ../../worksp/jpeg /I ../../wxcommon/zlib ")) -(try "wxprecomp.cxx" (list* "../../mzscheme/src/schvers.h" common-deps) - "xsrc/wxprecomp.h" #f wx-inc #f "" "-DGC2_AS_IMPORT" #f) - -(define (wx-try base proj x use-precomp? suffix) - (let ([cxx-file (format "../../~a/~a.~a" base x suffix)]) - (try cxx-file - (list* ; (find-obj x proj) - cxx-file - common-deps) - (format "xsrc/~a.~a" x suffix) - (format "xsrc/~a.obj" x) - wx-inc - (and use-precomp? "xsrc/wxprecomp.h") - "-DGC2_JUST_MACROS /FI../../../mzscheme/gc2/gc2.h" - "-DGC2_AS_IMPORT" - "wx.pch"))) - -(define wxwin-base-srcs - '("wb_canvs" - "wb_cmdlg" - "wb_data" - "wb_dc" - "wb_dialg" - "wb_frame" - "wb_gdi" - "wb_hash" - "wb_item" - "wb_list" - "wb_main" - "wb_obj" - "wb_panel" - "wb_print" - "wb_ps" - "wb_stdev" - "wb_sysev" - "wb_timer" - "wb_types" - "wb_utils" - "wb_win")) - -(map (lambda (x) - (wx-try "wxwindow/src/base" "wxwin" x #t "cxx")) - wxwin-base-srcs) - -(define wxwin-msw-srcs - '("wx_buttn" - "wx_canvs" - "wx_check" - "wx_choic" - "wx_clipb" - "wx_cmdlg" - "wx_dc" - "wx_dialg" - "wx_frame" - "wx_gauge" - "wx_gbox" - "wx_gdi" - "wx_graph_glue" - "wx_item" - "wx_lbox" - "wx_main" - "wx_menu" - "wx_messg" - "wx_panel" - "wx_pdf" - "wx_rbox" - "wx_slidr" - "wx_tabc" - "wx_timer" - "wx_utils" - "wx_win" - "wximgfil")) - -(map (lambda (x) - (wx-try "wxwindow/src/msw" "wxwin" x #t "cxx")) - wxwin-msw-srcs) - -(define wxs-srcs - '("wxs_bmap" - "wxs_butn" - "wxs_chce" - "wxs_ckbx" - "wxs_cnvs" - "wxs_dc" - "wxs_evnt" - "wxs_fram" - "wxs_gage" - "wxs_gdi" - "wxs_glob" - "wxs_item" - "wxs_lbox" - "wxs_madm" - "wxs_mede" - "wxs_medi" - "wxs_menu" - "wxs_mio" - "wxs_misc" - "wxs_mpb" - "wxs_obj" - "wxs_panl" - "wxs_rado" - "wxs_slid" - "wxs_snip" - "wxs_styl" - "wxs_tabc" - "wxs_win" - "wxscheme")) - -(map (lambda (x) - (wx-try "mred/wxs" "wxs" x #t "cxx")) - wxs-srcs) - -(define wxme-srcs - '("wx_cgrec" - "wx_keym" - "wx_mbuf" - "wx_medad" - "wx_media" - "wx_medio" - "wx_mline" - "wx_mpbrd" - "wx_mpriv" - "wx_msnip" - "wx_snip" - "wx_style")) - -(map (lambda (x) - (wx-try "mred/wxme" "wxme" x #t "cxx")) - wxme-srcs) - -(define mred-srcs - '("mred" - "mredmsw")) - -(map (lambda (x) - (wx-try "mred" "libmred" x #t "cxx")) - mred-srcs) - -(wx-try "wxcommon" "wxme" "wxJPEG" #t "cxx") -(wx-try "mzscheme/utils" "wxme" "xcglue" #f "c") -(compile "../../wxcommon/wxGC.cxx" - "xsrc/wxGC.obj" - (list "../../worksp/wxme/Release/wxGC.obj") - (string-append wx-inc " -DMZ_PRECISE_GC -DGC2_AS_IMPORT -Dwx_msw")) - -(let ([objs (append (list - "../libmzsch/Release/uniplt.obj" - "xsrc/wxGC.obj" - "xsrc/wxJPEG.obj" - "xsrc/xcglue.obj") - (map - (lambda (n) - (format "xsrc/~a.obj" n)) - (append wxwin-base-srcs - wxwin-msw-srcs - wxs-srcs - wxme-srcs - mred-srcs)))] - [libs (list - "../../../libmzsch3mxxxxxxx.lib" - "../../worksp/wxutils/Release/wxutils.lib" - "../../worksp/jpeg/Release/jpeg.lib" - "../../worksp/png/Release/png.lib" - "../../worksp/zlib/Release/zlib.lib")] - [win-libs (list - "comctl32.lib" "glu32.lib" "opengl32.lib" - "gdi32.lib" "comdlg32.lib" "advapi32.lib" - "shell32.lib" "ole32.lib" "oleaut32.lib" - "winmm.lib")]) - (link-dll (append objs libs) win-libs "../../../libmred3mxxxxxxx.dll" "" #f)) - -(wx-try "mred" "mred" "mrmain" #f "cxx") - -(unless (file-exists? "mred.res") - (system- (string-append - "rc /l 0x409 /I ../../wxwindow/include/msw /I ../../wxwindow/contrib/fafa " - "/fomred.res ../../worksp/mred/mred.rc"))) - -(let ([objs (list - "mred.res" - "xsrc/mrmain.obj" - "../libmzsch/Release/uniplt.obj" - "../../../libmzsch3mxxxxxxx.lib" - "../../../libmred3mxxxxxxx.lib")]) - (link-dll objs (list "advapi32.lib") "../../../MrEd3m.exe" "/link /subsystem:windows" #t)) - -(system- "cl.exe /MT /O2 /DMZ_PRECISE_GC /I../../mzscheme/include /I.. /c ../../mzscheme/dynsrc/mzdyn.c /Fomzdyn3m.obj") -(system- "lib.exe -def:../../mzscheme/dynsrc/mzdyn.def -out:mzdyn3m.lib") - -(define (copy-file/diff src dest) - (unless (and (file-exists? dest) - (string=? (with-input-from-file src (lambda () (read-string (file-size src)))) - (with-input-from-file dest (lambda () (read-string (file-size dest)))))) - (printf "Updating ~a~n" dest) - (when (file-exists? dest) (delete-file dest)) - (copy-file src dest))) - -(copy-file/diff "mzdyn3m.exp" "../../../lib/msvc/mzdyn3m.exp") -(copy-file/diff "mzdyn3m.obj" "../../../lib/msvc/mzdyn3m.obj") -(copy-file/diff "../../../libmzsch3mxxxxxxx.lib" "../../../lib/msvc/libmzsch3mxxxxxxx.lib") + +(use-compiled-file-paths null) + +(require (lib "restart.ss") + (lib "process.ss")) + +(define (system- s) + (fprintf (current-error-port) "~a~n" s) + (system s)) + +(define accounting-gc? #t) +(define opt-flags "/O2") +(define re:only #f) + +(unless (directory-exists? "xsrc") + (make-directory "xsrc")) + +(define srcs + '("salloc" + "bignum" + "bool" + "builtin" + "char" + "complex" + "dynext" + "env" + "error" + "eval" + "file" + "fun" + "hash" + "image" + "list" + "module" + "network" + "numarith" + "number" + "numcomp" + "numstr" + "port" + "portfun" + "print" + "rational" + "read" + "regexp" + "sema" + "setjmpup" + "string" + "struct" + "symbol" + "syntax" + "stxobj" + "thread" + "type" + "vector")) + +(define (try src deps dest objdest includes use-precomp extra-compile-flags expand-extra-flags msvc-pch) + (when (or (not re:only) (regexp-match re:only dest)) + (unless (and (file-exists? dest) + (let ([t (file-or-directory-modify-seconds dest)]) + (andmap + (lambda (dep) + (let ([dep (cond + [(bytes? dep) (bytes->path dep)] + [else dep])]) + (> t (file-or-directory-modify-seconds dep)))) + (append deps + (if use-precomp (list use-precomp) null) + (let ([deps (path-replace-suffix dest #".sdep")]) + (if (file-exists? deps) + (with-input-from-file deps read) + null)))))) + (unless (parameterize + ([use-compiled-file-paths (list "compiled")]) + (restart-mzscheme #() (lambda (x) x) + (list->vector + (append + (list "-r" + "../../mzscheme/gc2/xform.ss" + "--setup") + (if objdest + (if use-precomp + (list "--precompiled" use-precomp) + null) + (list "--precompile")) + (list + "--depends" + (format "cl.exe /MT /E ~a ~a" expand-extra-flags includes) + src + dest))) + void)) + (when (file-exists? dest) + (delete-file dest)) + (error "error xforming"))) + (when objdest + (compile dest objdest null (string-append + extra-compile-flags + (if msvc-pch + (format " /Fp~a" msvc-pch) + "")))))) + +(define (compile c o deps flags) + (unless (and (file-exists? o) + (let ([t (file-or-directory-modify-seconds o)]) + (and (>= t (file-or-directory-modify-seconds c)) + (andmap + (lambda (f) + (>= t (file-or-directory-modify-seconds f))) + deps)))) + (unless (system- (format "cl.exe ~a /MT /Zi ~a /c ~a /Fdxsrc/ /Fo~a" flags opt-flags c o)) + (error "failed compile")))) + +(define common-deps (list "../../mzscheme/gc2/xform.ss" + "../../mzscheme/gc2/xform-mod.ss")) + +(define (find-obj f d) (format "../../worksp/~a/release/~a.obj" d f)) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define mz-inc "/I ../../mzscheme/include /I .. ") + +(try "precomp.c" (list* "../../mzscheme/src/schvers.h" + common-deps) + "xsrc/precomp.h" #f + (string-append mz-inc "/I ../../mzscheme/src") + #f "" "" #f) + +(for-each + (lambda (x) + (try (format "../../mzscheme/src/~a.c" x) + (list* ; (find-obj x "libmzsch") + (format "../../mzscheme/src/~a.c" x) + common-deps) + (format "xsrc/~a.c" x) + (format "xsrc/~a.obj" x) + mz-inc + "xsrc/precomp.h" + "" + "" + "mz.pch")) + srcs) + +(try "../../mzscheme/main.c" + (list* ; (find-obj "main" "mzscheme") + "../../mzscheme/main.c" + common-deps) + "xsrc/main.c" + "xsrc/main.obj" + mz-inc + #f + "" + "" + #f) + +(try "../../foreign/foreign.c" + (list* ; (find-obj "main" "mzscheme") + "../../foreign/foreign.c" + common-deps) + "xsrc/foreign.c" + "xsrc/foreign.obj" + (string-append + mz-inc + "/I../../foreign/libffi_msvc " + "/I../../mzscheme/src ") + #f + "" + "" + #f) + +(compile "../../mzscheme/gc2/gc2.c" "xsrc/gc2.obj" + (map (lambda (f) (build-path "../../mzscheme/gc2/" f)) + '("gc2.c" + "compact.c" + "newgc.c" + "vm_win.c" + "sighand.c" + "msgprint.c")) + (string-append + "/D GC2_AS_EXPORT " + (if accounting-gc? + "/D NEWGC_BTC_ACCOUNT " + "/D USE_COMPACT_3M_GC") + mz-inc)) +(compile "../../mzscheme/src/mzsj86.c" "xsrc/mzsj86.obj" '() mz-inc) + +(define dll "../../../libmzsch3mxxxxxxx.dll") +(define exe "../../../MzScheme3m.exe") + +(define libs "kernel32.lib user32.lib wsock32.lib shell32.lib advapi32.lib") + +(define (link-dll objs sys-libs dll link-options exe?) + (let ([ms (if (file-exists? dll) + (file-or-directory-modify-seconds dll) + 0)]) + (when (ormap + (lambda (f) + (> (file-or-directory-modify-seconds f) + ms)) + objs) + (unless (system- (format "cl.exe ~a /MT /Zi /Fe~a unicows.lib ~a ~a ~a" + (if exe? "" "/LD /DLL") + dll + (let loop ([objs (append objs sys-libs)]) + (if (null? objs) + "" + (string-append + (car objs) + " " + (loop (cdr objs))))) + libs + link-options)) + (error 'winmake "~a link failed" (if exe? "EXE" "DLL")))))) + +(let ([objs (list* + "../libmzsch/Release/uniplt.obj" + "xsrc/gc2.obj" + "xsrc/mzsj86.obj" + "xsrc/foreign.obj" + (find-obj "gmp" "libmzsch") + (find-obj "ffi" "libmzsch") + (find-obj "win32" "libmzsch") + (find-obj "prep_cif" "libmzsch") + (find-obj "types" "libmzsch") + (map + (lambda (n) + (format "xsrc/~a.obj" n)) + srcs))]) + (link-dll objs null dll "" #f)) + +(let ([objs (list + "xsrc/main.obj" + "../libmzsch/Release/uniplt.obj" + "../../../libmzsch3mxxxxxxx.lib")]) + (link-dll objs null exe "" #t)) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define wx-inc (string-append "/I ../../mzscheme/include " + "/I .. " + "/I ../../mzscheme/gc2 " + "/I ../../wxwindow/include/msw " + "/I ../../wxwindow/include/base " + "/I ../../mred/wxme " + "/I ../../wxwindow/contrib/wxxpm/libxpm.34b/lib " + "/I ../../wxWindow/contrib/fafa " + "/I ../../wxcommon/jpeg /I ../../worksp/jpeg /I ../../wxcommon/zlib ")) +(try "wxprecomp.cxx" (list* "../../mzscheme/src/schvers.h" common-deps) + "xsrc/wxprecomp.h" #f wx-inc #f "" "-DGC2_AS_IMPORT" #f) + +(define (wx-try base proj x use-precomp? suffix) + (let ([cxx-file (format "../../~a/~a.~a" base x suffix)]) + (try cxx-file + (list* ; (find-obj x proj) + cxx-file + common-deps) + (format "xsrc/~a.~a" x suffix) + (format "xsrc/~a.obj" x) + wx-inc + (and use-precomp? "xsrc/wxprecomp.h") + "-DGC2_JUST_MACROS /FI../../../mzscheme/gc2/gc2.h" + "-DGC2_AS_IMPORT" + "wx.pch"))) + +(define wxwin-base-srcs + '("wb_canvs" + "wb_cmdlg" + "wb_data" + "wb_dc" + "wb_dialg" + "wb_frame" + "wb_gdi" + "wb_hash" + "wb_item" + "wb_list" + "wb_main" + "wb_obj" + "wb_panel" + "wb_print" + "wb_ps" + "wb_stdev" + "wb_sysev" + "wb_timer" + "wb_types" + "wb_utils" + "wb_win")) + +(map (lambda (x) + (wx-try "wxwindow/src/base" "wxwin" x #t "cxx")) + wxwin-base-srcs) + +(define wxwin-msw-srcs + '("wx_buttn" + "wx_canvs" + "wx_check" + "wx_choic" + "wx_clipb" + "wx_cmdlg" + "wx_dc" + "wx_dialg" + "wx_frame" + "wx_gauge" + "wx_gbox" + "wx_gdi" + "wx_graph_glue" + "wx_item" + "wx_lbox" + "wx_main" + "wx_menu" + "wx_messg" + "wx_panel" + "wx_pdf" + "wx_rbox" + "wx_slidr" + "wx_tabc" + "wx_timer" + "wx_utils" + "wx_win" + "wximgfil")) + +(map (lambda (x) + (wx-try "wxwindow/src/msw" "wxwin" x #t "cxx")) + wxwin-msw-srcs) + +(define wxs-srcs + '("wxs_bmap" + "wxs_butn" + "wxs_chce" + "wxs_ckbx" + "wxs_cnvs" + "wxs_dc" + "wxs_evnt" + "wxs_fram" + "wxs_gage" + "wxs_gdi" + "wxs_glob" + "wxs_item" + "wxs_lbox" + "wxs_madm" + "wxs_mede" + "wxs_medi" + "wxs_menu" + "wxs_mio" + "wxs_misc" + "wxs_mpb" + "wxs_obj" + "wxs_panl" + "wxs_rado" + "wxs_slid" + "wxs_snip" + "wxs_styl" + "wxs_tabc" + "wxs_win" + "wxscheme")) + +(map (lambda (x) + (wx-try "mred/wxs" "wxs" x #t "cxx")) + wxs-srcs) + +(define wxme-srcs + '("wx_cgrec" + "wx_keym" + "wx_mbuf" + "wx_medad" + "wx_media" + "wx_medio" + "wx_mline" + "wx_mpbrd" + "wx_mpriv" + "wx_msnip" + "wx_snip" + "wx_style")) + +(map (lambda (x) + (wx-try "mred/wxme" "wxme" x #t "cxx")) + wxme-srcs) + +(define mred-srcs + '("mred" + "mredmsw")) + +(map (lambda (x) + (wx-try "mred" "libmred" x #t "cxx")) + mred-srcs) + +(wx-try "wxcommon" "wxme" "wxJPEG" #t "cxx") +(wx-try "mzscheme/utils" "wxme" "xcglue" #f "c") +(compile "../../wxcommon/wxGC.cxx" + "xsrc/wxGC.obj" + (list "../../worksp/wxme/Release/wxGC.obj") + (string-append wx-inc " -DMZ_PRECISE_GC -DGC2_AS_IMPORT -Dwx_msw")) + +(let ([objs (append (list + "../libmzsch/Release/uniplt.obj" + "xsrc/wxGC.obj" + "xsrc/wxJPEG.obj" + "xsrc/xcglue.obj") + (map + (lambda (n) + (format "xsrc/~a.obj" n)) + (append wxwin-base-srcs + wxwin-msw-srcs + wxs-srcs + wxme-srcs + mred-srcs)))] + [libs (list + "../../../libmzsch3mxxxxxxx.lib" + "../../worksp/wxutils/Release/wxutils.lib" + "../../worksp/jpeg/Release/jpeg.lib" + "../../worksp/png/Release/png.lib" + "../../worksp/zlib/Release/zlib.lib")] + [win-libs (list + "comctl32.lib" "glu32.lib" "opengl32.lib" + "gdi32.lib" "comdlg32.lib" "advapi32.lib" + "shell32.lib" "ole32.lib" "oleaut32.lib" + "winmm.lib")]) + (link-dll (append objs libs) win-libs "../../../libmred3mxxxxxxx.dll" "" #f)) + +(wx-try "mred" "mred" "mrmain" #f "cxx") + +(unless (file-exists? "mred.res") + (system- (string-append + "rc /l 0x409 /I ../../wxwindow/include/msw /I ../../wxwindow/contrib/fafa " + "/fomred.res ../../worksp/mred/mred.rc"))) + +(let ([objs (list + "mred.res" + "xsrc/mrmain.obj" + "../libmzsch/Release/uniplt.obj" + "../../../libmzsch3mxxxxxxx.lib" + "../../../libmred3mxxxxxxx.lib")]) + (link-dll objs (list "advapi32.lib") "../../../MrEd3m.exe" "/link /subsystem:windows" #t)) + +(system- "cl.exe /MT /O2 /DMZ_PRECISE_GC /I../../mzscheme/include /I.. /c ../../mzscheme/dynsrc/mzdyn.c /Fomzdyn3m.obj") +(system- "lib.exe -def:../../mzscheme/dynsrc/mzdyn.def -out:mzdyn3m.lib") + +(define (copy-file/diff src dest) + (unless (and (file-exists? dest) + (string=? (with-input-from-file src (lambda () (read-string (file-size src)))) + (with-input-from-file dest (lambda () (read-string (file-size dest)))))) + (printf "Updating ~a~n" dest) + (when (file-exists? dest) (delete-file dest)) + (copy-file src dest))) + +(copy-file/diff "mzdyn3m.exp" "../../../lib/msvc/mzdyn3m.exp") +(copy-file/diff "mzdyn3m.obj" "../../../lib/msvc/mzdyn3m.obj") +(copy-file/diff "../../../libmzsch3mxxxxxxx.lib" "../../../lib/msvc/libmzsch3mxxxxxxx.lib") diff --git a/src/worksp/mzconfig.h b/src/worksp/mzconfig.h index f01fad196d..72ade2c46c 100644 --- a/src/worksp/mzconfig.h +++ b/src/worksp/mzconfig.h @@ -1,22 +1,22 @@ - -/* This file contains information for Windows that is collected using the - * "configure" script on other platforms. See src/mzscheme/mzconfig.h.in for - * things that should be defined here. - */ - -/* These are not used on Windows. */ - -/* The size of a `char', as computed by sizeof. */ -#undef SIZEOF_CHAR - -/* The size of a `int', as computed by sizeof. */ -#undef SIZEOF_INT - -/* The size of a `short', as computed by sizeof. */ -#undef SIZEOF_SHORT - -/* The size of a `long', as computed by sizeof. */ -#undef SIZEOF_LONG - -/* The size of a `long long', as computed by sizeof. */ -#undef SIZEOF_LONG_LONG + +/* This file contains information for Windows that is collected using the + * "configure" script on other platforms. See src/mzscheme/mzconfig.h.in for + * things that should be defined here. + */ + +/* These are not used on Windows. */ + +/* The size of a `char', as computed by sizeof. */ +#undef SIZEOF_CHAR + +/* The size of a `int', as computed by sizeof. */ +#undef SIZEOF_INT + +/* The size of a `short', as computed by sizeof. */ +#undef SIZEOF_SHORT + +/* The size of a `long', as computed by sizeof. */ +#undef SIZEOF_LONG + +/* The size of a `long long', as computed by sizeof. */ +#undef SIZEOF_LONG_LONG