Changeset 13897 in project


Ignore:
Timestamp:
03/24/09 18:05:25 (11 years ago)
Author:
Kon Lovett
Message:

Canonical naming for explicit inlines. [] -> ().

File:
1 edited

Legend:

Unmodified
Added
Removed

  • release/3/srfi-29/trunk/srfi-29.scm

    r12792 r13897  
    1818
    1919;; Within the bundle directory the structure
    20 ;; is [(language) [(country) [(details)]]] (module).
     20;; is [(language) [(country) [(details)]] (module).
    2121
    2222(eval-when (compile)
    … …  
    2727    (inline)
    2828    (no-procedure-checks)
    29     (no-bound-checks)
    3029    (bound-to-procedure ; Forward references
    3130      most-specific-bundle-specifier
    3231      invalidate-package-bundle-cache )
    3332    (export
    34       ;; Extensions
     33      ; SRFI 29
     34      current-language
     35      current-country
     36      current-locale-details
     37      load-bundle!
     38      store-bundle!
     39      declare-bundle!
     40      localized-template
     41      ; Extensions
    3542      most-specific-bundle-specifier
    3643      localized-template/default
    … …  
    4249      load-best-available-bundle!
    4350      current-locale-format-function
    44       localized-format
    45       ;; SRFI 29
    46       current-language
    47       current-country
    48       current-locale-details
    49       load-bundle!
    50       store-bundle!
    51       declare-bundle!
    52       localized-template ) ) )
    53 
    54 (require-extension
    55   srfi-1 srfi-12 srfi-13 posix files
    56   miscmacros lookup-table locale misc-extn-directory)
     51      localized-format ) ) )
     52
     53(require-extension srfi-1 srfi-12 srfi-13 posix files miscmacros lookup-table locale misc-extn-directory)
    5754
    5855(register-feature! 'srfi-29)
    … …  
    6360
    6461(define (display/port obj port)
    65   (cond [(port? port)                     (display obj port)]
    66         [(or (string? port) (not port))   (->string obj)]
    67         [else                             (display obj) ] ) )
    68 
    69 ;;
    70 
    71 (define-inline (->symbol obj)
    72   (string->symbol (->string obj)) )
     62  (cond ((port? port)                     (display obj port))
     63        ((or (string? port) (not port))   (->string obj))
     64        (else                             (display obj) ) ) )
     65
     66;;
     67
     68(define-inline (%->symbol obj) (string->symbol (->string obj)))
    7369
    7470;; Constants
    … …  
    8278;;
    8379
    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))
     80(define (make-exn-condition loc msg args)
     81  (make-property-condition 'exn 'message msg 'location loc 'arguments args) )
     82
     83(define (make-srfi-29-condition) (make-property-condition 'srfi-29))
     84
     85(define (make-insufficient-condition) (make-property-condition 'insufficient))
     86
     87(define (make-undefined-condition) (make-property-condition 'undefined))
    9488
    9589(define (make-exn-srfi-29-condition loc msg . args)
    9690  (make-composite-condition
    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)
     91   (make-exn-condition loc msg args)
     92   (make-srfi-29-condition)) )
     93
     94(define (error-insufficient loc msg . args)
    10595  (abort
    10696   (make-composite-condition
    10797    (apply make-exn-srfi-29-condition loc msg args)
    108     *insufficient-condition*)) )
    109 
    110 (define (raise-undefined-exception loc msg . args)
     98    (make-insufficient-condition))) )
     99
     100(define (error-undefined loc msg . args)
    111101  (abort
    112102   (make-composite-condition
    113103    (apply make-exn-srfi-29-condition loc msg args)
    114     *undefined-condition*)) )
    115 
    116 ;;
    117 
    118 (define-inline (locale-item? x)
    119   (or (not x)
    120       (symbol? x)) )
    121 
    122 (define-inline (locale-details? obj)
    123   (and (list? obj)
    124        (every locale-item? obj)) )
     104    (make-undefined-condition))) )
     105
     106;;
     107
     108(define-inline (%locale-item? x) (or (not x) (symbol? x)))
     109
     110(define-inline (%locale-details? obj) (and (list? obj) (every %locale-item? obj)))
    125111
    126112(define (coerce-locale-item obj)
    127   (cond [(locale-item? obj) obj]
    128         [(string? obj)      (string->symbol (string-downcase obj))]
    129         [else               (->symbol obj) ] ) )
     113  (cond ((%locale-item? obj) obj)
     114        ((string? obj)      (string->symbol (string-downcase obj)))
     115        (else               (%->symbol obj) ) ) )
    130116
    131117(define (cons-locale-item lci lst)
    132   (if lci
    133       (cons (symbol->string lci) lst)
     118  (if lci (cons (symbol->string lci) lst)
    134119      lst ) )
    135120
    … …  
    147132                 (bundle-specification-filename bundle-specifier)) )
    148133
    149 (define-inline (bundle-specification->absolute-pathname bundle-specifier alternate-dir)
    150   (make-pathname (optional alternate-dir SYSTEM-BUNDLES)
    151                  (bundle-specification->pathname bundle-specifier)) )
     134(define-inline (%bundle-specification->absolute-pathname bundle-specifier alternate-dir)
     135  (make-pathname
     136   (optional alternate-dir SYSTEM-BUNDLES)
     137   (bundle-specification->pathname bundle-specifier)) )
    152138
    153139;; Bundles Dictionary
    … …  
    155141(define *localization-bundles* (make-dict equal?))
    156142
    157 (define-inline (find-bundle bundle-specifier)
     143(define-inline (%find-bundle bundle-specifier)
    158144  (dict-ref *localization-bundles* bundle-specifier) )
    159145
    160 (define-inline (set-bundle! bundle-specifier bundle-alist)
     146(define-inline (%set-bundle! bundle-specifier bundle-alist)
    161147  (dict-set! *localization-bundles* bundle-specifier (alist->dict bundle-alist equal?)) )
    162148
    163 (define-inline (reset-bundle! bundle-specifier)
     149(define-inline (%reset-bundle! bundle-specifier)
    164150  (invalidate-package-bundle-cache bundle-specifier)
    165151  (dict-delete! *localization-bundles* bundle-specifier) )
    … …  
    170156
    171157(define (invalidate-package-bundle-cache . bundle-specifier)
    172   (if (not (null? bundle-specifier))
    173       (dict-delete! *package-bundle-cache* (caar bundle-specifier))
    174       (set! *package-bundle-cache* (make-dict eq?)) ) )
     158  (if (null? bundle-specifier) (set! *package-bundle-cache* (make-dict eq?))
     159      (dict-delete! *package-bundle-cache* (caar bundle-specifier)) ) )
    175160
    176161(define (cached-package-bundle package-name)
    177162  (or (dict-ref *package-bundle-cache* package-name)
    178       (let loop ([specifier (remove! not (most-specific-bundle-specifier package-name))])
     163      (let loop ((specifier (remove! not (most-specific-bundle-specifier package-name))))
    179164        (and (not (null? specifier))
    180              (if* (find-bundle specifier)
     165             (if* (%find-bundle specifier)
    181166                  (begin
    182167                    (dict-set! *package-bundle-cache* package-name it)
    … …  
    187172
    188173(define (locale-ref what)
    189   (let ([lc (current-locale-components)])
     174  (let ((lc (current-locale-components)))
    190175    (case what
    191       [(details)
    192         (list (locale-ref 'script) (locale-ref 'codeset) (locale-ref 'modifier))]
    193       [else
    194         (coerce-locale-item (locale-component-ref lc what)) ] ) ) )
     176      ((details)
     177        (list (locale-ref 'script) (locale-ref 'codeset) (locale-ref 'modifier)))
     178      (else
     179        (coerce-locale-item (locale-component-ref lc what)) ) ) ) )
    195180
    196181;;; Locale Parameters
    … …  
    200185;; The initial procedure is the builtin
    201186
    202 (define-parameter current-locale-format-function
    203   format
     187(define-parameter current-locale-format-function format
    204188  (lambda (x)
    205     (if (procedure? x)
    206         x
     189    (if (procedure? x) x
    207190        (begin
    208191          (warning 'current-locale-format-function "invalid procedure" x)
    … …  
    211194;; The default language
    212195
    213 (define-parameter current-language
    214   (locale-ref 'language)
     196(define-parameter current-language (locale-ref 'language)
    215197  (lambda (x)
    216     (cond [(locale-item? x)
     198    (cond ((%locale-item? x)
    217199           (invalidate-package-bundle-cache)
    218            x ]
    219           [else
     200           x )
     201          (else
    220202           (warning 'current-language "invalid locale item" x)
    221            (current-language) ] ) ) )
     203           (current-language) ) ) ) )
    222204
    223205;; The default country
    224206
    225 (define-parameter current-country
    226   (locale-ref 'region)
     207(define-parameter current-country (locale-ref 'region)
    227208  (lambda (x)
    228     (cond [(locale-item? x)
     209    (cond ((%locale-item? x)
    229210           (invalidate-package-bundle-cache)
    230            x ]
    231           [else
     211           x )
     212          (else
    232213           (warning 'current-country "invalid locale item" x)
    233            (current-country) ] ) ) )
     214           (current-country) ) ) ) )
    234215
    235216;; The default locale-details
    236217
    237 (define-parameter current-locale-details
    238   (locale-ref 'details)
     218(define-parameter current-locale-details (locale-ref 'details)
    239219  (lambda (x)
    240     (cond [(locale-details? x)
     220    (cond ((%locale-details? x)
    241221           (invalidate-package-bundle-cache)
    242            x ]
    243           [else
    244             (warning 'current-locale-details "invalid locale item" x)
    245             (current-locale-details) ] ) ) )
     222           x )
     223          (else
     224           (warning 'current-locale-details "invalid locale item" x)
     225           (current-locale-details) ) ) ) )
    246226
    247227;; If you change (current-locale), you don't have to set current-*
    … …  
    264244;; Returns the localized template from the most specific bundle given
    265245;; its' package name and a template name, if the package exists. Otherwise
    266 ;; returns the not-found argument, default #f.
    267 
    268 (define (localized-template package-name template-name #!optional not-found)
    269   (if* (cached-package-bundle package-name)
    270        (dict-ref it template-name)
    271        not-found ) )
     246;; returns the default argument, default #f.
     247
     248(define (localized-template package-name template-name #!optional default)
     249  (if* (cached-package-bundle package-name) (dict-ref it template-name)
     250       default ) )
    272251
    273252;; Returns the localized template from the most specific bundle given
    274253;; its' package name and a template name, if the package exists. Otherwise
    275 ;; returns the not-found argument, default is the template-name.
    276 
    277 (define (localized-template/default package-name template-name #!optional (not-found template-name))
    278   (localized-template package-name template-name not-found) )
     254;; returns the default argument, default is the template-name.
     255
     256(define (localized-template/default package-name template-name #!optional (default template-name))
     257  (localized-template package-name template-name default) )
    279258
    280259;; Returns the application of the default 'format' procedure to the
    … …  
    292271          #\]) )
    293272
    294   (let ([fmtstr (or (localized-template package-name template-name)
     273  (let ((fmtstr (or (localized-template package-name template-name)
    295274                    (and (string? template-name)
    296                          template-name))])
    297     (if fmtstr
    298         (apply (current-locale-format-function) port fmtstr fmtargs)
     275                         template-name))))
     276    (if fmtstr (apply (current-locale-format-function) port fmtstr fmtargs)
    299277        (display/port (format-info-string package-name template-name fmtargs) port) ) ) )
    300278
    … …  
    303281
    304282(define (localized-template-set! package-name template-name value)
    305   (and-let* ([bundle (cached-package-bundle package-name)])
     283  (and-let* ((bundle (cached-package-bundle package-name)))
    306284    (dict-set! bundle template-name value)
    307285    #t ) )
    … …  
    310288
    311289(define (declare-bundle! bundle-specifier bundle-alist)
    312   (set-bundle! bundle-specifier bundle-alist)
     290  (%set-bundle! bundle-specifier bundle-alist)
    313291  #t )
    314292
    … …  
    316294
    317295(define (undeclare-bundle! bundle-specifier)
    318   (reset-bundle! bundle-specifier)
     296  (%reset-bundle! bundle-specifier)
    319297  #t )
    320298
    … …  
    322300
    323301(define (need-bundle loc bundle-specifier)
    324   (or (find-bundle bundle-specifier)
    325       (raise-undefined-exception loc "undeclared bundle specification" bundle-specifier)) )
     302  (or (%find-bundle bundle-specifier)
     303      (error-undefined loc "undeclared bundle specification" bundle-specifier)) )
    326304
    327305(define (check-bundle-specifier loc obj)
    328306  (unless (and (list? obj) (not (null? obj)))
    329     (raise-insufficient-exception loc "null bundle specification" obj) ) )
     307    (error-insufficient loc "null bundle specification" obj) ) )
    330308
    331309(define (need-bundle-absolute-pathname loc bundle-specifier alternate-dir)
    332310  (check-bundle-specifier loc bundle-specifier)
    333   (bundle-specification->absolute-pathname bundle-specifier alternate-dir) )
     311  (%bundle-specification->absolute-pathname bundle-specifier alternate-dir) )
    334312
    335313;; Reads bundle file & declares.
    336314
    337315(define (load-bundle! bundle-specifier . alternate-dir)
    338   (let ([path (need-bundle-absolute-pathname 'load-bundle! bundle-specifier alternate-dir)])
     316  (let ((path (need-bundle-absolute-pathname 'load-bundle! bundle-specifier alternate-dir)))
    339317    (and (file-exists? path)
    340318         (declare-bundle! bundle-specifier (with-input-from-file path read)) ) ) )
    … …  
    343321
    344322(define (store-bundle! bundle-specifier . alternate-dir)
    345   (let ([path (need-bundle-absolute-pathname 'store-bundle! bundle-specifier alternate-dir)]
    346         [bundle (need-bundle 'store-bundle! bundle-specifier)] )
     323  (let ((path (need-bundle-absolute-pathname 'store-bundle! bundle-specifier alternate-dir))
     324        (bundle (need-bundle 'store-bundle! bundle-specifier)) )
    347325    (create-pathname-directory path)
    348326    (delete-file* path)
    … …  
    353331
    354332(define (remove-bundle! bundle-specifier . alternate-dir)
    355   (let ([path (need-bundle-absolute-pathname 'remove-bundle! bundle-specifier alternate-dir)])
    356     (reset-bundle! bundle-specifier)
     333  (let ((path (need-bundle-absolute-pathname 'remove-bundle! bundle-specifier alternate-dir)))
     334    (%reset-bundle! bundle-specifier)
    357335    (delete-file* path)
    358336    #t ) )
    … …  
    361339
    362340(define (remove-bundle-directory! bundle-specifier . alternate-dir)
    363   (let ([path (need-bundle-absolute-pathname 'remove-bundle-directory! bundle-specifier alternate-dir)])
     341  (let ((path (need-bundle-absolute-pathname 'remove-bundle-directory! bundle-specifier alternate-dir)))
    364342    (delete-file* path)
    365     (let ([topdir (optional alternate-dir SYSTEM-BUNDLES)])
    366       (let loop ([path path])
    367         (let* ([dir (pathname-directory path)]
    368                [fillst (directory dir)])
    369           (cond [(string=? dir topdir)        #t]
    370                 [(positive? (length fillst))  #f]
    371                 [else
    372                   (delete-directory dir)
    373                   (loop dir)]) ) ) ) ) )
     343    (let ((topdir (optional alternate-dir SYSTEM-BUNDLES)))
     344      (let loop ((path path))
     345        (let* ((dir (pathname-directory path))
     346               (fillst (directory dir)))
     347          (cond ((string=? dir topdir)        #t)
     348                ((positive? (length fillst))  #f)
     349                (else
     350                 (delete-directory dir)
     351                 (loop dir) ) ) ) ) ) ) )
    374352
    375353;; Try loading from most to least specific, returns #f when failure.
    … …  
    377355(define (load-best-available-bundle! bundle-specifier . alternate-dir)
    378356  (check-bundle-specifier 'load-best-available-bundle! bundle-specifier)
    379   (let loop ([specifier (remove not bundle-specifier)])
     357  (let loop ((specifier (remove not bundle-specifier)))
    380358    (and (not (null? specifier))
    381359         (or (apply load-bundle! specifier alternate-dir)
    382              (loop (drop-right! specifier 1)))) ) )
     360             (loop (drop-right! specifier 1)) ) ) ) )
Note: See TracChangeset for help on using the changeset viewer.