Changeset 34679 in project


Ignore:
Timestamp:
10/01/17 20:11:08 (3 months ago)
Author:
kon
Message:

#1420 fix

Location:
release/4/coerce/trunk
Files:
6 edited

Legend:

Unmodified
Added
Removed
  • release/4/coerce/trunk/coerce-extend.scm

    r26589 r34679  
    55(module coerce-extend
    66
    7   (;export
    8     extended-type-of
    9     ;;
    10     coerce-extend!
    11     coerce-composite-extension!
    12     coerce-extended?
    13     coerce-extension
    14     coerce-extension-remove!
    15     ;;
    16     type-of-extended?
    17     type-of-extend!
    18     type-of-extension
    19     type-of-composite-extension!
    20     type-of-remove!
    21     ;;
    22     other-coerce)
     7(;export
     8  extended-type-of
     9  ;;
     10  coerce-extend!
     11  coerce-composite-extension!
     12  coerce-extended?
     13  coerce-extension
     14  coerce-extension-remove!
     15  ;;
     16  type-of-extended?
     17  type-of-extend!
     18  type-of-extension
     19  type-of-composite-extension!
     20  type-of-remove!
     21  ;;
     22  other-coerce)
    2323
    24   (import
    25     scheme chicken
    26     (only data-structures identity)
    27     (only miscmacros if*)
    28     (only type-checks check-procedure check-symbol)
    29     type-extend-support
    30     type-of)
     24(import
     25  scheme chicken
     26  (only data-structures identity)
     27  (only miscmacros if*)
     28  (only type-checks check-procedure check-symbol)
     29  type-extend-support
     30  type-of)
    3131
    32   (require-library
    33     data-structures
    34     miscmacros
    35     type-checks
    36     type-extend-support
    37     type-of)
     32(require-library
     33  data-structures
     34  miscmacros
     35  type-checks
     36  type-extend-support
     37  type-of)
    3838
    3939;;;
     
    4444
    4545(define (extended-type-of obj)
    46   (or (other-type-of obj)
    47       (type-of obj)) )
     46  (or
     47    (other-type-of obj)
     48    (type-of obj)) )
    4849
    4950;;;
     
    5455
    5556(define (other-coerce obj result-type default-proc)
    56   (if* (typdef/type (type-of obj)) ((typdef-proc it) obj result-type default-proc)
    57        (default-proc obj result-type)) )
     57  (if* (typdef/type (type-of obj))
     58    ((typdef-proc it) obj result-type default-proc)
     59    (default-proc obj result-type)) )
    5860
    5961(define ((composite-pred pred old-pred) obj)
    60   (or (pred obj) (old-pred obj)) )
     62  (or
     63    (pred obj)
     64    (old-pred obj)) )
    6165
    6266(define ((composite-proc proc old-proc) obj typ err)
     
    7781(define (coerce-extension typ)
    7882  (check-symbol 'coerce-extension typ)
    79   (if* (typdef/type typ) (values (typdef-pred it) (typdef-proc it))
    80        (values #f #f) ) )
     83  (if* (typdef/type typ)
     84    (values (typdef-pred it) (typdef-proc it))
     85    (values #f #f) ) )
    8186
    8287(define (coerce-composite-extension! typ pred #!optional (proc identity))
  • release/4/coerce/trunk/coerce.scm

    r26589 r34679  
    66(module coerce
    77
    8   (;export
    9     ;; Original
    10     coerce
    11     type-of
    12     ;; Type Testing Extensions
    13     basic-type-of
    14     basic-same-type?
    15     same-type?
    16     ;; Coerce Extensions
    17     (case-coerce *make-case-coerce)
    18     case-coerce
    19     coerce-all
    20     ;; Type Domain Extension
    21     coerce-extended?
    22     coerce-extend!
    23     coerce-extension
    24     coerce-composite-extension!
    25     coerce-extension-remove!
    26     ;;
    27     extended-type-of
    28     type-of-extended?
    29     type-of-extend!
    30     type-of-extension
    31     type-of-composite-extension!
    32     type-of-remove!)
     8(;export
     9  ;; Original
     10  coerce
     11  type-of
     12  ;; Type Testing Extensions
     13  basic-type-of
     14  basic-same-type?
     15  same-type?
     16  ;; Coerce Extensions
     17  (case-coerce *make-case-coerce)
     18  case-coerce
     19  coerce-all
     20  ;; Type Domain Extension
     21  coerce-extended?
     22  coerce-extend!
     23  coerce-extension
     24  coerce-composite-extension!
     25  coerce-extension-remove!
     26  ;;
     27  extended-type-of
     28  type-of-extended?
     29  type-of-extend!
     30  type-of-extension
     31  type-of-composite-extension!
     32  type-of-remove!)
    3333
    34   (import scheme chicken type-coerce type-of coerce-extend)
     34(import scheme chicken type-coerce type-of coerce-extend)
    3535
    36   (require-library type-coerce type-of coerce-extend)
     36(require-library type-coerce type-of coerce-extend)
    3737
    3838) ;module coerce
  • release/4/coerce/trunk/coerce.setup

    r26588 r34679  
    55(verify-extension-name "coerce")
    66
    7 (setup-shared-extension-module 'type-extend-support (extension-version "2.0.0")
     7(setup-shared-extension-module 'type-extend-support (extension-version "2.0.1")
    88  #:inline? #t
    99  #:types? #t
     
    1414    -no-procedure-checks -no-bound-checks -no-argc-checks))
    1515
    16 (setup-shared-extension-module 'type-of (extension-version "2.0.0")
     16(setup-shared-extension-module 'type-of (extension-version "2.0.1")
    1717  #:inline? #t
    1818  #:types? #t
     
    2323    -no-procedure-checks))
    2424
    25 (setup-shared-extension-module 'coerce-extend (extension-version "2.0.0")
     25(setup-shared-extension-module 'coerce-extend (extension-version "2.0.1")
    2626  #:inline? #t
    2727  #:types? #t
     
    3232    -no-procedure-checks -no-bound-checks -no-argc-checks))
    3333
    34 (setup-shared-extension-module 'type-coerce (extension-version "2.0.0")
     34(setup-shared-extension-module 'type-coerce (extension-version "2.0.1")
    3535  #:inline? #t
    3636  #:types? #t
     
    4141    -no-procedure-checks))
    4242
    43 (setup-shared-extension-module 'coerce (extension-version "2.0.0"))
     43(setup-shared-extension-module 'coerce (extension-version "2.0.1"))
  • release/4/coerce/trunk/type-coerce.scm

    r26589 r34679  
    3232(module type-coerce
    3333
    34   (;export
    35     make-case-coerce
    36     (case-coerce *make-case-coerce) *make-case-coerce
    37     coerce
    38     coerce-all)
     34(;export
     35  make-case-coerce
     36  (case-coerce *make-case-coerce) *make-case-coerce
     37  coerce
     38  coerce-all)
    3939
    4040#|
    41   (cond-expand
    42     (full-numeric-tower
    43       (import
    44         (except scheme
    45           + - * / = > < >= <=
    46           number->string string->number
    47           eqv? equal?
    48           exp log sin cos tan atan acos asin expt sqrt
    49           quotient modulo remainder
    50           numerator denominator
    51           abs max min gcd lcm
    52           positive? negative? odd? even? zero?
    53           exact? inexact?
    54           rationalize
    55           floor ceiling truncate round
    56           inexact->exact exact->inexact
    57           number? complex? real? rational? integer?
    58           make-rectangular make-polar real-part imag-part magnitude angle)
    59         (except chicken
    60           add1 sub1 random randomize conj signum
    61           force-finalizers
    62           bitwise-and bitwise-ior bitwise-xor bitwise-not arithmetic-shift)
    63         numbers)
    64       (require-library numbers) )
    65     (else
     41(cond-expand
     42  (full-numeric-tower
     43    (import
     44      (except scheme
     45        + - * / = > < >= <=
     46        number->string string->number
     47        eqv? equal?
     48        exp log sin cos tan atan acos asin expt sqrt
     49        quotient modulo remainder
     50        numerator denominator
     51        abs max min gcd lcm
     52        positive? negative? odd? even? zero?
     53        exact? inexact?
     54        rationalize
     55        floor ceiling truncate round
     56        inexact->exact exact->inexact
     57        number? complex? real? rational? integer?
     58        make-rectangular make-polar real-part imag-part magnitude angle)
     59      (except chicken
     60        add1 sub1 random randomize conj signum
     61        force-finalizers
     62        bitwise-and bitwise-ior bitwise-xor bitwise-not arithmetic-shift)
     63      numbers)
     64    (require-library numbers) )
     65  (else
    6666      (import scheme chicken) ) )
    6767|#
    6868
    69   (import
    70     scheme
    71     chicken
    72     (only data-structures alist-ref)
    73     (only srfi-1 every reverse!)
    74     (only miscmacros if*)
    75     (only type-checks check-procedure check-symbol check-list check-alist)
    76     (only type-errors signal-type-error)
    77     type-of
    78     coerce-extend)
    79 
    80   (require-library
    81     data-structures srfi-1
    82     miscmacros type-checks type-errors
    83     type-of coerce-extend)
     69(import scheme)
     70
     71(import chicken)
     72
     73(import
     74  (only data-structures alist-ref)
     75  (only srfi-1 every reverse!)
     76  (only miscmacros if*)
     77  (only type-checks check-procedure check-symbol check-list check-alist)
     78  (only type-errors signal-type-error)
     79  type-of
     80  coerce-extend)
     81
     82(require-library
     83  data-structures srfi-1
     84  miscmacros type-checks type-errors
     85  type-of coerce-extend)
    8486
    8587;;;
  • release/4/coerce/trunk/type-extend-support.scm

    r23807 r34679  
    44(module type-extend-support
    55
    6   (;export
    7     typdef-type
    8     typdef-pred
    9     typdef-proc
    10     typdef-add!
    11     typdef-delete!
    12     typdef/object
    13     typdef/type)
     6(;export
     7  typdef-type
     8  typdef-pred
     9  typdef-proc
     10  typdef-add!
     11  typdef-delete!
     12  typdef/object
     13  typdef/type)
    1414
    15   (import scheme chicken lookup-table-synch)
     15(import scheme)
    1616
    17   (require-library lookup-table-synch)
     17(import chicken)
     18
     19(import srfi-18)
     20(require-library srfi-18)
     21
     22(import lookup-table-synch)
     23(require-library lookup-table-synch)
    1824
    1925;;
  • release/4/coerce/trunk/type-of.scm

    r26589 r34679  
    8080(module type-of
    8181
    82   (;export
    83     basic-type-of
    84     basic-same-type?
    85     type-of
    86     same-type?)
     82(;export
     83  basic-type-of
     84  basic-same-type?
     85  type-of
     86  same-type?)
    8787
    88   (import
    89     scheme chicken foreign
    90     (only lolevel record-instance-type))
     88(import
     89  scheme chicken foreign
     90  (only lolevel record-instance-type))
    9191
    92   (require-library
    93     lolevel)
     92(require-library
     93  lolevel)
    9494
    9595;;;
     
    113113
    114114(define (same-type? a b)
    115   (and (basic-same-type? a b)
    116        (case (basic-type-of a)
    117          ((record) (eq? (record-instance-type a) (record-instance-type b)) )
    118          ((port)   (if (input-port? a) (input-port? b) (output-port? b)) )
    119          (else     #t ) ) ) )
     115  (and
     116    (basic-same-type? a b)
     117    (case (basic-type-of a)
     118      ((record) (eq? (record-instance-type a) (record-instance-type b)) )
     119      ((port)   (if (input-port? a) (input-port? b) (output-port? b)) )
     120      (else     #t ) ) ) )
    120121
    121122;;
     
    135136(define (type-of obj)
    136137  ; slooow
    137   (or (other-type-of obj)
    138       (let ((typ (basic-type-of obj)))
    139         (case typ
    140           ((symbol)         (if (keyword? obj) 'keyword 'symbol) )
    141           ((port)           (if (input-port? obj) 'input-port 'output-port) )
    142           ((record)         (record-instance-type obj) )
    143           ; think just wrong
    144           ((fixnum flonum)  'number )
    145           ((null pair)      'list )
    146           (else             typ ) ) ) ) )
     138  (or
     139    (other-type-of obj)
     140    (let ((typ (basic-type-of obj)))
     141      (case typ
     142        ((symbol)         (if (keyword? obj) 'keyword 'symbol) )
     143        ((port)           (if (input-port? obj) 'input-port 'output-port) )
     144        ((record)         (record-instance-type obj) )
     145        ; think just wrong
     146        ((fixnum flonum)  'number )
     147        ((null pair)      'list )
     148        (else             typ ) ) ) ) )
    147149
    148150;Use moremacros#typecase
     
    180182    ;FIXME will never reach here unless 'bucket
    181183    (else
    182       (or (other-type-of obj)
    183           'object) ) ) )
     184      (or
     185        (other-type-of obj)
     186        'object) ) ) )
    184187
    185188) ;module type-of
Note: See TracChangeset for help on using the changeset viewer.