Changeset 20890 in project


Ignore:
Timestamp:
10/19/10 08:46:50 (11 years ago)
Author:
Kon Lovett
Message:

Added unbound-variable-condition. Deprecated !localized-template & make-!localized-template. Added required-localized-template & make-required-localized-template. Chgs for deprecated lolevel::global-*.

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

Legend:

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

    r19863 r20890  
    22;;;; Kon Lovett, Dec '05
    33
    4 ;; ISSUES
     4;; Issues
    55;;
    66;; - Bit of a dither about (disable-interrupts). Suspect not really
     
    1313;; symbol means what?
    1414;;
    15 ;; - Possible race condition creating a bundle file or directory
     15;; - Possible race condition creating a bundle file or directory.
     16;;
     17;; - Uses `##sys#module-rename' to construct a module qualified identifier.
    1618
    1719(module srfi-29
     
    2729    localized-template
    2830    ; Extensions
    29     undefined-condition?
     31    undefined-condition? unbound-variable-condition?
    3032    system-bundle-directory
    3133    most-specific-bundle-specifier
    32     !localized-template
     34    required-localized-template
    3335    localized-template/default
    34     make-!localized-template
     36    make-required-localized-template
    3537    make-localized-template
    3638    make-localized-template/default
     
    4648    localized-templates
    4749    declared-bundle-specifiers
    48     declared-bundle-templates)
     50    declared-bundle-templates
     51    ;Deperecated
     52    !localized-template
     53    make-!localized-template)
    4954
    5055  (import
     
    6469    (only posix
    6570      directory? create-directory delete-directory directory)
    66     (only lolevel
    67       global-bound? global-ref)
    6871    (only lookup-table
    6972      make-dict dict-ref dict-set! dict-delete!
     
    8487
    8588  (require-library
    86     srfi-1 srfi-13 extras data-structures files posix lolevel
     89    srfi-1 srfi-13 extras data-structures files posix
    8790    lookup-table miscmacros locale
    8891    condition-utils type-errors type-checks)
    8992
    9093  (declare
    91     (bound-to-procedure ; Forward references
     94    (bound-to-procedure
     95      ##sys#symbol-has-toplevel-binding?
     96      ; Forward references
    9297      most-specific-bundle-specifier
    9398      invalidate-package-bundle-cache ) )
    9499
    95100;;; Utilities
     101
     102;;
     103
     104(define-inline (%global-bound? sym) (##sys#symbol-has-toplevel-binding? sym))
     105(define-inline (%global-ref sym) (##sys#slot sym 0))
    96106
    97107;;
     
    131141      (make-property-condition 'undefined))) )
    132142
     143(define (error-unbound-variable loc sym)
     144  (abort
     145    (make-exn-condition+
     146      loc "unbound variable" (list sym)
     147      (make-property-condition 'srfi-29)
     148      (make-property-condition 'unbound))) )
     149
    133150(define undefined-condition? (make-condition-predicate exn srfi-29 undefined))
     151
     152(define unbound-variable-condition? (make-condition-predicate exn srfi-29 unbound))
    134153
    135154;;; Locale Operations
     
    313332;; its' package name and a template name.
    314333;;
    315 ;; Raises an expception for undefined elements. 
     334;; Raises an expception for undefined elements.
    316335
    317336(define +no-package-tag+ (vector 'no-package))
    318337(define +no-template-tag+ (vector 'no-template))
    319338
    320 (define (*!localized-template loc pkgnam tptnam)
     339(define (*required-localized-template loc pkgnam tptnam)
    321340  (let ((res (localized-template pkgnam tptnam +no-package-tag+ +no-template-tag+)))
    322341    (cond
     
    328347        res ) ) ) )
    329348
    330 (define (!localized-template pkgnam tptnam)
    331   (*!localized-template '!localized-template pkgnam tptnam) )
     349(define (required-localized-template pkgnam tptnam)
     350  (*required-localized-template 'required-localized-template pkgnam tptnam) )
    332351
    333352;; Returns a procedure the looks up a template in a fixed package
    334353
    335 (define ((make-!localized-template pkgnam) tptnam)
    336   (!localized-template pkgnam tptnam) )
     354(define ((make-required-localized-template pkgnam) tptnam)
     355  (required-localized-template pkgnam tptnam) )
    337356
    338357(define ((make-localized-template pkgnam) tptnam #!optional defpkg deftpt)
     
    372391;;; "Logic Bundle"
    373392
    374 ;association-list pair -> value
    375 ;(key . (value ...))
    376 ;(key . value)
    377 
     393;; Support
     394
     395; Support both "styles" of alist element: (key . (value ...)) & (key . value)
     396; where value is assumed to be an atom.
     397; assumes valid argument!
    378398(define (alist-element-atomic-value p)
    379   (if (pair? (cdr p)) (cadr p) (cdr p)) )
     399  (if (pair? (cdr p)) (cadr p)
     400    (cdr p)) )
     401
     402; assumes valid argument!
     403(define (make-identifier ident)
     404  (cond
     405    ; qualified name
     406    ((pair? ident)
     407      (##sys#module-rename (alist-element-atomic-value ident) (car ident)) )
     408    ; unqualified name
     409    (else
     410      ident ) ) )
     411
     412; assumes valid argument!
     413(define (required-global-ref loc ident)
     414  (let ((ident (make-identifier ident)))
     415    (if (and ident (%global-bound? ident)) (%global-ref ident)
     416      (error-unbound-variable loc ident) ) ) )
     417
     418;; Form checks
    380419
    381420(define (template-identifier-name? obj)
     
    386425
    387426(define-check+error-type template-identifier-name)
    388  
     427
    389428(define (check-template-variable-name loc pkgnam obj #!optional argnam)
    390429  (check-symbol loc obj argnam)
    391   (check-template-identifier-name loc (!localized-template pkgnam obj) argnam)
     430  (check-template-identifier-name loc (required-localized-template pkgnam obj) argnam)
    392431  obj )
    393  
     432
    394433(define (check-template-variable-names loc pkgnam obj #!optional argnam)
    395434  (check-list loc obj argnam)
    396   (every (cut check-template-variable-name loc pkgnam <> argnam) obj)
     435  (for-each (cut check-template-variable-name loc pkgnam <> argnam) obj)
    397436  obj )
    398437
    399 (define (make-identifier ident)
    400   (cond
    401     ; unqualified name
    402     ((symbol? ident)
    403       ident )
    404     ; qualified name
    405     ((pair? ident)
    406       (##sys#module-rename
    407         (alist-element-atomic-value ident)
    408         (car ident)) )
    409     (else
    410       #f ) ) )
    411 
    412 (define (!global-ref loc ident)
    413   (let ((ident (make-identifier ident)))
    414     (if (and ident (global-bound? ident)) (global-ref ident)
    415       (error-undefined loc "undefined toplevel variable" ident) ) ) )
     438;;
    416439
    417440;there must be a better way using sys namespace operations.
    418441;(Chicken 4.2.2 had a query for ALL loaded binaries)
    419442
     443; A `library-name' is a pathname or unitname.
    420444(define +loaded-library-names+ '())
    421445
    422446(define (load-code loc libspec)
    423   (let ((unit (if (pair? libspec)
    424                 (and (pair? libspec) (symbol? (car libspec)) (car libspec))
    425                 (and (symbol? libspec) libspec) ) )
    426         (path (if (pair? libspec)
    427                 (and (string? (cadr libspec)) libspec)
    428                 (and (string? libspec) libspec) ) ) )
    429     (unless (member (or path unit) +loaded-library-names+)
    430       (cond
    431         ; Library Unit
    432         ((and unit path)
    433           (load-library unit path) )
    434         ; Library Unit
    435         (unit
    436           (load-library unit) )
    437         ; Must be absolute pathaname, otherwise pathname is relative to
    438         ; "current file"
    439         (path
    440           (load-relative path) )
    441         (else
    442           (error loc "invalid library load specificiation" libspec) ) )
    443       (set! +loaded-library-names+ (cons (or path unit) +loaded-library-names+)) ) ) )
     447  (let ((unit (if (not (pair? libspec)) (and (symbol? libspec) libspec)
     448                (and (pair? libspec) (symbol? (car libspec)) (car libspec))) )
     449        (path (if (not (pair? libspec)) (and (string? libspec) libspec)
     450                (and (string? (cadr libspec)) libspec)) ) )
     451    ; A pathname is preferred to a unitname
     452    (let ((the-name (or path unit)))
     453      (unless (member the-name +loaded-library-names+)
     454        (cond
     455          ; Library Unit w/ path
     456          ((and unit path)
     457            (load-library unit path) )
     458          ; Library Unit
     459          (unit
     460            (load-library unit) )
     461          ; Must be absolute pathaname, otherwise pathname is relative to
     462          ; "current file"
     463          (path
     464            (load-relative path) )
     465          (else
     466            (error loc "invalid library load specificiation" libspec) ) )
     467        (set! +loaded-library-names+ (cons the-name +loaded-library-names+)) ) ) ) )
    444468
    445469(define (fixup-references loc pkgnam vartptnams)
     
    448472      (localized-template-set!
    449473        pkgnam tptnam
    450         (!global-ref loc (!localized-template pkgnam tptnam))) )
     474        (required-global-ref loc (required-localized-template pkgnam tptnam))) )
    451475    vartptnams) )
     476
     477;;
    452478
    453479(define (*load-localized-compiled-code libspec pkgnam vartptnams)
     
    570596(register-feature! 'srfi-29)
    571597
     598;Deprecated
     599(define !localized-template required-localized-template)
     600(define make-!localized-template make-required-localized-template)
     601
    572602) ;module srfi-29
    573603
  • release/4/srfi-29/tags/2.1.3/srfi-29.setup

    r20306 r20890  
    1616(create-directory/parents (make-repository-pathname "srfi-29-bundles"))
    1717
    18 (setup-shared-extension-module 'srfi-29 (extension-version "2.1.2")
     18(setup-shared-extension-module 'srfi-29 (extension-version "2.1.3")
    1919  #:compile-options '(
    2020    -disable-interrupts ; We got shared data but might not be necessary
    2121    -fixnum-arithmetic
     22    -O3 -d1
    2223    -no-procedure-checks))
  • release/4/srfi-29/trunk/srfi-29.scm

    r19863 r20890  
    22;;;; Kon Lovett, Dec '05
    33
    4 ;; ISSUES
     4;; Issues
    55;;
    66;; - Bit of a dither about (disable-interrupts). Suspect not really
     
    1313;; symbol means what?
    1414;;
    15 ;; - Possible race condition creating a bundle file or directory
     15;; - Possible race condition creating a bundle file or directory.
     16;;
     17;; - Uses `##sys#module-rename' to construct a module qualified identifier.
    1618
    1719(module srfi-29
     
    2729    localized-template
    2830    ; Extensions
    29     undefined-condition?
     31    undefined-condition? unbound-variable-condition?
    3032    system-bundle-directory
    3133    most-specific-bundle-specifier
    32     !localized-template
     34    required-localized-template
    3335    localized-template/default
    34     make-!localized-template
     36    make-required-localized-template
    3537    make-localized-template
    3638    make-localized-template/default
     
    4648    localized-templates
    4749    declared-bundle-specifiers
    48     declared-bundle-templates)
     50    declared-bundle-templates
     51    ;Deperecated
     52    !localized-template
     53    make-!localized-template)
    4954
    5055  (import
     
    6469    (only posix
    6570      directory? create-directory delete-directory directory)
    66     (only lolevel
    67       global-bound? global-ref)
    6871    (only lookup-table
    6972      make-dict dict-ref dict-set! dict-delete!
     
    8487
    8588  (require-library
    86     srfi-1 srfi-13 extras data-structures files posix lolevel
     89    srfi-1 srfi-13 extras data-structures files posix
    8790    lookup-table miscmacros locale
    8891    condition-utils type-errors type-checks)
    8992
    9093  (declare
    91     (bound-to-procedure ; Forward references
     94    (bound-to-procedure
     95      ##sys#symbol-has-toplevel-binding?
     96      ; Forward references
    9297      most-specific-bundle-specifier
    9398      invalidate-package-bundle-cache ) )
    9499
    95100;;; Utilities
     101
     102;;
     103
     104(define-inline (%global-bound? sym) (##sys#symbol-has-toplevel-binding? sym))
     105(define-inline (%global-ref sym) (##sys#slot sym 0))
    96106
    97107;;
     
    131141      (make-property-condition 'undefined))) )
    132142
     143(define (error-unbound-variable loc sym)
     144  (abort
     145    (make-exn-condition+
     146      loc "unbound variable" (list sym)
     147      (make-property-condition 'srfi-29)
     148      (make-property-condition 'unbound))) )
     149
    133150(define undefined-condition? (make-condition-predicate exn srfi-29 undefined))
     151
     152(define unbound-variable-condition? (make-condition-predicate exn srfi-29 unbound))
    134153
    135154;;; Locale Operations
     
    313332;; its' package name and a template name.
    314333;;
    315 ;; Raises an expception for undefined elements. 
     334;; Raises an expception for undefined elements.
    316335
    317336(define +no-package-tag+ (vector 'no-package))
    318337(define +no-template-tag+ (vector 'no-template))
    319338
    320 (define (*!localized-template loc pkgnam tptnam)
     339(define (*required-localized-template loc pkgnam tptnam)
    321340  (let ((res (localized-template pkgnam tptnam +no-package-tag+ +no-template-tag+)))
    322341    (cond
     
    328347        res ) ) ) )
    329348
    330 (define (!localized-template pkgnam tptnam)
    331   (*!localized-template '!localized-template pkgnam tptnam) )
     349(define (required-localized-template pkgnam tptnam)
     350  (*required-localized-template 'required-localized-template pkgnam tptnam) )
    332351
    333352;; Returns a procedure the looks up a template in a fixed package
    334353
    335 (define ((make-!localized-template pkgnam) tptnam)
    336   (!localized-template pkgnam tptnam) )
     354(define ((make-required-localized-template pkgnam) tptnam)
     355  (required-localized-template pkgnam tptnam) )
    337356
    338357(define ((make-localized-template pkgnam) tptnam #!optional defpkg deftpt)
     
    372391;;; "Logic Bundle"
    373392
    374 ;association-list pair -> value
    375 ;(key . (value ...))
    376 ;(key . value)
    377 
     393;; Support
     394
     395; Support both "styles" of alist element: (key . (value ...)) & (key . value)
     396; where value is assumed to be an atom.
     397; assumes valid argument!
    378398(define (alist-element-atomic-value p)
    379   (if (pair? (cdr p)) (cadr p) (cdr p)) )
     399  (if (pair? (cdr p)) (cadr p)
     400    (cdr p)) )
     401
     402; assumes valid argument!
     403(define (make-identifier ident)
     404  (cond
     405    ; qualified name
     406    ((pair? ident)
     407      (##sys#module-rename (alist-element-atomic-value ident) (car ident)) )
     408    ; unqualified name
     409    (else
     410      ident ) ) )
     411
     412; assumes valid argument!
     413(define (required-global-ref loc ident)
     414  (let ((ident (make-identifier ident)))
     415    (if (and ident (%global-bound? ident)) (%global-ref ident)
     416      (error-unbound-variable loc ident) ) ) )
     417
     418;; Form checks
    380419
    381420(define (template-identifier-name? obj)
     
    386425
    387426(define-check+error-type template-identifier-name)
    388  
     427
    389428(define (check-template-variable-name loc pkgnam obj #!optional argnam)
    390429  (check-symbol loc obj argnam)
    391   (check-template-identifier-name loc (!localized-template pkgnam obj) argnam)
     430  (check-template-identifier-name loc (required-localized-template pkgnam obj) argnam)
    392431  obj )
    393  
     432
    394433(define (check-template-variable-names loc pkgnam obj #!optional argnam)
    395434  (check-list loc obj argnam)
    396   (every (cut check-template-variable-name loc pkgnam <> argnam) obj)
     435  (for-each (cut check-template-variable-name loc pkgnam <> argnam) obj)
    397436  obj )
    398437
    399 (define (make-identifier ident)
    400   (cond
    401     ; unqualified name
    402     ((symbol? ident)
    403       ident )
    404     ; qualified name
    405     ((pair? ident)
    406       (##sys#module-rename
    407         (alist-element-atomic-value ident)
    408         (car ident)) )
    409     (else
    410       #f ) ) )
    411 
    412 (define (!global-ref loc ident)
    413   (let ((ident (make-identifier ident)))
    414     (if (and ident (global-bound? ident)) (global-ref ident)
    415       (error-undefined loc "undefined toplevel variable" ident) ) ) )
     438;;
    416439
    417440;there must be a better way using sys namespace operations.
    418441;(Chicken 4.2.2 had a query for ALL loaded binaries)
    419442
     443; A `library-name' is a pathname or unitname.
    420444(define +loaded-library-names+ '())
    421445
    422446(define (load-code loc libspec)
    423   (let ((unit (if (pair? libspec)
    424                 (and (pair? libspec) (symbol? (car libspec)) (car libspec))
    425                 (and (symbol? libspec) libspec) ) )
    426         (path (if (pair? libspec)
    427                 (and (string? (cadr libspec)) libspec)
    428                 (and (string? libspec) libspec) ) ) )
    429     (unless (member (or path unit) +loaded-library-names+)
    430       (cond
    431         ; Library Unit
    432         ((and unit path)
    433           (load-library unit path) )
    434         ; Library Unit
    435         (unit
    436           (load-library unit) )
    437         ; Must be absolute pathaname, otherwise pathname is relative to
    438         ; "current file"
    439         (path
    440           (load-relative path) )
    441         (else
    442           (error loc "invalid library load specificiation" libspec) ) )
    443       (set! +loaded-library-names+ (cons (or path unit) +loaded-library-names+)) ) ) )
     447  (let ((unit (if (not (pair? libspec)) (and (symbol? libspec) libspec)
     448                (and (pair? libspec) (symbol? (car libspec)) (car libspec))) )
     449        (path (if (not (pair? libspec)) (and (string? libspec) libspec)
     450                (and (string? (cadr libspec)) libspec)) ) )
     451    ; A pathname is preferred to a unitname
     452    (let ((the-name (or path unit)))
     453      (unless (member the-name +loaded-library-names+)
     454        (cond
     455          ; Library Unit w/ path
     456          ((and unit path)
     457            (load-library unit path) )
     458          ; Library Unit
     459          (unit
     460            (load-library unit) )
     461          ; Must be absolute pathaname, otherwise pathname is relative to
     462          ; "current file"
     463          (path
     464            (load-relative path) )
     465          (else
     466            (error loc "invalid library load specificiation" libspec) ) )
     467        (set! +loaded-library-names+ (cons the-name +loaded-library-names+)) ) ) ) )
    444468
    445469(define (fixup-references loc pkgnam vartptnams)
     
    448472      (localized-template-set!
    449473        pkgnam tptnam
    450         (!global-ref loc (!localized-template pkgnam tptnam))) )
     474        (required-global-ref loc (required-localized-template pkgnam tptnam))) )
    451475    vartptnams) )
     476
     477;;
    452478
    453479(define (*load-localized-compiled-code libspec pkgnam vartptnams)
     
    570596(register-feature! 'srfi-29)
    571597
     598;Deprecated
     599(define !localized-template required-localized-template)
     600(define make-!localized-template make-required-localized-template)
     601
    572602) ;module srfi-29
    573603
  • release/4/srfi-29/trunk/srfi-29.setup

    r20306 r20890  
    1616(create-directory/parents (make-repository-pathname "srfi-29-bundles"))
    1717
    18 (setup-shared-extension-module 'srfi-29 (extension-version "2.1.2")
     18(setup-shared-extension-module 'srfi-29 (extension-version "2.1.3")
    1919  #:compile-options '(
    2020    -disable-interrupts ; We got shared data but might not be necessary
    2121    -fixnum-arithmetic
     22    -O3 -d1
    2223    -no-procedure-checks))
Note: See TracChangeset for help on using the changeset viewer.