Changeset 34213 in project


Ignore:
Timestamp:
06/27/17 18:40:49 (5 months ago)
Author:
kon
Message:

rmv variable-items dep, all parameters

Location:
release/4/srfi-29
Files:
8 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/srfi-29/tags/2.4.0/srfi-29.meta

    r31582 r34213  
    1111  (setup-helper "1.5.4")
    1212  (miscmacros "2.91")
    13   (variable-item "1.3.0")
    1413  (posix-utils "1.0.0")
    1514  (lookup-table "1.13.1")
  • release/4/srfi-29/tags/2.4.0/srfi-29.scm

    r34115 r34213  
    11;;;; srfi-29.scm
     2;;;; Kon Lovett, Jun '17
     3;;;; Kon Lovett,
    24;;;; Kon Lovett, Dec '05
    35
     
    1921(module srfi-29
    2022
    21   (;export
    22     ; SRFI 29
    23     current-language
    24     current-country
    25     current-locale-details
    26     load-bundle!
    27     store-bundle!
    28     declare-bundle!
    29     localized-template
    30     ; Extensions
    31     undefined-condition? unbound-variable-condition?
    32     system-bundle-directory
    33     most-specific-bundle-specifier
    34     required-localized-template
    35     localized-template/default
    36     make-required-localized-template
    37     make-localized-template
    38     make-localized-template/default
    39     localized-template-set!
    40     load-localized-compiled-code
    41     remove-bundle!
    42     undeclare-bundle!
    43     reset-locale-parameters
    44     remove-bundle-directory!
    45     load-best-available-bundle!
    46     current-locale-format-function
    47     localized-format
    48     localized-templates
    49     declared-bundle-specifiers
    50     declared-bundle-templates)
    51 
    52   (import
    53     scheme chicken
    54     (only srfi-1
    55       map! reverse! every drop-right!
    56       remove remove! fold list-copy)
    57     (only srfi-13
    58       string-downcase)
    59     (only extras
    60       format)
    61     (only data-structures
    62       intersperse conc ->string)
    63     (only files
    64       delete-file*
    65       make-pathname pathname-directory)
    66     (only posix
    67       directory? create-directory delete-directory directory)
    68     (only lookup-table
    69       make-dict dict-ref dict-set! dict-delete!
    70       dict->alist alist->dict
    71       dict-keys
    72       dict-safe-mode)
    73     (only miscmacros if*)
    74     (only locale
    75       current-locale-components locale-component-ref)
    76     (only posix-utils environment-variable-true?)
    77     (only condition-utils
    78       make-exn-condition+ make-condition-predicate)
    79     (only type-errors
    80       error-argument-type )
    81     (only type-checks
    82       check-procedure check-symbol check-string check-list
    83       define-check+error-type) )
    84 
    85   (require-library
    86     srfi-1 srfi-13 extras data-structures files posix
    87     lookup-table miscmacros locale posix-utils
    88     condition-utils type-errors type-checks)
    89 
    90   (require-extension variable-item)
    91 
    92   (declare
    93     (bound-to-procedure
    94       ##sys#symbol-has-toplevel-binding?
    95       ; Forward references
    96       most-specific-bundle-specifier
    97       invalidate-package-bundle-cache))
     23(;export
     24  ; SRFI 29
     25  current-language
     26  current-country
     27  current-locale-details
     28  load-bundle!
     29  store-bundle!
     30  declare-bundle!
     31  localized-template
     32  ; Extensions
     33  undefined-condition? unbound-variable-condition?
     34  system-bundle-directory
     35  most-specific-bundle-specifier
     36  required-localized-template
     37  localized-template/default
     38  make-required-localized-template
     39  make-localized-template
     40  make-localized-template/default
     41  localized-template-set!
     42  load-localized-compiled-code
     43  remove-bundle!
     44  undeclare-bundle!
     45  reset-locale-parameters
     46  remove-bundle-directory!
     47  load-best-available-bundle!
     48  current-locale-format-function
     49  localized-format
     50  localized-templates
     51  declared-bundle-specifiers
     52  declared-bundle-templates)
     53
     54(import scheme)
     55
     56(import
     57  chicken
     58  (only srfi-1
     59    first second third
     60    map! reverse! every drop-right!
     61    remove remove! fold list-copy)
     62  (only srfi-13
     63    string-downcase)
     64  (only extras
     65    format)
     66  (only data-structures
     67    intersperse conc ->string)
     68  (only files
     69    delete-file*
     70    make-pathname pathname-directory decompose-pathname)
     71  (only posix
     72    directory? create-directory delete-directory directory))
     73(require-library
     74  srfi-1 srfi-13 extras data-structures files posix)
     75
     76(import
     77  (only lookup-table
     78    make-dict dict-ref dict-set! dict-delete!
     79    dict->alist alist->dict
     80    dict-keys
     81    dict-safe-mode)
     82  (only miscmacros
     83    if* define-parameter)
     84  (only locale
     85    current-locale-components locale-component-ref)
     86  (only posix-utils environment-variable-true?)
     87  (only condition-utils
     88    make-exn-condition+ make-condition-predicate)
     89  (only type-errors
     90    error-argument-type )
     91  (only type-checks
     92    check-procedure check-symbol check-string check-list
     93    define-check+error-type) )
     94(require-library
     95  lookup-table miscmacros locale posix-utils
     96  condition-utils type-errors type-checks)
     97
     98;(require-extension variable-item)
     99
     100(declare
     101  (bound-to-procedure
     102    ##sys#symbol-has-toplevel-binding?))
    98103
    99104;;;
    100105
     106;used to stop the replacement of the 'package-bundle-cache'
     107;during initialization (ugh)
    101108(define *LOADTIME* #t)
    102109
     
    123130(define create-pathname-directory (cut create-directory <> #t))
    124131
    125 ;;; Constants
     132(define (pathname? obj)
     133  (and
     134    (string? obj)
     135    (let-values (((dir fil ext) (decompose-pathname obj)))
     136      ;ext w/o dir/fil indicates a *nix "hidden" file (too broad for Windows?)
     137      (or dir fil ext) ) ) )
     138
     139;; Bundle Pathname
     140
     141(define-constant TLS-ENVIRONMENT-VARIABLE "SRFI29_TLS")
    126142
    127143(define-constant DEFAULT-BUNDLE-DIR "srfi-29-bundles")
     
    132148;is [<language> [<country> [<details>...]]] (package-name).
    133149
    134 (define SYSTEM-BUNDLES (make-pathname (repository-path) DEFAULT-BUNDLE-DIR))
    135 
    136 ;; Query it
    137 
    138 (define (system-bundle-directory) SYSTEM-BUNDLES)
     150(define +default-system-bundles+ (make-pathname (repository-path) DEFAULT-BUNDLE-DIR))
     151
     152;; Where
     153
     154(define-parameter system-bundle-directory +default-system-bundles+
     155  (lambda (x)
     156    (if (pathname? x)
     157      x
     158      (error 'system-bundle-directory "invalid directory" x) ) ) )
    139159
    140160;;; Errors
     
    257277;A subset of the `localization-bundles'
    258278
    259 (define invalidate-package-bundle-cache)
    260 (define cached-package-bundle)
    261 (if (environment-variable-true? "SRFI29_TLS")
    262 
    263   ;then use a parameter for the cache
    264   ;so one bundle per package per thread
    265   (let ((package-bundle-cache (make-parameter (make-dict eq?))))
    266 
    267     (set! invalidate-package-bundle-cache (lambda args
    268       (if (null? args) (package-bundle-cache (make-dict eq?))
    269         ;else args is (bndl-spec)
    270         (dict-delete! (package-bundle-cache) (caar args)) ) ) )
    271 
    272     (set! cached-package-bundle (lambda (pkgnam)
    273       (or (dict-ref (package-bundle-cache) pkgnam)
    274           (let loop ((bndl-spec (most-specific-bundle-specifier pkgnam)))
    275             (and (not (null? bndl-spec))
    276                  (if* (bundle-ref bndl-spec)
    277                       (begin
    278                         (dict-set! (package-bundle-cache) pkgnam it)
    279                         it )
    280                       (loop (drop-right! bndl-spec 1)) ) ) ) ) ) ) )
    281 
    282   ;else one bundle per package
    283   (let ((package-bundle-cache (make-dict eq?)))
    284 
    285     (set! invalidate-package-bundle-cache (lambda args
    286       (if (null? args) (set! package-bundle-cache (make-dict eq?))
    287         ;else args is (bndl-spec)
    288         (dict-delete! package-bundle-cache (caar args)) ) ) )
    289 
    290     (set! cached-package-bundle (lambda (pkgnam)
    291       (or (dict-ref package-bundle-cache pkgnam)
    292           (let loop ((bndl-spec (most-specific-bundle-specifier pkgnam)))
    293             (and (not (null? bndl-spec))
    294                  (if* (bundle-ref bndl-spec)
    295                       (begin
    296                         (dict-set! package-bundle-cache pkgnam it)
    297                         it )
    298                       (loop (drop-right! bndl-spec 1)) ) ) ) ) ) ) ) )
     279;parameter interface
     280(define package-bundle-cache
     281  ;NOTE *LOADTIME* is #t here
     282  (let ((dict (make-dict eq?)))
     283    (if (environment-variable-true? TLS-ENVIRONMENT-VARIABLE)
     284      ;then use a parameter for the cache so one bundle per package per thread
     285      (make-parameter dict)
     286      ;else one bundle per package
     287      (let ((cur-dict dict))
     288        (lambda args
     289          (let-optionals args ((new-dict #f))
     290            (if new-dict
     291              (set! cur-dict new-dict)
     292              cur-dict ) ) ) ) ) ) )
     293
     294(define (invalidate-package-bundle-cache . args)
     295  (if (null? args)
     296    (package-bundle-cache (make-dict eq?))
     297    ;else args is (bndl-spec)
     298    (dict-delete! (package-bundle-cache) (caar args)) ) )
     299
     300(define (cached-package-bundle pkgnam)
     301  (let ((pkg-dict (package-bundle-cache)))
     302    (or
     303      (dict-ref pkg-dict pkgnam)
     304      (let loop ((bndl-spec (most-specific-bundle-specifier pkgnam)))
     305        (and
     306          (not (null? bndl-spec))
     307          (if* (bundle-ref bndl-spec)
     308            (begin
     309              (dict-set! pkg-dict pkgnam it)
     310              it )
     311            (loop (drop-right! bndl-spec 1)) ) ) ) ) ) )
    299312
    300313;;; Locale Parameters
     
    304317;; The initial procedure is the builtin
    305318
    306 (define-checked-variable current-locale-format-function format procedure)
     319(define-parameter current-locale-format-function format
     320  (lambda (x)
     321    (if (procedure? x)
     322      x
     323      (error 'current-locale-format-function "invalid procedure" x) ) ) )
    307324
    308325;; The default language, country, and locale-details
     
    337354;; If template undefined returns the template default (defaults #f).
    338355
    339 (define (localized-template pkgnam tptnam #!optional defpkg deftpt)
     356(define (localized-template pkgnam tplnam #!optional defpkg deftpl)
    340357  (if* (cached-package-bundle pkgnam)
    341     (dict-ref it tptnam deftpt)
     358    (dict-ref it tplnam deftpl)
    342359    defpkg ) )
    343360
     
    347364;; If template undefined returns the template default (defaults template-name).
    348365
    349 (define (localized-template/default pkgnam tptnam #!optional (defpkg tptnam) (deftpt tptnam))
    350   (localized-template pkgnam tptnam defpkg deftpt) )
     366(define (localized-template/default pkgnam tplnam #!optional (defpkg tplnam) (deftpl tplnam))
     367  (localized-template pkgnam tplnam defpkg deftpl) )
    351368
    352369;; Returns the localized template from the most specific bundle given
     
    358375(define NO-TEMPLATE-TAG '#(no-template))
    359376
    360 (define (*required-localized-template loc pkgnam tptnam)
    361   (let ((res (localized-template pkgnam tptnam NO-PACKAGE-TAG NO-TEMPLATE-TAG)))
     377(define (*required-localized-template loc pkgnam tplnam)
     378  (let ((res (localized-template pkgnam tplnam NO-PACKAGE-TAG NO-TEMPLATE-TAG)))
    362379    (cond
    363380      ((eq? res NO-PACKAGE-TAG)
    364381        (error-undefined loc "undefined package" pkgnam) )
    365382      ((eq? res NO-TEMPLATE-TAG)
    366         (error-undefined loc "undefined template in package" tptnam pkgnam) )
     383        (error-undefined loc "undefined template in package" tplnam pkgnam) )
    367384      (else
    368385        res ) ) ) )
    369386
    370 (define (required-localized-template pkgnam tptnam)
    371   (*required-localized-template 'required-localized-template pkgnam tptnam) )
     387(define (required-localized-template pkgnam tplnam)
     388  (*required-localized-template 'required-localized-template pkgnam tplnam) )
    372389
    373390;; Returns a procedure the looks up a template in a fixed package
    374391
    375 (define ((make-required-localized-template pkgnam) tptnam)
    376   (required-localized-template pkgnam tptnam) )
    377 
    378 (define ((make-localized-template pkgnam) tptnam #!optional defpkg deftpt)
    379   (localized-template pkgnam tptnam defpkg deftpt) )
     392(define ((make-required-localized-template pkgnam) tplnam)
     393  (required-localized-template pkgnam tplnam) )
     394
     395(define ((make-localized-template pkgnam) tplnam #!optional defpkg deftpl)
     396  (localized-template pkgnam tplnam defpkg deftpl) )
    380397
    381398(define ((make-localized-template/default pkgnam)
    382           tptnam #!optional (defpkg tptnam) (deftpt tptnam))
    383   (localized-template pkgnam tptnam) )
     399          tplnam #!optional (defpkg tplnam) (deftpl tplnam))
     400  (localized-template pkgnam tplnam) )
    384401
    385402;; Returns the application of the default 'format' procedure to the
     
    389406;; relevant details is made to proper destination.
    390407
    391 (define (localized-format pkgnam tptnam . fmtargs)
    392 
    393   (define (format-info-string pkgnam tptnam fmtargs)
     408(define (localized-format pkgnam tplnam . fmtargs)
     409
     410  (define (format-info-string pkgnam tplnam fmtargs)
    394411    (conc
    395412      #\[
    396         #\< pkgnam #\space tptnam #\>
     413        #\< pkgnam #\space tplnam #\>
    397414        #\space
    398415        (apply conc (intersperse fmtargs #\space))
     
    401418  (let ((fmtstr
    402419          (or
    403             (localized-template pkgnam tptnam)
    404             (and (string? tptnam) tptnam))))
     420            (localized-template pkgnam tplnam)
     421            (and (string? tplnam) tplnam))))
    405422    (if fmtstr
    406423      (apply (current-locale-format-function) fmtstr fmtargs)
    407       (format-info-string pkgnam tptnam fmtargs) ) ) )
     424      (format-info-string pkgnam tplnam fmtargs) ) ) )
    408425
    409426;; Create or update the value for a template in an existing package.
    410427;; Returns #t for success & #f when no such package.
    411428
    412 (define (localized-template-set! pkgnam tptnam value)
     429(define (localized-template-set! pkgnam tplnam value)
    413430  (and-let* ((bndl (cached-package-bundle pkgnam)))
    414     (dict-set! bndl tptnam value)
     431    (dict-set! bndl tplnam value)
    415432    #t ) )
    416433
     
    468485;;
    469486
     487(define (load-localized-compiled-code libspec pkgnam vartplnams)
     488  (check-package-name 'load-localized-compiled-code pkgnam)
     489  (*load-localized-compiled-code
     490    libspec
     491    pkgnam
     492    (check-template-variable-names 'load-localized-compiled-code pkgnam vartplnams)) )
     493
     494(define (*load-localized-compiled-code libspec pkgnam vartplnams)
     495  (*load-code 'load-localized-compiled-code libspec)
     496  (fixup-references 'load-localized-compiled-code pkgnam vartplnams) )
     497
     498;;
     499
    470500;There must be a better way using sys namespace operations.
    471 ;(Chicken 4.2.2 had a query for ALL loaded binaries)
     501;(Chicken 4.2.2 had a query for ALL loaded binaries. KRL dloader branch still
     502;does.)
    472503
    473504; A `library-name' is a pathname or unitname.
    474505(define +loaded-library-names+ '())
    475506
    476 (define (load-code loc libspec)
     507(define (*load-code loc libspec)
    477508  (let ((unit
    478509          (if (not (pair? libspec))
    479510            (and (symbol? libspec) libspec)
    480             (and (pair? libspec) (symbol? (car libspec)) (car libspec)) ) )
     511            (and (pair? libspec) (symbol? (first libspec)) (first libspec)) ) )
    481512        (path
    482           (if (not (pair? libspec))
    483             (and (string? libspec) libspec)
    484             (and (string? (cadr libspec)) libspec) ) ) )
     513          (and (string? (if (pair? libspec) (second libspec) libspec)) libspec) ) )
    485514    ; A pathname is preferred to a unitname
    486515    (let ((the-name (or path unit)))
     
    493522          (unit
    494523            (load-library unit) )
    495           ; Must be absolute pathaname, otherwise pathname is relative to
    496           ; "current file"
     524          ;Must be absolute pathaname, otherwise pathname is relative to
     525          ;the "current file"
    497526          (path
    498527            (load-relative path) )
     
    501530        (set! +loaded-library-names+ (cons the-name +loaded-library-names+)) ) ) ) )
    502531
    503 (define (fixup-references loc pkgnam vartptnams)
     532(define (fixup-references loc pkgnam vartplnams)
    504533  (for-each
    505     (lambda (tptnam)
     534    (lambda (tplnam)
    506535      (localized-template-set!
    507         pkgnam tptnam
    508         (required-global-ref loc (required-localized-template pkgnam tptnam))) )
    509     vartptnams) )
    510 
    511 ;;
    512 
    513 (define (*load-localized-compiled-code libspec pkgnam vartptnams)
    514   (load-code 'load-localized-compiled-code libspec)
    515   (fixup-references 'load-localized-compiled-code pkgnam vartptnams) )
    516 
    517 ;;
    518 
    519 (define (load-localized-compiled-code libspec pkgnam vartptnams)
    520   (check-package-name 'load-localized-compiled-code pkgnam)
    521   (*load-localized-compiled-code
    522     libspec
    523     pkgnam
    524     (check-template-variable-names 'load-localized-compiled-code pkgnam vartptnams)) )
     536        pkgnam tplnam
     537        (required-global-ref loc (required-localized-template pkgnam tplnam))) )
     538    vartplnams) )
    525539
    526540;;; Bundle Operations
     
    552566
    553567(define (load-bundle! bndl-spec . args)
    554   (let-optionals args ((alt-dir SYSTEM-BUNDLES))
     568  (let-optionals args ((alt-dir (system-bundle-directory)))
    555569    (let ((path
    556570            (need-bundle-absolute-pathname
     
    563577
    564578(define (store-bundle! bndl-spec . args)
    565   (let-optionals args ((alt-dir SYSTEM-BUNDLES))
     579  (let-optionals args ((alt-dir (system-bundle-directory)))
    566580    (let ((path
    567581            (need-bundle-absolute-pathname
     
    577591
    578592(define (remove-bundle! bndl-spec . args)
    579   (let-optionals args ((alt-dir SYSTEM-BUNDLES))
     593  (let-optionals args ((alt-dir (system-bundle-directory)))
    580594    (let ((path
    581595            (need-bundle-absolute-pathname
     
    588602
    589603(define (remove-bundle-directory! bndl-spec . args)
    590   (let-optionals args ((alt-dir SYSTEM-BUNDLES))
     604  (let-optionals args ((alt-dir (system-bundle-directory)))
    591605    (let ((path (need-bundle-absolute-pathname
    592606                  'remove-bundle-directory! bndl-spec alt-dir)))
     
    606620
    607621(define (load-best-available-bundle! bndl-spec . args)
    608   (let-optionals args ((alt-dir SYSTEM-BUNDLES))
     622  (let-optionals args ((alt-dir (system-bundle-directory)))
    609623    (let loop ((bndl-spec
    610624                (check-bundle-specifier
  • release/4/srfi-29/tags/2.4.0/srfi-29.setup

    r34115 r34213  
    99  (file-chmod (srfi-29-bundles-home) 'a+rx) )
    1010
    11 (setup-shared-extension-module 'srfi-29 (extension-version "2.3.3")
     11(setup-shared-extension-module 'srfi-29 (extension-version "2.4.0")
    1212  #:inline? #t
    1313  #:types? #t
    1414  #:compile-options '(
    15     -disable-interrupts ; We got shared data but might not be necessary
     15    ;-disable-interrupts ;got shared data but might not be necessary; all params now?
    1616    -fixnum-arithmetic
    1717    -O3 -d1
  • release/4/srfi-29/tags/2.4.0/tests/run.scm

    r23815 r34213  
    11;;;; srfi-29-test.scm
    22
    3 ;To use w/ TSL:
     3;To use w/ TLS:
    44;(cd .../srfi-29/trunk/tests; \
    55;sudo csi -n -R posix -e '(setenv "SRFI29_TLS" "1")' -s run.scm)
     
    1010
    1111(define (allow-sysops?)
    12   (or (eq? 'windows (software-type))
    13       (= 0 (current-effective-user-id))) )
     12  (or
     13    (eq? 'windows (software-type))
     14    (= 0 (current-effective-user-id))) )
    1415
    1516(test-group "SRFI 29 Basics"
     
    4647      (test-assert "" (declare-bundle! '(srfi-29-test foo bar) bal3))
    4748
    48       (test "declared-bundle-specifiers (problematic since assumes internal list order)"
     49      (test "declared-bundle-specifiers (uses internal list order; brittle)"
    4950            '((srfi-29-test foo bar) (srfi-29-test foo) (srfi-29-test))
    5051            (declared-bundle-specifiers))
     
    9192    (when (allow-sysops?)
    9293      (test-group "Bundles System Directory"
    93  
     94
    9495        (test-assert "B16" (declare-bundle! '(srfi-29-test) bal1))
    9596        (test-assert "B17" (declare-bundle! '(srfi-29-test foo) bal2))
    9697        (test-assert "B18" (declare-bundle! '(srfi-29-test foo bar) bal3))
    97  
     98
    9899        (test-assert "B19" (store-bundle! '(srfi-29-test)))
    99100        (test-assert "B20" (store-bundle! '(srfi-29-test foo)))
    100101        (test-assert "B21" (store-bundle! '(srfi-29-test foo bar)))
    101  
     102
    102103        (test-assert "B22" (undeclare-bundle! '(srfi-29-test)))
    103104        (test-assert "B23" (undeclare-bundle! '(srfi-29-test foo)))
    104105        (test-assert "B24" (undeclare-bundle! '(srfi-29-test foo bar)))
    105  
     106
    106107        (test-assert "B25.1" (not (localized-template 'srfi-29-test 'foo1)))
    107108        (test-assert "B26.1" (not (localized-template 'srfi-29-test "bar1")))
    108109        (test-assert "B27.1" (not (localized-template 'srfi-29-test 'baz1)))
    109  
     110
    110111        (test-assert "B22.1" (load-bundle! '(srfi-29-test)))
    111112        (test-assert "B23.1" (load-bundle! '(srfi-29-test foo)))
    112113        (test-assert "B24.1" (load-bundle! '(srfi-29-test foo bar)))
    113  
     114
    114115        (test "B25" 1 (localized-template 'srfi-29-test 'foo1))
    115116        (test "B26" 2 (localized-template 'srfi-29-test "bar1"))
    116117        (test "B27" 3 (localized-template 'srfi-29-test 'baz1))
    117  
     118
    118119        (test "localized-templates" bal1 (localized-templates 'srfi-29-test))
    119  
     120
    120121        (current-language 'foo)
    121  
     122
    122123        (test "B28" 4 (localized-template 'srfi-29-test 'foo2))
    123124        (test "B29" 5 (localized-template 'srfi-29-test "bar2"))
    124125        (test "B30" 6 (localized-template 'srfi-29-test 'baz2))
    125  
     126
    126127        (test "localized-templates language foo" bal2 (localized-templates 'srfi-29-test))
    127  
     128
    128129        (current-country 'bar)
    129  
     130
    130131        (test "B31" 7 (localized-template 'srfi-29-test 'foo3))
    131132        (test "B32" 8 (localized-template 'srfi-29-test "bar3"))
    132133        (test "B33" 9 (localized-template 'srfi-29-test 'baz3))
    133  
     134
    134135        (test "localized-templates language foo, country bar"
    135136          bal3 (localized-templates 'srfi-29-test))
    136  
     137
    137138        (test-assert "B37.1" (localized-template-set! 'srfi-29-test 'baz3 'foobar))
    138139        (test "B37.2" 'foobar (localized-template 'srfi-29-test 'baz3))
     
    140141        (test-assert "B37.4" (localized-template-set! 'srfi-29-test 'barf 16))
    141142        (test "B37.5" 16 (localized-template 'srfi-29-test 'barf))
    142  
     143
    143144        (test-assert "B34" (remove-bundle! '(srfi-29-test)))
    144145        (test-assert "B35" (remove-bundle! '(srfi-29-test foo)))
    145146        (test-assert "B36" (remove-bundle! '(srfi-29-test foo bar)))
    146  
     147
    147148        (test-assert "SysDir RmDir" (remove-bundle-directory! '(srfi-29-test foo bar)))
    148  
     149
    149150        (reset-locale-parameters)
    150151      )
     
    158159
    159160(test-group "SRFI 29 Logic"
    160  
     161
    161162  ;compile logic
    162163  (system "csc -s test-logic")
    163  
     164
    164165  ;declare logic pkg
    165166  (declare-bundle! '(srfi-29-test)
     
    177178    'srfi-29-test
    178179    '(proc0 proc1 procN proc*))
    179  
     180
    180181  ;test logic
    181182  (test-assert (procedure? (!item@ 'proc0)))
     
    183184  (test-assert (procedure? (!item@ 'procN)))
    184185  (test-assert (procedure? (!item@ 'proc*)))
    185  
     186
    186187  (test 0 ((!item@ 'proc0)))
    187188  (test -56 ((!item@ 'proc1) 56))
  • release/4/srfi-29/trunk/srfi-29.meta

    r31582 r34213  
    1111  (setup-helper "1.5.4")
    1212  (miscmacros "2.91")
    13   (variable-item "1.3.0")
    1413  (posix-utils "1.0.0")
    1514  (lookup-table "1.13.1")
  • release/4/srfi-29/trunk/srfi-29.scm

    r34115 r34213  
    11;;;; srfi-29.scm
     2;;;; Kon Lovett, Jun '17
     3;;;; Kon Lovett,
    24;;;; Kon Lovett, Dec '05
    35
     
    1921(module srfi-29
    2022
    21   (;export
    22     ; SRFI 29
    23     current-language
    24     current-country
    25     current-locale-details
    26     load-bundle!
    27     store-bundle!
    28     declare-bundle!
    29     localized-template
    30     ; Extensions
    31     undefined-condition? unbound-variable-condition?
    32     system-bundle-directory
    33     most-specific-bundle-specifier
    34     required-localized-template
    35     localized-template/default
    36     make-required-localized-template
    37     make-localized-template
    38     make-localized-template/default
    39     localized-template-set!
    40     load-localized-compiled-code
    41     remove-bundle!
    42     undeclare-bundle!
    43     reset-locale-parameters
    44     remove-bundle-directory!
    45     load-best-available-bundle!
    46     current-locale-format-function
    47     localized-format
    48     localized-templates
    49     declared-bundle-specifiers
    50     declared-bundle-templates)
    51 
    52   (import
    53     scheme chicken
    54     (only srfi-1
    55       map! reverse! every drop-right!
    56       remove remove! fold list-copy)
    57     (only srfi-13
    58       string-downcase)
    59     (only extras
    60       format)
    61     (only data-structures
    62       intersperse conc ->string)
    63     (only files
    64       delete-file*
    65       make-pathname pathname-directory)
    66     (only posix
    67       directory? create-directory delete-directory directory)
    68     (only lookup-table
    69       make-dict dict-ref dict-set! dict-delete!
    70       dict->alist alist->dict
    71       dict-keys
    72       dict-safe-mode)
    73     (only miscmacros if*)
    74     (only locale
    75       current-locale-components locale-component-ref)
    76     (only posix-utils environment-variable-true?)
    77     (only condition-utils
    78       make-exn-condition+ make-condition-predicate)
    79     (only type-errors
    80       error-argument-type )
    81     (only type-checks
    82       check-procedure check-symbol check-string check-list
    83       define-check+error-type) )
    84 
    85   (require-library
    86     srfi-1 srfi-13 extras data-structures files posix
    87     lookup-table miscmacros locale posix-utils
    88     condition-utils type-errors type-checks)
    89 
    90   (require-extension variable-item)
    91 
    92   (declare
    93     (bound-to-procedure
    94       ##sys#symbol-has-toplevel-binding?
    95       ; Forward references
    96       most-specific-bundle-specifier
    97       invalidate-package-bundle-cache))
     23(;export
     24  ; SRFI 29
     25  current-language
     26  current-country
     27  current-locale-details
     28  load-bundle!
     29  store-bundle!
     30  declare-bundle!
     31  localized-template
     32  ; Extensions
     33  undefined-condition? unbound-variable-condition?
     34  system-bundle-directory
     35  most-specific-bundle-specifier
     36  required-localized-template
     37  localized-template/default
     38  make-required-localized-template
     39  make-localized-template
     40  make-localized-template/default
     41  localized-template-set!
     42  load-localized-compiled-code
     43  remove-bundle!
     44  undeclare-bundle!
     45  reset-locale-parameters
     46  remove-bundle-directory!
     47  load-best-available-bundle!
     48  current-locale-format-function
     49  localized-format
     50  localized-templates
     51  declared-bundle-specifiers
     52  declared-bundle-templates)
     53
     54(import scheme)
     55
     56(import
     57  chicken
     58  (only srfi-1
     59    first second third
     60    map! reverse! every drop-right!
     61    remove remove! fold list-copy)
     62  (only srfi-13
     63    string-downcase)
     64  (only extras
     65    format)
     66  (only data-structures
     67    intersperse conc ->string)
     68  (only files
     69    delete-file*
     70    make-pathname pathname-directory decompose-pathname)
     71  (only posix
     72    directory? create-directory delete-directory directory))
     73(require-library
     74  srfi-1 srfi-13 extras data-structures files posix)
     75
     76(import
     77  (only lookup-table
     78    make-dict dict-ref dict-set! dict-delete!
     79    dict->alist alist->dict
     80    dict-keys
     81    dict-safe-mode)
     82  (only miscmacros
     83    if* define-parameter)
     84  (only locale
     85    current-locale-components locale-component-ref)
     86  (only posix-utils environment-variable-true?)
     87  (only condition-utils
     88    make-exn-condition+ make-condition-predicate)
     89  (only type-errors
     90    error-argument-type )
     91  (only type-checks
     92    check-procedure check-symbol check-string check-list
     93    define-check+error-type) )
     94(require-library
     95  lookup-table miscmacros locale posix-utils
     96  condition-utils type-errors type-checks)
     97
     98;(require-extension variable-item)
     99
     100(declare
     101  (bound-to-procedure
     102    ##sys#symbol-has-toplevel-binding?))
    98103
    99104;;;
    100105
     106;used to stop the replacement of the 'package-bundle-cache'
     107;during initialization (ugh)
    101108(define *LOADTIME* #t)
    102109
     
    123130(define create-pathname-directory (cut create-directory <> #t))
    124131
    125 ;;; Constants
     132(define (pathname? obj)
     133  (and
     134    (string? obj)
     135    (let-values (((dir fil ext) (decompose-pathname obj)))
     136      ;ext w/o dir/fil indicates a *nix "hidden" file (too broad for Windows?)
     137      (or dir fil ext) ) ) )
     138
     139;; Bundle Pathname
     140
     141(define-constant TLS-ENVIRONMENT-VARIABLE "SRFI29_TLS")
    126142
    127143(define-constant DEFAULT-BUNDLE-DIR "srfi-29-bundles")
     
    132148;is [<language> [<country> [<details>...]]] (package-name).
    133149
    134 (define SYSTEM-BUNDLES (make-pathname (repository-path) DEFAULT-BUNDLE-DIR))
    135 
    136 ;; Query it
    137 
    138 (define (system-bundle-directory) SYSTEM-BUNDLES)
     150(define +default-system-bundles+ (make-pathname (repository-path) DEFAULT-BUNDLE-DIR))
     151
     152;; Where
     153
     154(define-parameter system-bundle-directory +default-system-bundles+
     155  (lambda (x)
     156    (if (pathname? x)
     157      x
     158      (error 'system-bundle-directory "invalid directory" x) ) ) )
    139159
    140160;;; Errors
     
    257277;A subset of the `localization-bundles'
    258278
    259 (define invalidate-package-bundle-cache)
    260 (define cached-package-bundle)
    261 (if (environment-variable-true? "SRFI29_TLS")
    262 
    263   ;then use a parameter for the cache
    264   ;so one bundle per package per thread
    265   (let ((package-bundle-cache (make-parameter (make-dict eq?))))
    266 
    267     (set! invalidate-package-bundle-cache (lambda args
    268       (if (null? args) (package-bundle-cache (make-dict eq?))
    269         ;else args is (bndl-spec)
    270         (dict-delete! (package-bundle-cache) (caar args)) ) ) )
    271 
    272     (set! cached-package-bundle (lambda (pkgnam)
    273       (or (dict-ref (package-bundle-cache) pkgnam)
    274           (let loop ((bndl-spec (most-specific-bundle-specifier pkgnam)))
    275             (and (not (null? bndl-spec))
    276                  (if* (bundle-ref bndl-spec)
    277                       (begin
    278                         (dict-set! (package-bundle-cache) pkgnam it)
    279                         it )
    280                       (loop (drop-right! bndl-spec 1)) ) ) ) ) ) ) )
    281 
    282   ;else one bundle per package
    283   (let ((package-bundle-cache (make-dict eq?)))
    284 
    285     (set! invalidate-package-bundle-cache (lambda args
    286       (if (null? args) (set! package-bundle-cache (make-dict eq?))
    287         ;else args is (bndl-spec)
    288         (dict-delete! package-bundle-cache (caar args)) ) ) )
    289 
    290     (set! cached-package-bundle (lambda (pkgnam)
    291       (or (dict-ref package-bundle-cache pkgnam)
    292           (let loop ((bndl-spec (most-specific-bundle-specifier pkgnam)))
    293             (and (not (null? bndl-spec))
    294                  (if* (bundle-ref bndl-spec)
    295                       (begin
    296                         (dict-set! package-bundle-cache pkgnam it)
    297                         it )
    298                       (loop (drop-right! bndl-spec 1)) ) ) ) ) ) ) ) )
     279;parameter interface
     280(define package-bundle-cache
     281  ;NOTE *LOADTIME* is #t here
     282  (let ((dict (make-dict eq?)))
     283    (if (environment-variable-true? TLS-ENVIRONMENT-VARIABLE)
     284      ;then use a parameter for the cache so one bundle per package per thread
     285      (make-parameter dict)
     286      ;else one bundle per package
     287      (let ((cur-dict dict))
     288        (lambda args
     289          (let-optionals args ((new-dict #f))
     290            (if new-dict
     291              (set! cur-dict new-dict)
     292              cur-dict ) ) ) ) ) ) )
     293
     294(define (invalidate-package-bundle-cache . args)
     295  (if (null? args)
     296    (package-bundle-cache (make-dict eq?))
     297    ;else args is (bndl-spec)
     298    (dict-delete! (package-bundle-cache) (caar args)) ) )
     299
     300(define (cached-package-bundle pkgnam)
     301  (let ((pkg-dict (package-bundle-cache)))
     302    (or
     303      (dict-ref pkg-dict pkgnam)
     304      (let loop ((bndl-spec (most-specific-bundle-specifier pkgnam)))
     305        (and
     306          (not (null? bndl-spec))
     307          (if* (bundle-ref bndl-spec)
     308            (begin
     309              (dict-set! pkg-dict pkgnam it)
     310              it )
     311            (loop (drop-right! bndl-spec 1)) ) ) ) ) ) )
    299312
    300313;;; Locale Parameters
     
    304317;; The initial procedure is the builtin
    305318
    306 (define-checked-variable current-locale-format-function format procedure)
     319(define-parameter current-locale-format-function format
     320  (lambda (x)
     321    (if (procedure? x)
     322      x
     323      (error 'current-locale-format-function "invalid procedure" x) ) ) )
    307324
    308325;; The default language, country, and locale-details
     
    337354;; If template undefined returns the template default (defaults #f).
    338355
    339 (define (localized-template pkgnam tptnam #!optional defpkg deftpt)
     356(define (localized-template pkgnam tplnam #!optional defpkg deftpl)
    340357  (if* (cached-package-bundle pkgnam)
    341     (dict-ref it tptnam deftpt)
     358    (dict-ref it tplnam deftpl)
    342359    defpkg ) )
    343360
     
    347364;; If template undefined returns the template default (defaults template-name).
    348365
    349 (define (localized-template/default pkgnam tptnam #!optional (defpkg tptnam) (deftpt tptnam))
    350   (localized-template pkgnam tptnam defpkg deftpt) )
     366(define (localized-template/default pkgnam tplnam #!optional (defpkg tplnam) (deftpl tplnam))
     367  (localized-template pkgnam tplnam defpkg deftpl) )
    351368
    352369;; Returns the localized template from the most specific bundle given
     
    358375(define NO-TEMPLATE-TAG '#(no-template))
    359376
    360 (define (*required-localized-template loc pkgnam tptnam)
    361   (let ((res (localized-template pkgnam tptnam NO-PACKAGE-TAG NO-TEMPLATE-TAG)))
     377(define (*required-localized-template loc pkgnam tplnam)
     378  (let ((res (localized-template pkgnam tplnam NO-PACKAGE-TAG NO-TEMPLATE-TAG)))
    362379    (cond
    363380      ((eq? res NO-PACKAGE-TAG)
    364381        (error-undefined loc "undefined package" pkgnam) )
    365382      ((eq? res NO-TEMPLATE-TAG)
    366         (error-undefined loc "undefined template in package" tptnam pkgnam) )
     383        (error-undefined loc "undefined template in package" tplnam pkgnam) )
    367384      (else
    368385        res ) ) ) )
    369386
    370 (define (required-localized-template pkgnam tptnam)
    371   (*required-localized-template 'required-localized-template pkgnam tptnam) )
     387(define (required-localized-template pkgnam tplnam)
     388  (*required-localized-template 'required-localized-template pkgnam tplnam) )
    372389
    373390;; Returns a procedure the looks up a template in a fixed package
    374391
    375 (define ((make-required-localized-template pkgnam) tptnam)
    376   (required-localized-template pkgnam tptnam) )
    377 
    378 (define ((make-localized-template pkgnam) tptnam #!optional defpkg deftpt)
    379   (localized-template pkgnam tptnam defpkg deftpt) )
     392(define ((make-required-localized-template pkgnam) tplnam)
     393  (required-localized-template pkgnam tplnam) )
     394
     395(define ((make-localized-template pkgnam) tplnam #!optional defpkg deftpl)
     396  (localized-template pkgnam tplnam defpkg deftpl) )
    380397
    381398(define ((make-localized-template/default pkgnam)
    382           tptnam #!optional (defpkg tptnam) (deftpt tptnam))
    383   (localized-template pkgnam tptnam) )
     399          tplnam #!optional (defpkg tplnam) (deftpl tplnam))
     400  (localized-template pkgnam tplnam) )
    384401
    385402;; Returns the application of the default 'format' procedure to the
     
    389406;; relevant details is made to proper destination.
    390407
    391 (define (localized-format pkgnam tptnam . fmtargs)
    392 
    393   (define (format-info-string pkgnam tptnam fmtargs)
     408(define (localized-format pkgnam tplnam . fmtargs)
     409
     410  (define (format-info-string pkgnam tplnam fmtargs)
    394411    (conc
    395412      #\[
    396         #\< pkgnam #\space tptnam #\>
     413        #\< pkgnam #\space tplnam #\>
    397414        #\space
    398415        (apply conc (intersperse fmtargs #\space))
     
    401418  (let ((fmtstr
    402419          (or
    403             (localized-template pkgnam tptnam)
    404             (and (string? tptnam) tptnam))))
     420            (localized-template pkgnam tplnam)
     421            (and (string? tplnam) tplnam))))
    405422    (if fmtstr
    406423      (apply (current-locale-format-function) fmtstr fmtargs)
    407       (format-info-string pkgnam tptnam fmtargs) ) ) )
     424      (format-info-string pkgnam tplnam fmtargs) ) ) )
    408425
    409426;; Create or update the value for a template in an existing package.
    410427;; Returns #t for success & #f when no such package.
    411428
    412 (define (localized-template-set! pkgnam tptnam value)
     429(define (localized-template-set! pkgnam tplnam value)
    413430  (and-let* ((bndl (cached-package-bundle pkgnam)))
    414     (dict-set! bndl tptnam value)
     431    (dict-set! bndl tplnam value)
    415432    #t ) )
    416433
     
    468485;;
    469486
     487(define (load-localized-compiled-code libspec pkgnam vartplnams)
     488  (check-package-name 'load-localized-compiled-code pkgnam)
     489  (*load-localized-compiled-code
     490    libspec
     491    pkgnam
     492    (check-template-variable-names 'load-localized-compiled-code pkgnam vartplnams)) )
     493
     494(define (*load-localized-compiled-code libspec pkgnam vartplnams)
     495  (*load-code 'load-localized-compiled-code libspec)
     496  (fixup-references 'load-localized-compiled-code pkgnam vartplnams) )
     497
     498;;
     499
    470500;There must be a better way using sys namespace operations.
    471 ;(Chicken 4.2.2 had a query for ALL loaded binaries)
     501;(Chicken 4.2.2 had a query for ALL loaded binaries. KRL dloader branch still
     502;does.)
    472503
    473504; A `library-name' is a pathname or unitname.
    474505(define +loaded-library-names+ '())
    475506
    476 (define (load-code loc libspec)
     507(define (*load-code loc libspec)
    477508  (let ((unit
    478509          (if (not (pair? libspec))
    479510            (and (symbol? libspec) libspec)
    480             (and (pair? libspec) (symbol? (car libspec)) (car libspec)) ) )
     511            (and (pair? libspec) (symbol? (first libspec)) (first libspec)) ) )
    481512        (path
    482           (if (not (pair? libspec))
    483             (and (string? libspec) libspec)
    484             (and (string? (cadr libspec)) libspec) ) ) )
     513          (and (string? (if (pair? libspec) (second libspec) libspec)) libspec) ) )
    485514    ; A pathname is preferred to a unitname
    486515    (let ((the-name (or path unit)))
     
    493522          (unit
    494523            (load-library unit) )
    495           ; Must be absolute pathaname, otherwise pathname is relative to
    496           ; "current file"
     524          ;Must be absolute pathaname, otherwise pathname is relative to
     525          ;the "current file"
    497526          (path
    498527            (load-relative path) )
     
    501530        (set! +loaded-library-names+ (cons the-name +loaded-library-names+)) ) ) ) )
    502531
    503 (define (fixup-references loc pkgnam vartptnams)
     532(define (fixup-references loc pkgnam vartplnams)
    504533  (for-each
    505     (lambda (tptnam)
     534    (lambda (tplnam)
    506535      (localized-template-set!
    507         pkgnam tptnam
    508         (required-global-ref loc (required-localized-template pkgnam tptnam))) )
    509     vartptnams) )
    510 
    511 ;;
    512 
    513 (define (*load-localized-compiled-code libspec pkgnam vartptnams)
    514   (load-code 'load-localized-compiled-code libspec)
    515   (fixup-references 'load-localized-compiled-code pkgnam vartptnams) )
    516 
    517 ;;
    518 
    519 (define (load-localized-compiled-code libspec pkgnam vartptnams)
    520   (check-package-name 'load-localized-compiled-code pkgnam)
    521   (*load-localized-compiled-code
    522     libspec
    523     pkgnam
    524     (check-template-variable-names 'load-localized-compiled-code pkgnam vartptnams)) )
     536        pkgnam tplnam
     537        (required-global-ref loc (required-localized-template pkgnam tplnam))) )
     538    vartplnams) )
    525539
    526540;;; Bundle Operations
     
    552566
    553567(define (load-bundle! bndl-spec . args)
    554   (let-optionals args ((alt-dir SYSTEM-BUNDLES))
     568  (let-optionals args ((alt-dir (system-bundle-directory)))
    555569    (let ((path
    556570            (need-bundle-absolute-pathname
     
    563577
    564578(define (store-bundle! bndl-spec . args)
    565   (let-optionals args ((alt-dir SYSTEM-BUNDLES))
     579  (let-optionals args ((alt-dir (system-bundle-directory)))
    566580    (let ((path
    567581            (need-bundle-absolute-pathname
     
    577591
    578592(define (remove-bundle! bndl-spec . args)
    579   (let-optionals args ((alt-dir SYSTEM-BUNDLES))
     593  (let-optionals args ((alt-dir (system-bundle-directory)))
    580594    (let ((path
    581595            (need-bundle-absolute-pathname
     
    588602
    589603(define (remove-bundle-directory! bndl-spec . args)
    590   (let-optionals args ((alt-dir SYSTEM-BUNDLES))
     604  (let-optionals args ((alt-dir (system-bundle-directory)))
    591605    (let ((path (need-bundle-absolute-pathname
    592606                  'remove-bundle-directory! bndl-spec alt-dir)))
     
    606620
    607621(define (load-best-available-bundle! bndl-spec . args)
    608   (let-optionals args ((alt-dir SYSTEM-BUNDLES))
     622  (let-optionals args ((alt-dir (system-bundle-directory)))
    609623    (let loop ((bndl-spec
    610624                (check-bundle-specifier
  • release/4/srfi-29/trunk/srfi-29.setup

    r34115 r34213  
    99  (file-chmod (srfi-29-bundles-home) 'a+rx) )
    1010
    11 (setup-shared-extension-module 'srfi-29 (extension-version "2.3.3")
     11(setup-shared-extension-module 'srfi-29 (extension-version "2.4.0")
    1212  #:inline? #t
    1313  #:types? #t
    1414  #:compile-options '(
    15     -disable-interrupts ; We got shared data but might not be necessary
     15    ;-disable-interrupts ;got shared data but might not be necessary; all params now?
    1616    -fixnum-arithmetic
    1717    -O3 -d1
  • release/4/srfi-29/trunk/tests/run.scm

    r23815 r34213  
    11;;;; srfi-29-test.scm
    22
    3 ;To use w/ TSL:
     3;To use w/ TLS:
    44;(cd .../srfi-29/trunk/tests; \
    55;sudo csi -n -R posix -e '(setenv "SRFI29_TLS" "1")' -s run.scm)
     
    1010
    1111(define (allow-sysops?)
    12   (or (eq? 'windows (software-type))
    13       (= 0 (current-effective-user-id))) )
     12  (or
     13    (eq? 'windows (software-type))
     14    (= 0 (current-effective-user-id))) )
    1415
    1516(test-group "SRFI 29 Basics"
     
    4647      (test-assert "" (declare-bundle! '(srfi-29-test foo bar) bal3))
    4748
    48       (test "declared-bundle-specifiers (problematic since assumes internal list order)"
     49      (test "declared-bundle-specifiers (uses internal list order; brittle)"
    4950            '((srfi-29-test foo bar) (srfi-29-test foo) (srfi-29-test))
    5051            (declared-bundle-specifiers))
     
    9192    (when (allow-sysops?)
    9293      (test-group "Bundles System Directory"
    93  
     94
    9495        (test-assert "B16" (declare-bundle! '(srfi-29-test) bal1))
    9596        (test-assert "B17" (declare-bundle! '(srfi-29-test foo) bal2))
    9697        (test-assert "B18" (declare-bundle! '(srfi-29-test foo bar) bal3))
    97  
     98
    9899        (test-assert "B19" (store-bundle! '(srfi-29-test)))
    99100        (test-assert "B20" (store-bundle! '(srfi-29-test foo)))
    100101        (test-assert "B21" (store-bundle! '(srfi-29-test foo bar)))
    101  
     102
    102103        (test-assert "B22" (undeclare-bundle! '(srfi-29-test)))
    103104        (test-assert "B23" (undeclare-bundle! '(srfi-29-test foo)))
    104105        (test-assert "B24" (undeclare-bundle! '(srfi-29-test foo bar)))
    105  
     106
    106107        (test-assert "B25.1" (not (localized-template 'srfi-29-test 'foo1)))
    107108        (test-assert "B26.1" (not (localized-template 'srfi-29-test "bar1")))
    108109        (test-assert "B27.1" (not (localized-template 'srfi-29-test 'baz1)))
    109  
     110
    110111        (test-assert "B22.1" (load-bundle! '(srfi-29-test)))
    111112        (test-assert "B23.1" (load-bundle! '(srfi-29-test foo)))
    112113        (test-assert "B24.1" (load-bundle! '(srfi-29-test foo bar)))
    113  
     114
    114115        (test "B25" 1 (localized-template 'srfi-29-test 'foo1))
    115116        (test "B26" 2 (localized-template 'srfi-29-test "bar1"))
    116117        (test "B27" 3 (localized-template 'srfi-29-test 'baz1))
    117  
     118
    118119        (test "localized-templates" bal1 (localized-templates 'srfi-29-test))
    119  
     120
    120121        (current-language 'foo)
    121  
     122
    122123        (test "B28" 4 (localized-template 'srfi-29-test 'foo2))
    123124        (test "B29" 5 (localized-template 'srfi-29-test "bar2"))
    124125        (test "B30" 6 (localized-template 'srfi-29-test 'baz2))
    125  
     126
    126127        (test "localized-templates language foo" bal2 (localized-templates 'srfi-29-test))
    127  
     128
    128129        (current-country 'bar)
    129  
     130
    130131        (test "B31" 7 (localized-template 'srfi-29-test 'foo3))
    131132        (test "B32" 8 (localized-template 'srfi-29-test "bar3"))
    132133        (test "B33" 9 (localized-template 'srfi-29-test 'baz3))
    133  
     134
    134135        (test "localized-templates language foo, country bar"
    135136          bal3 (localized-templates 'srfi-29-test))
    136  
     137
    137138        (test-assert "B37.1" (localized-template-set! 'srfi-29-test 'baz3 'foobar))
    138139        (test "B37.2" 'foobar (localized-template 'srfi-29-test 'baz3))
     
    140141        (test-assert "B37.4" (localized-template-set! 'srfi-29-test 'barf 16))
    141142        (test "B37.5" 16 (localized-template 'srfi-29-test 'barf))
    142  
     143
    143144        (test-assert "B34" (remove-bundle! '(srfi-29-test)))
    144145        (test-assert "B35" (remove-bundle! '(srfi-29-test foo)))
    145146        (test-assert "B36" (remove-bundle! '(srfi-29-test foo bar)))
    146  
     147
    147148        (test-assert "SysDir RmDir" (remove-bundle-directory! '(srfi-29-test foo bar)))
    148  
     149
    149150        (reset-locale-parameters)
    150151      )
     
    158159
    159160(test-group "SRFI 29 Logic"
    160  
     161
    161162  ;compile logic
    162163  (system "csc -s test-logic")
    163  
     164
    164165  ;declare logic pkg
    165166  (declare-bundle! '(srfi-29-test)
     
    177178    'srfi-29-test
    178179    '(proc0 proc1 procN proc*))
    179  
     180
    180181  ;test logic
    181182  (test-assert (procedure? (!item@ 'proc0)))
     
    183184  (test-assert (procedure? (!item@ 'procN)))
    184185  (test-assert (procedure? (!item@ 'proc*)))
    185  
     186
    186187  (test 0 ((!item@ 'proc0)))
    187188  (test -56 ((!item@ 'proc1) 56))
Note: See TracChangeset for help on using the changeset viewer.