Changeset 13897 in project
- Timestamp:
- 03/24/09 18:05:25 (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
release/3/srfi-29/trunk/srfi-29.scm
r12792 r13897 18 18 19 19 ;; Within the bundle directory the structure 20 ;; is [(language) [(country) [(details)]] ](module).20 ;; is [(language) [(country) [(details)]] (module). 21 21 22 22 (eval-when (compile) … … 27 27 (inline) 28 28 (no-procedure-checks) 29 (no-bound-checks)30 29 (bound-to-procedure ; Forward references 31 30 most-specific-bundle-specifier 32 31 invalidate-package-bundle-cache ) 33 32 (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 35 42 most-specific-bundle-specifier 36 43 localized-template/default … … 42 49 load-best-available-bundle! 43 50 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) 57 54 58 55 (register-feature! 'srfi-29) … … 63 60 64 61 (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))) 73 69 74 70 ;; Constants … … 82 78 ;; 83 79 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)) 94 88 95 89 (define (make-exn-srfi-29-condition loc msg . args) 96 90 (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) 105 95 (abort 106 96 (make-composite-condition 107 97 (apply make-exn-srfi-29-condition loc msg args) 108 *insufficient-condition*)) )109 110 (define ( raise-undefined-exceptionloc msg . args)98 (make-insufficient-condition))) ) 99 100 (define (error-undefined loc msg . args) 111 101 (abort 112 102 (make-composite-condition 113 103 (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))) 125 111 126 112 (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) ) ) ) 130 116 131 117 (define (cons-locale-item lci lst) 132 (if lci 133 (cons (symbol->string lci) lst) 118 (if lci (cons (symbol->string lci) lst) 134 119 lst ) ) 135 120 … … 147 132 (bundle-specification-filename bundle-specifier)) ) 148 133 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)) ) 152 138 153 139 ;; Bundles Dictionary … … 155 141 (define *localization-bundles* (make-dict equal?)) 156 142 157 (define-inline ( find-bundle bundle-specifier)143 (define-inline (%find-bundle bundle-specifier) 158 144 (dict-ref *localization-bundles* bundle-specifier) ) 159 145 160 (define-inline ( set-bundle! bundle-specifier bundle-alist)146 (define-inline (%set-bundle! bundle-specifier bundle-alist) 161 147 (dict-set! *localization-bundles* bundle-specifier (alist->dict bundle-alist equal?)) ) 162 148 163 (define-inline ( reset-bundle! bundle-specifier)149 (define-inline (%reset-bundle! bundle-specifier) 164 150 (invalidate-package-bundle-cache bundle-specifier) 165 151 (dict-delete! *localization-bundles* bundle-specifier) ) … … 170 156 171 157 (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)) ) ) 175 160 176 161 (define (cached-package-bundle package-name) 177 162 (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)))) 179 164 (and (not (null? specifier)) 180 (if* ( find-bundle specifier)165 (if* (%find-bundle specifier) 181 166 (begin 182 167 (dict-set! *package-bundle-cache* package-name it) … … 187 172 188 173 (define (locale-ref what) 189 (let ( [lc (current-locale-components)])174 (let ((lc (current-locale-components))) 190 175 (case what 191 [(details)192 (list (locale-ref 'script) (locale-ref 'codeset) (locale-ref 'modifier)) ]193 [else194 (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)) ) ) ) ) 195 180 196 181 ;;; Locale Parameters … … 200 185 ;; The initial procedure is the builtin 201 186 202 (define-parameter current-locale-format-function 203 format 187 (define-parameter current-locale-format-function format 204 188 (lambda (x) 205 (if (procedure? x) 206 x 189 (if (procedure? x) x 207 190 (begin 208 191 (warning 'current-locale-format-function "invalid procedure" x) … … 211 194 ;; The default language 212 195 213 (define-parameter current-language 214 (locale-ref 'language) 196 (define-parameter current-language (locale-ref 'language) 215 197 (lambda (x) 216 (cond [(locale-item? x)198 (cond ((%locale-item? x) 217 199 (invalidate-package-bundle-cache) 218 x ]219 [else200 x ) 201 (else 220 202 (warning 'current-language "invalid locale item" x) 221 (current-language) ]) ) )203 (current-language) ) ) ) ) 222 204 223 205 ;; The default country 224 206 225 (define-parameter current-country 226 (locale-ref 'region) 207 (define-parameter current-country (locale-ref 'region) 227 208 (lambda (x) 228 (cond [(locale-item? x)209 (cond ((%locale-item? x) 229 210 (invalidate-package-bundle-cache) 230 x ]231 [else211 x ) 212 (else 232 213 (warning 'current-country "invalid locale item" x) 233 (current-country) ]) ) )214 (current-country) ) ) ) ) 234 215 235 216 ;; The default locale-details 236 217 237 (define-parameter current-locale-details 238 (locale-ref 'details) 218 (define-parameter current-locale-details (locale-ref 'details) 239 219 (lambda (x) 240 (cond [(locale-details? x)220 (cond ((%locale-details? x) 241 221 (invalidate-package-bundle-cache) 242 x ]243 [else244 245 (current-locale-details) ]) ) )222 x ) 223 (else 224 (warning 'current-locale-details "invalid locale item" x) 225 (current-locale-details) ) ) ) ) 246 226 247 227 ;; If you change (current-locale), you don't have to set current-* … … 264 244 ;; Returns the localized template from the most specific bundle given 265 245 ;; 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 ) ) 272 251 273 252 ;; Returns the localized template from the most specific bundle given 274 253 ;; its' package name and a template name, if the package exists. Otherwise 275 ;; returns the not-foundargument, default is the template-name.276 277 (define (localized-template/default package-name template-name #!optional ( not-foundtemplate-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) ) 279 258 280 259 ;; Returns the application of the default 'format' procedure to the … … 292 271 #\]) ) 293 272 294 (let ( [fmtstr (or (localized-template package-name template-name)273 (let ((fmtstr (or (localized-template package-name template-name) 295 274 (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) 299 277 (display/port (format-info-string package-name template-name fmtargs) port) ) ) ) 300 278 … … 303 281 304 282 (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))) 306 284 (dict-set! bundle template-name value) 307 285 #t ) ) … … 310 288 311 289 (define (declare-bundle! bundle-specifier bundle-alist) 312 ( set-bundle! bundle-specifier bundle-alist)290 (%set-bundle! bundle-specifier bundle-alist) 313 291 #t ) 314 292 … … 316 294 317 295 (define (undeclare-bundle! bundle-specifier) 318 ( reset-bundle! bundle-specifier)296 (%reset-bundle! bundle-specifier) 319 297 #t ) 320 298 … … 322 300 323 301 (define (need-bundle loc bundle-specifier) 324 (or ( find-bundle bundle-specifier)325 ( raise-undefined-exceptionloc "undeclared bundle specification" bundle-specifier)) )302 (or (%find-bundle bundle-specifier) 303 (error-undefined loc "undeclared bundle specification" bundle-specifier)) ) 326 304 327 305 (define (check-bundle-specifier loc obj) 328 306 (unless (and (list? obj) (not (null? obj))) 329 ( raise-insufficient-exceptionloc "null bundle specification" obj) ) )307 (error-insufficient loc "null bundle specification" obj) ) ) 330 308 331 309 (define (need-bundle-absolute-pathname loc bundle-specifier alternate-dir) 332 310 (check-bundle-specifier loc bundle-specifier) 333 ( bundle-specification->absolute-pathname bundle-specifier alternate-dir) )311 (%bundle-specification->absolute-pathname bundle-specifier alternate-dir) ) 334 312 335 313 ;; Reads bundle file & declares. 336 314 337 315 (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))) 339 317 (and (file-exists? path) 340 318 (declare-bundle! bundle-specifier (with-input-from-file path read)) ) ) ) … … 343 321 344 322 (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)) ) 347 325 (create-pathname-directory path) 348 326 (delete-file* path) … … 353 331 354 332 (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) 357 335 (delete-file* path) 358 336 #t ) ) … … 361 339 362 340 (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))) 364 342 (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 [else372 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) ) ) ) ) ) ) ) 374 352 375 353 ;; Try loading from most to least specific, returns #f when failure. … … 377 355 (define (load-best-available-bundle! bundle-specifier . alternate-dir) 378 356 (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))) 380 358 (and (not (null? specifier)) 381 359 (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.