Changeset 34115 in project


Ignore:
Timestamp:
05/30/17 00:51:05 (4 weeks ago)
Author:
kon
Message:

re-flow

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

Legend:

Unmodified
Added
Removed
  • release/4/srfi-29/tags/2.3.3/srfi-29.scm

    r21386 r34115  
    105105;;
    106106
    107 (define-inline (%global-bound? sym) (##sys#symbol-has-toplevel-binding? sym))
    108 (define-inline (%global-ref sym) (##sys#slot sym 0))
     107(define (%global-bound? sym)
     108  (##sys#symbol-has-toplevel-binding? sym) )
     109
     110(define (%global-ref sym)
     111  (##sys#slot sym 0) )
    109112
    110113;;
     
    170173
    171174(define (cons-locale-item lci lst)
    172   (if lci (cons (symbol->string lci) lst)
     175  (if lci
     176    (cons (symbol->string lci) lst)
    173177    lst ) )
    174178
     
    194198
    195199(define (bundle-specifier? obj)
    196   (and (pair? obj)
    197        (package-name? (car obj))
    198        (every bundle-specifier-element? (cdr obj))) )
     200  (and
     201    (pair? obj)
     202    (package-name? (car obj))
     203    (every bundle-specifier-element? (cdr obj))) )
    199204(define-check+error-type bundle-specifier)
    200205
     
    243248
    244249(define (need-bundle loc bndl-spec)
    245   (or (bundle-ref bndl-spec)
    246       (error-undefined loc "undeclared bundle specification" bndl-spec)) )
     250  (or
     251    (bundle-ref bndl-spec)
     252    (error-undefined loc "undeclared bundle specification" bndl-spec)) )
    247253
    248254;; Package Bundle Cache
     
    255261(if (environment-variable-true? "SRFI29_TLS")
    256262
    257     ;then use a parameter for the cache
    258     ;so one bundle per package per thread
    259     (let ((package-bundle-cache (make-parameter (make-dict eq?))))
    260 
    261       (set! invalidate-package-bundle-cache (lambda args
    262         (if (null? args) (package-bundle-cache (make-dict eq?))
    263           ;else args is (bndl-spec)
    264           (dict-delete! (package-bundle-cache) (caar args)) ) ) )
    265 
    266       (set! cached-package-bundle (lambda (pkgnam)
    267         (or (dict-ref (package-bundle-cache) pkgnam)
    268             (let loop ((bndl-spec (most-specific-bundle-specifier pkgnam)))
    269               (and (not (null? bndl-spec))
    270                    (if* (bundle-ref bndl-spec)
    271                         (begin
    272                           (dict-set! (package-bundle-cache) pkgnam it)
    273                           it )
    274                         (loop (drop-right! bndl-spec 1)) ) ) ) ) ) ) )
    275 
    276     ;else one bundle per package
    277     (let ((package-bundle-cache (make-dict eq?)))
    278 
    279       (set! invalidate-package-bundle-cache (lambda args
    280         (if (null? args) (set! package-bundle-cache (make-dict eq?))
    281           ;else args is (bndl-spec)
    282           (dict-delete! package-bundle-cache (caar args)) ) ) )
    283 
    284       (set! cached-package-bundle (lambda (pkgnam)
    285         (or (dict-ref package-bundle-cache pkgnam)
    286             (let loop ((bndl-spec (most-specific-bundle-specifier pkgnam)))
    287               (and (not (null? bndl-spec))
    288                    (if* (bundle-ref bndl-spec)
    289                         (begin
    290                           (dict-set! package-bundle-cache pkgnam it)
    291                           it )
    292                         (loop (drop-right! bndl-spec 1)) ) ) ) ) ) ) ) )
     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)) ) ) ) ) ) ) ) )
    293299
    294300;;; Locale Parameters
     
    332338
    333339(define (localized-template pkgnam tptnam #!optional defpkg deftpt)
    334   (if* (cached-package-bundle pkgnam) (dict-ref it tptnam deftpt)
     340  (if* (cached-package-bundle pkgnam)
     341    (dict-ref it tptnam deftpt)
    335342    defpkg ) )
    336343
     
    385392
    386393  (define (format-info-string pkgnam tptnam fmtargs)
    387     (conc #\[ #\< pkgnam #\space tptnam #\>
    388               #\space
    389               (apply conc (intersperse fmtargs #\space))
    390           #\]) )
    391 
    392   (let ((fmtstr (or (localized-template pkgnam tptnam)
    393                     (and (string? tptnam)
    394                          tptnam))))
    395     (if fmtstr (apply (current-locale-format-function) fmtstr fmtargs)
    396         (format-info-string pkgnam tptnam fmtargs) ) ) )
     394    (conc
     395      #\[
     396        #\< pkgnam #\space tptnam #\>
     397        #\space
     398        (apply conc (intersperse fmtargs #\space))
     399      #\]) )
     400
     401  (let ((fmtstr
     402          (or
     403            (localized-template pkgnam tptnam)
     404            (and (string? tptnam) tptnam))))
     405    (if fmtstr
     406      (apply (current-locale-format-function) fmtstr fmtargs)
     407      (format-info-string pkgnam tptnam fmtargs) ) ) )
    397408
    398409;; Create or update the value for a template in an existing package.
     
    412423;Assumes valid argument!
    413424(define (alist-element-atomic-value p)
    414   (if (pair? (cdr p)) (cadr p)
     425  (if (pair? (cdr p))
     426    (cadr p)
    415427    (cdr p)) )
    416428
     
    428440(define (required-global-ref loc ident)
    429441  (let ((ident (make-identifier ident)))
    430     (if (and ident (%global-bound? ident)) (%global-ref ident)
     442    (if (and ident (%global-bound? ident))
     443      (%global-ref ident)
    431444      (error-unbound-variable loc ident) ) ) )
    432445
     
    434447
    435448(define (template-identifier-name? obj)
    436   (or (symbol? obj)
    437       (and (pair? obj)
    438            (symbol? (car obj))
    439            (symbol? (alist-element-atomic-value obj)))) )
     449  (or
     450    (symbol? obj)
     451    (and
     452      (pair? obj)
     453      (symbol? (car obj))
     454      (symbol? (alist-element-atomic-value obj)))) )
    440455
    441456(define-check+error-type template-identifier-name)
     
    460475
    461476(define (load-code loc libspec)
    462   (let ((unit (if (not (pair? libspec)) (and (symbol? libspec) libspec)
    463                 (and (pair? libspec) (symbol? (car libspec)) (car libspec))) )
    464         (path (if (not (pair? libspec)) (and (string? libspec) libspec)
    465                 (and (string? (cadr libspec)) libspec)) ) )
     477  (let ((unit
     478          (if (not (pair? libspec))
     479            (and (symbol? libspec) libspec)
     480            (and (pair? libspec) (symbol? (car libspec)) (car libspec)) ) )
     481        (path
     482          (if (not (pair? libspec))
     483            (and (string? libspec) libspec)
     484            (and (string? (cadr libspec)) libspec) ) ) )
    466485    ; A pathname is preferred to a unitname
    467486    (let ((the-name (or path unit)))
     
    534553(define (load-bundle! bndl-spec . args)
    535554  (let-optionals args ((alt-dir SYSTEM-BUNDLES))
    536     (let ((path (need-bundle-absolute-pathname
    537                   'load-bundle! bndl-spec alt-dir)))
    538       (and (file-exists? path)
    539            (declare-bundle! bndl-spec
    540              (with-input-from-file path read)) ) ) ) )
     555    (let ((path
     556            (need-bundle-absolute-pathname
     557              'load-bundle! bndl-spec alt-dir)))
     558      (and
     559        (file-exists? path)
     560        (declare-bundle! bndl-spec (with-input-from-file path read)) ) ) ) )
    541561
    542562;; Write bundle to file
     
    544564(define (store-bundle! bndl-spec . args)
    545565  (let-optionals args ((alt-dir SYSTEM-BUNDLES))
    546     (let ((path (need-bundle-absolute-pathname
    547                   'store-bundle! bndl-spec alt-dir))
    548           (bndl (need-bundle 'store-bundle! bndl-spec)) )
     566    (let ((path
     567            (need-bundle-absolute-pathname
     568              'store-bundle! bndl-spec alt-dir))
     569          (bndl
     570            (need-bundle 'store-bundle! bndl-spec)) )
    549571      (create-pathname-directory path)
    550572      (delete-file* path)
     
    556578(define (remove-bundle! bndl-spec . args)
    557579  (let-optionals args ((alt-dir SYSTEM-BUNDLES))
    558     (let ((path (need-bundle-absolute-pathname
    559                   'remove-bundle! bndl-spec alt-dir)))
     580    (let ((path
     581            (need-bundle-absolute-pathname
     582              'remove-bundle! bndl-spec alt-dir)))
    560583      (bundle-delete! bndl-spec)
    561584      (delete-file* path)
     
    585608  (let-optionals args ((alt-dir SYSTEM-BUNDLES))
    586609    (let loop ((bndl-spec
    587                 (check-bundle-specifier 'load-best-available-bundle!
    588                                         bndl-spec)))
    589       (and (not (null? bndl-spec))
    590            (or (load-bundle! bndl-spec alt-dir)
    591                (loop (drop-right! bndl-spec 1)) ) ) ) ) )
     610                (check-bundle-specifier
     611                  'load-best-available-bundle! bndl-spec)))
     612      (and
     613        (not (null? bndl-spec))
     614        (or
     615          (load-bundle! bndl-spec alt-dir)
     616          (loop (drop-right! bndl-spec 1)) ) ) ) ) )
    592617
    593618;;; Introspection
  • release/4/srfi-29/tags/2.3.3/srfi-29.setup

    r31582 r34115  
    99  (file-chmod (srfi-29-bundles-home) 'a+rx) )
    1010
    11 (setup-shared-extension-module 'srfi-29 (extension-version "2.3.2")
     11(setup-shared-extension-module 'srfi-29 (extension-version "2.3.3")
    1212  #:inline? #t
    1313  #:types? #t
  • release/4/srfi-29/trunk/srfi-29.scm

    r21386 r34115  
    105105;;
    106106
    107 (define-inline (%global-bound? sym) (##sys#symbol-has-toplevel-binding? sym))
    108 (define-inline (%global-ref sym) (##sys#slot sym 0))
     107(define (%global-bound? sym)
     108  (##sys#symbol-has-toplevel-binding? sym) )
     109
     110(define (%global-ref sym)
     111  (##sys#slot sym 0) )
    109112
    110113;;
     
    170173
    171174(define (cons-locale-item lci lst)
    172   (if lci (cons (symbol->string lci) lst)
     175  (if lci
     176    (cons (symbol->string lci) lst)
    173177    lst ) )
    174178
     
    194198
    195199(define (bundle-specifier? obj)
    196   (and (pair? obj)
    197        (package-name? (car obj))
    198        (every bundle-specifier-element? (cdr obj))) )
     200  (and
     201    (pair? obj)
     202    (package-name? (car obj))
     203    (every bundle-specifier-element? (cdr obj))) )
    199204(define-check+error-type bundle-specifier)
    200205
     
    243248
    244249(define (need-bundle loc bndl-spec)
    245   (or (bundle-ref bndl-spec)
    246       (error-undefined loc "undeclared bundle specification" bndl-spec)) )
     250  (or
     251    (bundle-ref bndl-spec)
     252    (error-undefined loc "undeclared bundle specification" bndl-spec)) )
    247253
    248254;; Package Bundle Cache
     
    255261(if (environment-variable-true? "SRFI29_TLS")
    256262
    257     ;then use a parameter for the cache
    258     ;so one bundle per package per thread
    259     (let ((package-bundle-cache (make-parameter (make-dict eq?))))
    260 
    261       (set! invalidate-package-bundle-cache (lambda args
    262         (if (null? args) (package-bundle-cache (make-dict eq?))
    263           ;else args is (bndl-spec)
    264           (dict-delete! (package-bundle-cache) (caar args)) ) ) )
    265 
    266       (set! cached-package-bundle (lambda (pkgnam)
    267         (or (dict-ref (package-bundle-cache) pkgnam)
    268             (let loop ((bndl-spec (most-specific-bundle-specifier pkgnam)))
    269               (and (not (null? bndl-spec))
    270                    (if* (bundle-ref bndl-spec)
    271                         (begin
    272                           (dict-set! (package-bundle-cache) pkgnam it)
    273                           it )
    274                         (loop (drop-right! bndl-spec 1)) ) ) ) ) ) ) )
    275 
    276     ;else one bundle per package
    277     (let ((package-bundle-cache (make-dict eq?)))
    278 
    279       (set! invalidate-package-bundle-cache (lambda args
    280         (if (null? args) (set! package-bundle-cache (make-dict eq?))
    281           ;else args is (bndl-spec)
    282           (dict-delete! package-bundle-cache (caar args)) ) ) )
    283 
    284       (set! cached-package-bundle (lambda (pkgnam)
    285         (or (dict-ref package-bundle-cache pkgnam)
    286             (let loop ((bndl-spec (most-specific-bundle-specifier pkgnam)))
    287               (and (not (null? bndl-spec))
    288                    (if* (bundle-ref bndl-spec)
    289                         (begin
    290                           (dict-set! package-bundle-cache pkgnam it)
    291                           it )
    292                         (loop (drop-right! bndl-spec 1)) ) ) ) ) ) ) ) )
     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)) ) ) ) ) ) ) ) )
    293299
    294300;;; Locale Parameters
     
    332338
    333339(define (localized-template pkgnam tptnam #!optional defpkg deftpt)
    334   (if* (cached-package-bundle pkgnam) (dict-ref it tptnam deftpt)
     340  (if* (cached-package-bundle pkgnam)
     341    (dict-ref it tptnam deftpt)
    335342    defpkg ) )
    336343
     
    385392
    386393  (define (format-info-string pkgnam tptnam fmtargs)
    387     (conc #\[ #\< pkgnam #\space tptnam #\>
    388               #\space
    389               (apply conc (intersperse fmtargs #\space))
    390           #\]) )
    391 
    392   (let ((fmtstr (or (localized-template pkgnam tptnam)
    393                     (and (string? tptnam)
    394                          tptnam))))
    395     (if fmtstr (apply (current-locale-format-function) fmtstr fmtargs)
    396         (format-info-string pkgnam tptnam fmtargs) ) ) )
     394    (conc
     395      #\[
     396        #\< pkgnam #\space tptnam #\>
     397        #\space
     398        (apply conc (intersperse fmtargs #\space))
     399      #\]) )
     400
     401  (let ((fmtstr
     402          (or
     403            (localized-template pkgnam tptnam)
     404            (and (string? tptnam) tptnam))))
     405    (if fmtstr
     406      (apply (current-locale-format-function) fmtstr fmtargs)
     407      (format-info-string pkgnam tptnam fmtargs) ) ) )
    397408
    398409;; Create or update the value for a template in an existing package.
     
    412423;Assumes valid argument!
    413424(define (alist-element-atomic-value p)
    414   (if (pair? (cdr p)) (cadr p)
     425  (if (pair? (cdr p))
     426    (cadr p)
    415427    (cdr p)) )
    416428
     
    428440(define (required-global-ref loc ident)
    429441  (let ((ident (make-identifier ident)))
    430     (if (and ident (%global-bound? ident)) (%global-ref ident)
     442    (if (and ident (%global-bound? ident))
     443      (%global-ref ident)
    431444      (error-unbound-variable loc ident) ) ) )
    432445
     
    434447
    435448(define (template-identifier-name? obj)
    436   (or (symbol? obj)
    437       (and (pair? obj)
    438            (symbol? (car obj))
    439            (symbol? (alist-element-atomic-value obj)))) )
     449  (or
     450    (symbol? obj)
     451    (and
     452      (pair? obj)
     453      (symbol? (car obj))
     454      (symbol? (alist-element-atomic-value obj)))) )
    440455
    441456(define-check+error-type template-identifier-name)
     
    460475
    461476(define (load-code loc libspec)
    462   (let ((unit (if (not (pair? libspec)) (and (symbol? libspec) libspec)
    463                 (and (pair? libspec) (symbol? (car libspec)) (car libspec))) )
    464         (path (if (not (pair? libspec)) (and (string? libspec) libspec)
    465                 (and (string? (cadr libspec)) libspec)) ) )
     477  (let ((unit
     478          (if (not (pair? libspec))
     479            (and (symbol? libspec) libspec)
     480            (and (pair? libspec) (symbol? (car libspec)) (car libspec)) ) )
     481        (path
     482          (if (not (pair? libspec))
     483            (and (string? libspec) libspec)
     484            (and (string? (cadr libspec)) libspec) ) ) )
    466485    ; A pathname is preferred to a unitname
    467486    (let ((the-name (or path unit)))
     
    534553(define (load-bundle! bndl-spec . args)
    535554  (let-optionals args ((alt-dir SYSTEM-BUNDLES))
    536     (let ((path (need-bundle-absolute-pathname
    537                   'load-bundle! bndl-spec alt-dir)))
    538       (and (file-exists? path)
    539            (declare-bundle! bndl-spec
    540              (with-input-from-file path read)) ) ) ) )
     555    (let ((path
     556            (need-bundle-absolute-pathname
     557              'load-bundle! bndl-spec alt-dir)))
     558      (and
     559        (file-exists? path)
     560        (declare-bundle! bndl-spec (with-input-from-file path read)) ) ) ) )
    541561
    542562;; Write bundle to file
     
    544564(define (store-bundle! bndl-spec . args)
    545565  (let-optionals args ((alt-dir SYSTEM-BUNDLES))
    546     (let ((path (need-bundle-absolute-pathname
    547                   'store-bundle! bndl-spec alt-dir))
    548           (bndl (need-bundle 'store-bundle! bndl-spec)) )
     566    (let ((path
     567            (need-bundle-absolute-pathname
     568              'store-bundle! bndl-spec alt-dir))
     569          (bndl
     570            (need-bundle 'store-bundle! bndl-spec)) )
    549571      (create-pathname-directory path)
    550572      (delete-file* path)
     
    556578(define (remove-bundle! bndl-spec . args)
    557579  (let-optionals args ((alt-dir SYSTEM-BUNDLES))
    558     (let ((path (need-bundle-absolute-pathname
    559                   'remove-bundle! bndl-spec alt-dir)))
     580    (let ((path
     581            (need-bundle-absolute-pathname
     582              'remove-bundle! bndl-spec alt-dir)))
    560583      (bundle-delete! bndl-spec)
    561584      (delete-file* path)
     
    585608  (let-optionals args ((alt-dir SYSTEM-BUNDLES))
    586609    (let loop ((bndl-spec
    587                 (check-bundle-specifier 'load-best-available-bundle!
    588                                         bndl-spec)))
    589       (and (not (null? bndl-spec))
    590            (or (load-bundle! bndl-spec alt-dir)
    591                (loop (drop-right! bndl-spec 1)) ) ) ) ) )
     610                (check-bundle-specifier
     611                  'load-best-available-bundle! bndl-spec)))
     612      (and
     613        (not (null? bndl-spec))
     614        (or
     615          (load-bundle! bndl-spec alt-dir)
     616          (loop (drop-right! bndl-spec 1)) ) ) ) ) )
    592617
    593618;;; Introspection
  • release/4/srfi-29/trunk/srfi-29.setup

    r31582 r34115  
    99  (file-chmod (srfi-29-bundles-home) 'a+rx) )
    1010
    11 (setup-shared-extension-module 'srfi-29 (extension-version "2.3.2")
     11(setup-shared-extension-module 'srfi-29 (extension-version "2.3.3")
    1212  #:inline? #t
    1313  #:types? #t
Note: See TracChangeset for help on using the changeset viewer.