Changeset 35761 in project


Ignore:
Timestamp:
07/05/18 08:33:15 (3 weeks ago)
Author:
kon
Message:

numbers, rm anaphoric-if, idiom

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

Legend:

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

    r35017 r35761  
    11;;;; coerce-extend.scm
     2;;;; Kon Lovett, Apr '12
    23;;;; Kon Lovett, Sep '09
    3 ;;;; Kon Lovett, Apr '12
    44
    55(module coerce-extend
     
    2626(use
    2727  (only data-structures identity)
    28   (only miscmacros if*)
    2928  (only type-checks check-procedure check-symbol)
    3029  type-extend-support
     
    3332;;;
    3433
    35 (define (->boolean x) (and x #t))
     34(define (->boolean x)
     35  (and x #t) )
    3636
    3737;;;
     
    5050
    5151(define (other-coerce obj result-type default-proc)
    52   (if* (typdef/type (type-of obj))
    53     ((typdef-proc it) obj result-type default-proc)
    54     (default-proc obj result-type)) )
     52  (let ((to-typ (typdef/type (type-of obj))))
     53    (if to-typ
     54      ((typdef-proc to-typ) obj result-type default-proc)
     55      (default-proc obj result-type)) ) )
    5556
    5657(define ((composite-pred pred old-pred) obj)
     
    7576
    7677(define (coerce-extension typ)
    77   (if* (typdef/type (check-symbol 'coerce-extension typ))
    78     (values (typdef-pred it) (typdef-proc it))
    79     (values #f #f) ) )
     78  (let ((to-typ (typdef/type (check-symbol 'coerce-extension typ))))
     79    (if to-typ
     80      (values (typdef-pred to-typ) (typdef-proc to-typ))
     81      (values #f #f) ) ) )
    8082
    8183(define (coerce-composite-extension! typ pred #!optional (proc identity))
    8284  (check-procedure 'extend-coerce pred)
    8385  (check-procedure 'extend-coerce proc)
    84   (if* (typdef/type (check-symbol 'extend-coerce typ))
    85     ;then update old
    86     (let (
    87       (old-pred (typdef-pred it))
    88       (old-proc (typdef-proc it)) )
    89       ; don't replace when same
    90       (unless (and (eq? pred old-pred) (eq? proc old-proc))
    91         (let (
    92           (pred (if (eq? pred old-pred) pred (composite-pred pred old-pred)))
    93           (proc (if (eq? proc old-proc) proc (composite-proc proc old-proc))) )
    94           (typdef-add! typ pred proc) ) ) )
    95     ;else create new
    96     (typdef-add! typ pred proc) ) )
     86  (let ((to-typ (typdef/type (check-symbol 'extend-coerce typ))))
     87    (if to-typ
     88      ;then update old
     89      (let (
     90        (old-pred (typdef-pred to-typ))
     91        (old-proc (typdef-proc to-typ)) )
     92        ;don't replace when same
     93        (unless (and (eq? pred old-pred) (eq? proc old-proc))
     94          (let (
     95            (pred (if (eq? pred old-pred) pred (composite-pred pred old-pred)))
     96            (proc (if (eq? proc old-proc) proc (composite-proc proc old-proc))) )
     97            (typdef-add! typ pred proc) ) ) )
     98      ;else create new
     99      (typdef-add! typ pred proc) ) ) )
    97100
    98101(define (coerce-extension-remove! typ)
  • release/4/coerce/trunk/coerce.meta

    r35017 r35761  
    99 (depends
    1010  (setup-helper "1.5.2")
     11  (check-errors "1.5.0")
    1112  (miscmacros "2.91")
    12         (lookup-table "1.11.0")
    13         (check-errors "1.5.0"))
     13  (numbers "4.6.3")
     14  (lookup-table "1.11.0"))
    1415 (test-depends test)
    1516 (files
     
    1718  "coerce.scm" "coerce-extend.scm"
    1819  "type-of.scm" "type-coerce.scm" "type-extend-support.scm"
    19   "tests/run.scm") )
     20  "tests/run.scm" "tests/coerce-test.scm") )
  • release/4/coerce/trunk/coerce.setup

    r35017 r35761  
    99  #:types? #t
    1010  #:compile-options '(
    11     -scrutinize
    12     -fixnum-arithmetic
    13     -optimize-level 3 -debug-level 0
    14     -no-procedure-checks -no-bound-checks -no-argc-checks))
     11    -scrutinize -O3 -d0 -no-procedure-checks -no-bound-checks -no-argc-checks))
    1512
    1613(setup-shared-extension-module 'type-of (extension-version "2.1.0")
     
    1815  #:types? #t
    1916  #:compile-options '(
    20     -scrutinize
    21     -fixnum-arithmetic
    22     -optimize-level 3
    23     -no-procedure-checks))
     17    -scrutinize -O3 -d1 -no-procedure-checks))
    2418
    2519(setup-shared-extension-module 'coerce-extend (extension-version "2.1.0")
     
    2721  #:types? #t
    2822  #:compile-options '(
    29     -scrutinize
    30     -fixnum-arithmetic
    31     -optimize-level 3 -debug-level 0
    32     -no-procedure-checks -no-bound-checks -no-argc-checks))
     23    -scrutinize -O3 -d0 -no-procedure-checks -no-bound-checks -no-argc-checks))
    3324
    3425(setup-shared-extension-module 'type-coerce (extension-version "2.1.0")
     
    3627  #:types? #t
    3728  #:compile-options '(
    38     -scrutinize
    39     -fixnum-arithmetic
    40     -optimize-level 3
    41     -no-procedure-checks))
     29    -scrutinize -O3 -d1 -no-procedure-checks))
    4230
    4331(setup-shared-extension-module 'coerce (extension-version "2.1.0"))
  • release/4/coerce/trunk/type-coerce.scm

    r35017 r35761  
    3838  coerce-all)
    3939
    40 #|
    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
    66       (import scheme chicken) ) )
    67 |#
    68 
    6940(import scheme chicken)
    7041
    7142(use
     43  numbers
    7244  (only data-structures alist-ref)
    7345  (only srfi-1 every reverse!)
    74   (only miscmacros if*)
    7546  (only type-checks check-procedure check-symbol check-list check-alist)
    7647  (only type-errors signal-type-error)
     
    8758
    8859(define ((*make-case-coerce func al) obj typ err)
    89   (func obj typ (lambda () (if* (alist-ref typ al eq?) (it obj) (err)))) )
     60  (let (
     61    (cr-proc
     62      (lambda ()
     63        (let ((to-proc (alist-ref typ al eq?)))
     64          (if to-proc
     65            (to-proc obj)
     66            (err) ) ) ) ) )
     67    (func obj typ cr-proc) ) )
    9068
    9169;;
     
    10886        (_typ (rnm 'typ)) )
    10987        (let (
    110           (else-clause `(,_else (on-error))))
     88          (else-clause `(,_else (on-error))) )
    11189          (let loop ((clauses (cdr frm)) (sym-clauses '()))
    11290            (if (null? clauses)
     
    137115  (error 'coerce "cannot coerce" obj restyp))
    138116
     117(define (boolean->string obj)
     118  (if obj "#true" "#false") )
     119
    139120(define (coerce obj restyp #!optional (default-proc error-coerce))
    140121  ;
     
    159140                (if obj 1 0) )
    160141              ((string)
    161                 (if obj "true" "false") )
    162               ((keyword)
    163                 (string->keyword (if obj "true" "false")) )
    164               ((symbol)
    165                 (string->symbol (if obj "true" "false")) )
     142                (boolean->string obj) )
     143              ((keyword)
     144                (string->keyword (boolean->string obj)) )
     145              ((symbol)
     146                (string->symbol (boolean->string obj)) )
    166147              ((list)
    167148                (list obj) )
     
    188169              (else
    189170                (other->other) ) ) )
    190           ((number fixnum flonum) ;bignum ratnum compnum
    191             (case restyp
    192               ((atom)
    193                 obj )
    194               ((char)
     171          ((number fixnum flonum bignum ratnum cplxnum)
     172            (case restyp
     173              ((atom)
     174                obj )
     175              ((char)
     176                ;FIXME
    195177                (integer->char obj) )
    196178              ((integer)
     179                ;FIXME
    197180                (inexact->exact obj) )
    198181              ((string)
     
    246229          ((string)
    247230            (case restyp
    248               ((atom)     (or (string->number obj) (string->symbol obj)) )
    249               ((char)
    250                 (if (= 1 (string-length obj))
     231              ((atom)
     232                (or (string->number obj) (string->symbol obj)) )
     233              ((char)
     234                (if (fx= 1 (string-length obj))
    251235                  (string-ref obj 0)
    252236                  (other->other)))
     
    323307
    324308(define (coerce-all flst tlst #!optional default-proc)
    325   (check-list 'coerce-all flst "objects")
    326   (check-list 'coerce-all tlst "types")
    327   #; ;NOT NEEDED
    328   (unless (= (length flst) (length tlst))
     309  (unless
     310    (fx=
     311      (length (check-list 'coerce-all flst "objects"))
     312      (length (check-list 'coerce-all tlst "types")))
    329313    (signal-type-error 'coerce-all "list length mismatch" flst tlst) )
    330314  (map (cut coerce <> <> default-proc) flst tlst) )
  • release/4/coerce/trunk/type-of.scm

    r35017 r35761  
    2929;;  - "struct" vs. "record"
    3030
     31#>
     32#define elif else if
     33/* This could be tighter & faster but also more brittle */
     34
     35static char *
     36basic_type_of( ___scheme_value obj )
     37{
     38  if(C_truep( C_fixnump( obj ) )) {
     39                C_return( "fixnum" );
     40  } elif(C_truep( C_charp( obj ) )) {
     41                C_return( "char" );
     42  } elif(C_truep( C_booleanp( obj ) )) {
     43                C_return( "boolean" );
     44  } elif(C_truep( C_eofp( obj ) )) {
     45                C_return( "eof-object" );
     46  } elif(C_truep( C_undefinedp( obj ) )) {
     47                C_return( "unspecified" );
     48  } elif(C_truep( C_i_nullp( obj ) )) {
     49                C_return( "null" );
     50  } elif(C_truep( C_unboundvaluep( obj ) )) {
     51                C_return( "unbound" );
     52  } elif(C_truep( C_flonump( obj ) )) {
     53                C_return( "flonum" );
     54  } elif(C_truep( C_stringp( obj ) )) {
     55                C_return( "string" );
     56  } elif(C_truep( C_symbolp( obj ) )) {
     57                C_return( "symbol" );
     58  } elif(C_truep( C_pairp( obj ) )) {
     59                C_return( "pair" );
     60  } elif(C_truep( C_closurep( obj ) )) {
     61                C_return( "procedure" );
     62  } elif(C_truep( C_vectorp( obj ) )) {
     63                C_return( "vector" );
     64  } elif(C_truep( C_bytevectorp( obj ) )) {
     65                C_return( "blob" );
     66  } elif(C_truep( C_portp( obj ) )) {
     67                C_return( "port" );
     68  } elif(C_truep( C_structurep( obj ) )) {
     69                C_return( "record" );
     70  } elif(C_truep( C_locativep( obj ) )) {
     71                C_return( "locative" );
     72  } elif(C_truep( C_pointerp( obj ) )) {
     73                C_return( "pointer" );
     74  } elif(C_truep( C_taggedpointerp( obj ) )) {
     75                C_return( "tagged-pointer" );
     76  } elif(C_truep( C_swigpointerp( obj ) )) {
     77                C_return( "swig-pointer" );
     78  } elif(C_truep( C_lambdainfop( obj ) )) {
     79                C_return( "lambda-info" );
     80        }
     81  /* assume bucket */
     82  C_return( "bucket" );
     83}
     84
     85static int
     86basic_same_typep( ___scheme_value a,  ___scheme_value b )
     87{
     88  if(C_immediatep( a )) {
     89    if(C_immediatep( b )) {
     90      if(C_truep( C_fixnump( a ) )) {
     91                                C_return( C_truep( C_fixnump( b ) ) );
     92      } elif(C_truep( C_charp( a ) )) {
     93                                C_return( C_truep( C_charp( b ) ) );
     94      } elif(C_truep( C_booleanp( a ) )) {
     95                                C_return( C_truep( C_booleanp( b ) ) );
     96      } elif(C_truep( C_eofp( a ) )) {
     97                                C_return( C_truep( C_eofp( b ) ) );
     98      } elif(C_truep( C_unboundvaluep( a ) )) {
     99                                C_return( C_truep( C_unboundvaluep( b ) ) );
     100      } elif(C_truep( C_i_nullp( a ) )) {
     101                                C_return( C_truep( C_i_nullp( b ) ) );
     102      } elif(C_truep( C_undefinedp( a ) )) {
     103                                C_return( C_truep( C_undefinedp( b ) ) );
     104                        }
     105    }
     106    C_return( 0 );
     107  }
     108  C_return( C_truep( C_sametypep( a, b ) ) );
     109}
     110<#
     111
    31112(module type-of
    32113
     
    37118  same-type?)
    38119
    39 (import
    40   scheme chicken foreign)
    41 
     120(import scheme chicken foreign)
    42121(use
     122  numbers
    43123  (only lolevel record-instance-type))
    44124
    45125;;;
    46 
    47 #>
    48 /* This could be tighter & faster but also more brittle */
    49 
    50 static char *
    51 basic_type_of( ___scheme_value obj )
    52 {
    53   if (C_truep( C_fixnump( obj ) )) {
    54                 C_return( "fixnum" );
    55   } else if (C_truep( C_charp( obj ) )) {
    56                 C_return( "char" );
    57   } else if (C_truep( C_booleanp( obj ) )) {
    58                 C_return( "boolean" );
    59   } else if (C_truep( C_eofp( obj ) )) {
    60                 C_return( "eof-object" );
    61   } else if (C_truep( C_undefinedp( obj ) )) {
    62                 C_return( "unspecified" );
    63   } else if (C_truep( C_i_nullp( obj ) )) {
    64                 C_return( "null" );
    65   } else if (C_truep( C_unboundvaluep( obj ) )) {
    66                 C_return( "unbound" );
    67   } else if (C_truep( C_flonump( obj ) )) {
    68                 C_return( "flonum" );
    69   } else if (C_truep( C_stringp( obj ) )) {
    70                 C_return( "string" );
    71   } else if (C_truep( C_symbolp( obj ) )) {
    72                 C_return( "symbol" );
    73   } else if (C_truep( C_pairp( obj ) )) {
    74                 C_return( "pair" );
    75   } else if (C_truep( C_closurep( obj ) )) {
    76                 C_return( "procedure" );
    77   } else if (C_truep( C_vectorp( obj ) )) {
    78                 C_return( "vector" );
    79   } else if (C_truep( C_bytevectorp( obj ) )) {
    80                 C_return( "blob" );
    81   } else if (C_truep( C_portp( obj ) )) {
    82                 C_return( "port" );
    83   } else if (C_truep( C_structurep( obj ) )) {
    84                 C_return( "record" );
    85   } else if (C_truep( C_locativep( obj ) )) {
    86                 C_return( "locative" );
    87   } else if (C_truep( C_pointerp( obj ) )) {
    88                 C_return( "pointer" );
    89   } else if (C_truep( C_taggedpointerp( obj ) )) {
    90                 C_return( "tagged-pointer" );
    91   } else if (C_truep( C_swigpointerp( obj ) )) {
    92                 C_return( "swig-pointer" );
    93   } else if (C_truep( C_lambdainfop( obj ) )) {
    94                 C_return( "lambda-info" );
    95         } else {
    96     C_return( "bucket" );
    97   }
    98 }
    99 
    100 static int
    101 basic_same_typep( ___scheme_value a,  ___scheme_value b )
    102 {
    103   if (C_immediatep( a )) {
    104     if (C_immediatep( b )) {
    105       if (C_truep( C_fixnump( a ) )) {
    106                                 C_return( C_truep( C_fixnump( b ) ) );
    107       } else if (C_truep( C_charp( a ) )) {
    108                                 C_return( C_truep( C_charp( b ) ) );
    109       } else if (C_truep( C_booleanp( a ) )) {
    110                                 C_return( C_truep( C_booleanp( b ) ) );
    111       } else if (C_truep( C_eofp( a ) )) {
    112                                 C_return( C_truep( C_eofp( b ) ) );
    113       } else if (C_truep( C_unboundvaluep( a ) )) {
    114                                 C_return( C_truep( C_unboundvaluep( b ) ) );
    115       } else if (C_truep( C_i_nullp( a ) )) {
    116                                 C_return( C_truep( C_i_nullp( b ) ) );
    117       } else if (C_truep( C_undefinedp( a ) )) {
    118                                 C_return( C_truep( C_undefinedp( b ) ) );
    119                         }
    120     } else {
    121       C_return( 0 );
    122     }
    123   } else {
    124     C_return( C_truep( C_sametypep( a, b ) ) );
    125   }
    126 }
    127 <#
    128126
    129127;;
     
    168166                          (if (keyword? obj) 'keyword 'symbol) )
    169167      ((record)
    170                           (record-instance-type obj) )
     168        (if (number? obj)
     169          (cond
     170            ((bignum? obj)  'bignum )
     171            ((ratnum? obj)  'ratnum )
     172            ((cplxnum? obj) 'cplxnum )
     173            (else           (record-instance-type obj) ) )
     174                            (record-instance-type obj) ) )
    171175      ((port)
    172176                          (if (input-port? obj) 'input-port 'output-port) )
     
    174178        typ ) ) ) )
    175179
    176 #; ;has old semantic but think wrong
     180#|
     181;has old semantic but think wrong
    177182(define (type-of obj)
    178   ; slooow
     183  ;slooow
    179184  (or
    180185    (other-type-of obj)
     
    187192        ((record)
    188193                                  (record-instance-type obj) )
    189         ; think just wrong
     194        ;think just wrong
    190195        ((fixnum flonum)
    191196          'number )
     
    196201
    197202;Use moremacros#typecase
    198 #; ;original
     203;original
    199204(define (type-of obj)
    200205  (cond
     
    260265        (other-type-of obj)
    261266        'object) ) ) )
     267|#
    262268
    263269) ;module type-of
Note: See TracChangeset for help on using the changeset viewer.