Changeset 12792 in project


Ignore:
Timestamp:
12/08/08 07:05:31 (13 years ago)
Author:
Kon Lovett
Message:

Save.

Location:
release/3/srfi-29/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/3/srfi-29/trunk/srfi-29-eggdoc.scm

    r12015 r12792  
    5959      (code "[LANGUAGE [COUNTRY [SCRIPT [CODESET [MODIFIER]]]]] PACKAGE-NAME") ".")
    6060
    61       (p "The default language is " (code "en") ". The default country is " (code "us") ". "
    62       "The locale package will override these if a locale is set. Otherwise "
    63       "the user must set the corresponding parameters.")
    64 
    6561      (p "Any object which can be returned by " (code "(read)") " and tested for equality "
    6662      "with " (code "equal?") " is acceptable as a " (tt "TEMPLATE-NAME") ". "
     
    6965      (code "(read)") ", not just a string.")
    7066
    71       (p "Aborts with the composite condition " (code "(exn srfi-29)") " and properties "
    72       (code "location") ", " (code "message") ", and " (code "arguments") " for errors.")
     67      (p "This implementation uses the "
     68      (url "http://www.call-with-current-continuation.org/eggs/locale.html" locale") " "
     69      "extension for all locale information.")
     70
     71      (subsection "Exceptions"
     72
     73        (p "Extension error conditions are signaled with a composite condition of "
     74        (code "(exn srfi-29)") ".")
     75
     76        (p "The property-condition " (code "exn") " has properties "
     77        (code "location") ", " (code "message") ", and, optionally, " (code "arguments") ".")
     78
     79        (p "An invalid bundle-specification raises the composite-condition "
     80        (code "(exn srfi-29 insufficient)") ".")
     81
     82        (p "An unknown bundle-specification raises the composite-condition "
     83        (code "(exn srfi-29 undefined)") ".")
     84      )
    7385
    7486      (subsection "Parameters"
     
    183195      "3 element list " (code "(SCRIPT CODESET MODIFIER)") " where the "
    184196      "elements are symbols or " (code "#f") ".")
     197
     198      (p "The SRFI 29 document uses the term \"country\" for what the locale extension knows "
     199      "as \"region\".")
    185200    )
    186201
     
    189204
    190205    (history
     206     (version "1.14.0" "Pushed defaults to locale egg.")
    191207     (version "1.13.0" "Needs new Egg lookup-table.")
    192208     (version "1.12.0" "Needed Unit files. Procedure 'localized-format' did not follow specification.")
  • release/3/srfi-29/trunk/srfi-29.scm

    r12017 r12792  
    5252      localized-template ) ) )
    5353
    54 (use srfi-1 srfi-12 srfi-13 posix files
    55      miscmacros lookup-table locale misc-extn-directory)
     54(require-extension
     55  srfi-1 srfi-12 srfi-13 posix files
     56  miscmacros lookup-table locale misc-extn-directory)
    5657
    5758(register-feature! 'srfi-29)
    5859
    5960;;;
     61
     62;;
     63
     64(define (display/port obj port)
     65  (cond [(port? port)                     (display obj port)]
     66        [(or (string? port) (not port))   (->string obj)]
     67        [else                             (display obj) ] ) )
    6068
    6169;;
     
    7280(define SYSTEM-BUNDLES (make-pathname (repository-path) DEFAULT-BUNDLE-DIR))
    7381
    74 ;; Um, the user really should set a locale
    75 
    76 (define LANGUAGE-DEFAULT 'en)
    77 (define COUNTRY-DEFAULT 'us)
    78 
    79 ;;
    80 
    81 (define (make-srfi-29-exception loc msg . args)
     82;;
     83
     84(define (make-exn-condition loc msg . args)
     85  (if (null? args)
     86      (make-property-condition 'exn 'message msg 'location loc)
     87      (make-property-condition 'exn 'message msg 'location loc 'arguments args) ) )
     88
     89(define *srfi-29-condition* (make-property-condition 'srfi-29))
     90
     91(define *insufficient-condition* (make-property-condition 'insufficient))
     92
     93(define *undefined-condition* (make-property-condition 'undefined))
     94
     95(define (make-exn-srfi-29-condition loc msg . args)
    8296  (make-composite-condition
    83    (make-property-condition 'exn 'message msg 'location loc 'arguments args)
    84    (make-property-condition 'srfi-29)) )
    85 
    86 (define (signal-srfi-29-exception loc msg . args)
    87   (abort (apply make-srfi-29-exception loc msg args)) )
     97   (apply make-exn-condition loc msg args)
     98   *srfi-29-condition*) )
     99
     100#; ;UNUSED
     101(define (raise-exception loc msg . args)
     102  (abort (apply make-exn-srfi-29-condition loc msg args)) )
     103
     104(define (raise-insufficient-exception loc msg . args)
     105  (abort
     106   (make-composite-condition
     107    (apply make-exn-srfi-29-condition loc msg args)
     108    *insufficient-condition*)) )
     109
     110(define (raise-undefined-exception loc msg . args)
     111  (abort
     112   (make-composite-condition
     113    (apply make-exn-srfi-29-condition loc msg args)
     114    *undefined-condition*)) )
    88115
    89116;;
    90117
    91118(define-inline (locale-item? x)
    92   (or (not x) (symbol? x)) )
     119  (or (not x)
     120      (symbol? x)) )
    93121
    94122(define-inline (locale-details? obj)
     
    96124       (every locale-item? obj)) )
    97125
     126(define (coerce-locale-item obj)
     127  (cond [(locale-item? obj) obj]
     128        [(string? obj)      (string->symbol (string-downcase obj))]
     129        [else               (->symbol obj) ] ) )
     130
     131(define (cons-locale-item lci lst)
     132  (if lci
     133      (cons (symbol->string lci) lst)
     134      lst ) )
     135
    98136;; bundle-specifier: (list-of symbol)
    99 ;; i.e. package + locale, (package-name [language] [country] [details ...])
     137;; i.e. package + locale: (package-name [language] [country] [details ...])
     138
     139(define (bundle-specification-directory bundle-specifier)
     140  (reverse! (fold cons-locale-item '() (cdr bundle-specifier))) )
     141
     142(define (bundle-specification-filename bundle-specifier)
     143  (symbol->string (car bundle-specifier)) )
    100144
    101145(define (bundle-specification->pathname bundle-specifier)
    102   (if (null? bundle-specifier)
    103       (signal-srfi-29-exception 'load-bundle! "must specify package name" bundle-specifier)
    104       (make-pathname
    105        (reverse!
    106         (fold (lambda (x l) (if x (cons (symbol->string x) l) l)) '() (cdr bundle-specifier)))
    107        (symbol->string (car bundle-specifier))) ) )
     146  (make-pathname (bundle-specification-directory bundle-specifier)
     147                 (bundle-specification-filename bundle-specifier)) )
    108148
    109149(define-inline (bundle-specification->absolute-pathname bundle-specifier alternate-dir)
     
    147187
    148188(define (locale-ref what)
    149   (let ([locale
    150           (current-locale-components)]
    151         [as-sym
    152           (lambda (v)
    153             (cond [(locale-item? v)  v]
    154                   [(string? v)       (string->symbol (string-downcase v))]
    155                   [else              (->symbol v)]) ) ] )
    156     (select what
    157       [('language)
    158         (as-sym (locale-component-ref locale 'language LANGUAGE-DEFAULT))]
    159       [('country)
    160         (as-sym (locale-component-ref locale 'region COUNTRY-DEFAULT))]
     189  (let ([lc (current-locale-components)])
     190    (case what
     191      [(details)
     192        (list (locale-ref 'script) (locale-ref 'codeset) (locale-ref 'modifier))]
    161193      [else
    162         `(,(as-sym (locale-component-ref locale  'script))
    163           ,(as-sym (locale-component-ref locale  'codeset))
    164           ,(as-sym (locale-component-ref locale  'modifier))) ] ) ) )
     194        (coerce-locale-item (locale-component-ref lc what)) ] ) ) )
    165195
    166196;;; Locale Parameters
     
    194224
    195225(define-parameter current-country
    196   (locale-ref 'country)
     226  (locale-ref 'region)
    197227  (lambda (x)
    198228    (cond [(locale-item? x)
     
    222252(define (reset-locale-parameters)
    223253  (current-language (locale-ref 'language))
    224   (current-country (locale-ref 'country))
     254  (current-country (locale-ref 'region))
    225255  (current-locale-details (locale-ref 'details)) )
    226256
     
    250280;; Returns the application of the default 'format' procedure to the
    251281;; supplied arguments, using the package template as the format-string.
     282;;
    252283;; When a format-string is unavailable an emergency display of the
    253284;; relevant details is made to proper destination.
    254285
    255286(define (localized-format package-name template-name port . fmtargs)
     287
     288  (define (format-info-string package-name template-name fmtargs)
     289    (conc #\[ package-name #\/ template-name
     290              #\space
     291              (apply conc (intersperse fmtargs #\space))
     292          #\]) )
     293
    256294  (let ([fmtstr (or (localized-template package-name template-name)
    257295                    (and (string? template-name)
     
    259297    (if fmtstr
    260298        (apply (current-locale-format-function) port fmtstr fmtargs)
    261         (let ([str (conc #\[ package-name #\/ template-name
    262                              #\space
    263                              (apply conc (intersperse fmtargs #\space))
    264                          #\])])
    265           (cond [(port? port)                     (display str port)]
    266                 [(or (string? port) (not port))   str]
    267                 [else                             (display str) ] ) ) ) ) )
     299        (display/port (format-info-string package-name template-name fmtargs) port) ) ) )
    268300
    269301;; Create or update the value for a template in an existing package.
     
    287319  #t )
    288320
     321;; Error checking versions
     322
     323(define (need-bundle loc bundle-specifier)
     324  (or (find-bundle bundle-specifier)
     325      (raise-undefined-exception loc "undeclared bundle specification" bundle-specifier)) )
     326
     327(define (check-bundle-specifier loc obj)
     328  (unless (and (list? obj) (not (null? obj)))
     329    (raise-insufficient-exception loc "null bundle specification" obj) ) )
     330
     331(define (need-bundle-absolute-pathname loc bundle-specifier alternate-dir)
     332  (check-bundle-specifier loc bundle-specifier)
     333  (bundle-specification->absolute-pathname bundle-specifier alternate-dir) )
     334
    289335;; Reads bundle file & declares.
    290336
    291337(define (load-bundle! bundle-specifier . alternate-dir)
    292   (let ([path (bundle-specification->absolute-pathname bundle-specifier alternate-dir)])
     338  (let ([path (need-bundle-absolute-pathname 'load-bundle! bundle-specifier alternate-dir)])
    293339    (and (file-exists? path)
    294340         (declare-bundle! bundle-specifier (with-input-from-file path read)) ) ) )
     
    297343
    298344(define (store-bundle! bundle-specifier . alternate-dir)
    299   (let ([path (bundle-specification->absolute-pathname bundle-specifier alternate-dir)]
    300         [bundle (find-bundle bundle-specifier)] )
    301     (unless bundle
    302       (signal-srfi-29-exception 'store-bundle! "no such declared bundle" bundle-specifier) )
     345  (let ([path (need-bundle-absolute-pathname 'store-bundle! bundle-specifier alternate-dir)]
     346        [bundle (need-bundle 'store-bundle! bundle-specifier)] )
    303347    (create-pathname-directory path)
    304348    (delete-file* path)
     
    309353
    310354(define (remove-bundle! bundle-specifier . alternate-dir)
    311   (let ([path (bundle-specification->absolute-pathname bundle-specifier alternate-dir)])
     355  (let ([path (need-bundle-absolute-pathname 'remove-bundle! bundle-specifier alternate-dir)])
    312356    (reset-bundle! bundle-specifier)
    313357    (delete-file* path)
     
    317361
    318362(define (remove-bundle-directory! bundle-specifier . alternate-dir)
    319   (let ([pathname (bundle-specification->absolute-pathname bundle-specifier alternate-dir)])
    320     (delete-file* pathname)
     363  (let ([path (need-bundle-absolute-pathname 'remove-bundle-directory! bundle-specifier alternate-dir)])
     364    (delete-file* path)
    321365    (let ([topdir (optional alternate-dir SYSTEM-BUNDLES)])
    322       (let loop ([path pathname])
     366      (let loop ([path path])
    323367        (let* ([dir (pathname-directory path)]
    324368               [fillst (directory dir)])
     
    332376
    333377(define (load-best-available-bundle! bundle-specifier . alternate-dir)
     378  (check-bundle-specifier 'load-best-available-bundle! bundle-specifier)
    334379  (let loop ([specifier (remove not bundle-specifier)])
    335380    (and (not (null? specifier))
  • release/3/srfi-29/trunk/srfi-29.setup

    r12015 r12792  
    11(include "setup-header")
     2
     3(required-chicken-version "3.4.0")
    24
    35(required-extension-version
    46  'misc-extn              "3.1"
    5   'locale                 "0.3.1"
     7  'locale                 "0.4.0"
    68  'lookup-table           "1.7"
    79  'miscmacros             "2.4")
Note: See TracChangeset for help on using the changeset viewer.