From c877c0a2d804465cc9c752f203592b46aa4f5e66 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 6 Aug 2007 16:15:55 +0000 Subject: [PATCH] updates from Chongkai svn: r7034 --- collects/srfi/19/time.ss | 2 +- collects/srfi/29/localization.ss | 255 ++++++++++--------------------- collects/srfi/63/63.ss | 4 +- 3 files changed, 86 insertions(+), 175 deletions(-) diff --git a/collects/srfi/19/time.ss b/collects/srfi/19/time.ss index 85628a2ccb..6ac88f0d1e 100644 --- a/collects/srfi/19/time.ss +++ b/collects/srfi/19/time.ss @@ -97,7 +97,7 @@ ;; SRFI-29: Localization initialization: (re-read-locale) - (or (load-bundle! (list 'srfi-19 + (or (load-bundle! (list* 'srfi-19 (current-language) (current-country) (current-locale-details))) diff --git a/collects/srfi/29/localization.ss b/collects/srfi/29/localization.ss index aee26695d6..c19753911d 100644 --- a/collects/srfi/29/localization.ss +++ b/collects/srfi/29/localization.ss @@ -1,39 +1,21 @@ -;;; SRFI-29: localization port to PLT Scheme -*- Scheme -*- -;;; Time-stamp: <03/05/08 12:49:08 solsona> -;;; -;;; Copyright (C) Scott G. Miller (2002). All Rights Reserved. -;;; -;;; This file is part of PLT Scheme. - -;;; PLT Scheme 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. - -;;; PLT Scheme 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 PLT Scheme; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -;;; Author: Scott G. Miller -;;; Modified for PLT Scheme by: Francisco Solsona - (module localization mzscheme - (require (lib "etc.ss") + + (require (lib "contract.ss") + (lib "file.ss") (lib "runtime-path.ss") + (lib "string.ss") (lib "modread.ss" "syntax")) - (provide current-language current-country current-locale-details - load-bundle! store-bundle! declare-bundle! - localized-template - ;; NOT in SRFI-29, but useful in PLT when using/changing current-locale: - re-read-locale - ) - - + + (provide/contract (current-language (parameter/c symbol?)) + (current-country (parameter/c symbol?)) + (current-locale-details (parameter/c (listof symbol?))) + (declare-bundle! (-> (listof symbol?) (listof pair?) any)) + (load-bundle! (->* ((listof symbol?)) any/c any)) + (store-bundle! (-> (listof symbol?) any)) + (localized-template (-> symbol? any/c any))) + + (provide re-read-locale) + (define get-from-locale (lambda (what) (let ((locale (current-locale))) @@ -56,48 +38,51 @@ (if (> len 6) (list (string->symbol (substring locale 6))) null)))))))) - - (define list-of - (lambda (pred) - (lambda (lst) - (call/cc (lambda (exit) - (let loop ((lst lst)) - (cond ((null? lst) #t) - (else (or (pred (car lst)) - (exit #f)) - (loop (cdr lst)))))))))) - - ;; The association list in which bundles will be stored - (define *localization-bundles* '()) - + (define *localization-bundles* + (make-hash-table 'equal)) + (define current-language - (make-parameter (get-from-locale 'language) (lambda (l) - (if (symbol? l) l 'en)))) - + (make-parameter (get-from-locale 'language))) + (define current-country - (make-parameter (get-from-locale 'country) (lambda (l) - (if (symbol? l) l 'us)))) + (make-parameter (get-from-locale 'country))) (define current-locale-details - (make-parameter (get-from-locale 'details) (lambda (lst) - (if ((list-of symbol?) lst) - lst - null)))) - + (make-parameter (get-from-locale 'details))) + + (define (make-name bundle-specifier) + (string->symbol + (string-append "srfi-29:" + (expr->string bundle-specifier)))) + + (define (declare-bundle! bundle-specifier bundle-assoc-list) + (hash-table-put! *localization-bundles* bundle-specifier bundle-assoc-list)) + + (define (store-bundle! bundle-specifier) + (put-preferences (list (make-name bundle-specifier)) + (list (hash-table-get *localization-bundles* bundle-specifier))) + #t) + + (define (load-bundle-from-preference! bundle-specifier) + (let/ec k + (declare-bundle! bundle-specifier + (get-preference (make-name bundle-specifier) + (lambda () (k #f)))) + #t)) + ;; If you change (current-locale), you don't have to set current-* ;; by hand, you can simply call this procedure, and it will update ;; those parameters to the values in the new locale. - (define re-read-locale - (lambda () - (current-language (get-from-locale 'language)) - (current-country (get-from-locale 'country)) - (current-locale-details (get-from-locale 'details)))) + (define (re-read-locale) + (current-language (get-from-locale 'language)) + (current-country (get-from-locale 'country)) + (current-locale-details (get-from-locale 'details))) ;; System bundles are here: (define-runtime-path system-bundles "bundles") - + (define (with-reader-params thunk) ;; Use `with-module-reading-parameterization' to get ;; most defaults... @@ -106,114 +91,40 @@ ;; ... but disable `#reader': (parameterize ([read-accept-reader #f]) (thunk))))) - - ;; bundle-specifier: (listof symbol) - ;; i.e. package + locale, (package-name [language] [country] [details ...]) - (define load-bundle! - (opt-lambda (bundle-specifier [alternate-path null]) - (let* ((filename (case (length bundle-specifier) - ((1) (symbol->string (car bundle-specifier))) - ((2) (build-path (symbol->string (cadr bundle-specifier)) - (symbol->string (car bundle-specifier)))) - (else (build-path (symbol->string (cadr bundle-specifier)) - (symbol->string (caddr bundle-specifier)) - (symbol->string (car bundle-specifier)))))) - (path (build-path (if (null? alternate-path) - system-bundles - alternate-path) - filename))) - (and (file-exists? path) - ;; Found! - (declare-bundle! bundle-specifier - (with-reader-params - (lambda () - (with-input-from-file path read)))))))) - - (define extract-assoc-list - (lambda (bundle-specifier) - (let loop ((bundle *localization-bundles*)) - (cond ((null? bundle) #f) - ((equal? (caar bundle) bundle-specifier) - (cdar bundle)) - (else (extract-assoc-list (cdr bundle))))))) - (define store-bundle! - (opt-lambda (bundle-specifier [alternate-path null]) - (let* ((sub-path (if (null? alternate-path) system-bundles alternate-path)) - (file (case (length bundle-specifier) - ((1) (symbol->string (car bundle-specifier))) - ((2) - (let* ((dir (build-path sub-path (symbol->string (cadr bundle-specifier)))) - (file (build-path dir (symbol->string (car bundle-specifier))))) - (unless (directory-exists? dir) - (make-directory dir)) - file)) - (else - (let* ((dir (build-path sub-path (symbol->string (cadr bundle-specifier)))) - (dir2 (build-path dir (symbol->string (caddr bundle-specifier)))) - (file (build-path dir2 (symbol->string (car bundle-specifier))))) - (unless (directory-exists? dir) - (make-directory dir)) - (unless (directory-exists? dir2) - (make-directory dir2)) - file)))) - (bundle-assoc-list (extract-assoc-list bundle-specifier))) - - (and bundle-assoc-list - ;; Storing bundle! - (if (file-exists? file) - (if (memq 'write (file-or-directory-permissions file)) - ;; Replacing the existing bundle - (with-output-to-file file (lambda () - (write bundle-assoc-list)) - 'truncate/replace) - #f);; should be an exception? - (if (let-values ([(base filename directory?) (split-path file)]) - (memq 'write (file-or-directory-permissions base))) - ;; First time, this bundle is stored here: - (with-output-to-file file (lambda () - (write bundle-assoc-list))) - #f)))))) - - ;; Declare a bundle of templates with a given bundle specifier - (define declare-bundle! - (letrec ((remove-old-bundle - (lambda (specifier bundle) - (cond ((null? bundle) '()) - ((equal? (caar bundle) specifier) - (cdr bundle)) - (else (cons (car bundle) - (remove-old-bundle specifier - (cdr bundle)))))))) - (lambda (bundle-specifier bundle-assoc-list) - (set! *localization-bundles* - (cons (cons bundle-specifier bundle-assoc-list) - (remove-old-bundle bundle-specifier - *localization-bundles*)))))) - + ;; load-bundle! accpect an alternate-path to search bundle + (define (load-bundle! bundle-specifier . alternate-path) + (or (load-bundle-from-preference! bundle-specifier) + (let* ((filename (case (length bundle-specifier) + ((1) (symbol->string (car bundle-specifier))) + ((2) (build-path (symbol->string (cadr bundle-specifier)) + (symbol->string (car bundle-specifier)))) + (else (build-path (symbol->string (cadr bundle-specifier)) + (symbol->string (caddr bundle-specifier)) + (symbol->string (car bundle-specifier)))))) + (path (build-path (if (null? alternate-path) + system-bundles + (car alternate-path)) + filename))) + (and (file-exists? path) + (declare-bundle! bundle-specifier + (with-reader-params + (lambda () + (with-input-from-file path read)))) + #t)))) + (define (rdc ls) + (if (null? (cdr ls)) + '() + (cons (car ls) (rdc (cdr ls))))) + ;;Retrieve a localized template given its package name and a template name - (define localized-template - (letrec ((rdc - (lambda (ls) - (if (null? (cdr ls)) - '() - (cons (car ls) (rdc (cdr ls)))))) - (find-bundle - (lambda (specifier template-name) - (cond ((assoc specifier *localization-bundles*) => - (lambda (bundle) bundle)) - ((null? specifier) #f) - (else (find-bundle (rdc specifier) - template-name)))))) - (lambda (package-name template-name) - (let loop ((specifier (cons package-name - (list (current-language) - (current-country))))) - (and (not (null? specifier)) - (let ((bundle (find-bundle specifier template-name))) - (and bundle - (cond ((assq template-name bundle) => cdr) - ((null? (cdr specifier)) #f) - (else (loop (rdc specifier))))))))))) - - ) \ No newline at end of file + (define (localized-template package-name template-name) + (let loop ((specifier (list package-name + (current-language) + (current-country)))) + (and (not (null? specifier)) + (let ((bundle (hash-table-get *localization-bundles* specifier #f))) + (cond ((and bundle (assq template-name bundle)) => cdr) + ((null? (cdr specifier)) #f) + (else (loop (rdc specifier)))))))) + ) diff --git a/collects/srfi/63/63.ss b/collects/srfi/63/63.ss index cfe9082cde..6541147273 100644 --- a/collects/srfi/63/63.ss +++ b/collects/srfi/63/63.ss @@ -154,8 +154,8 @@ (and (s:equal? (vector-ref obj1 idx) (vector-ref obj2 idx)) (lp (sub1 idx)))))) - (and (my-array? obj1) - (my-array? obj2) + (and (array? obj1) + (array? obj2) (equal? (array-dimensions obj1) (array-dimensions obj2)) (s:equal? (array->vector obj1) (array->vector obj2))) (and (struct? obj1)