Changeset 16004 in project


Ignore:
Timestamp:
09/21/09 00:44:19 (10 years ago)
Author:
Kon Lovett
Message:

Forgot record

Location:
release/4/coerce/trunk
Files:
2 added
2 edited

Legend:

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

    r16000 r16004  
    2424;;
    2525;; - Cannot know before attempt if coercion possible.
     26;;
     27;; - The coercion of a composite object to a scalar often makes no sense.
    2628
    2729(module type-coerce (;export
     
    3436          chicken
    3537          (only data-structures alist-ref)
     38          (only lolevel record->vector)
    3639          (only srfi-1 every reverse!)
    3740          (only miscmacros if*)
     
    4043          type-of)
    4144
    42   (require-library data-structures srfi-1 miscmacros type-checks type-errors type-of)
     45  (require-library data-structures lolevel srfi-1
     46                   miscmacros type-checks type-errors type-of)
     47
     48;;;
     49
     50#; ;NOT YET
     51(define (vector->record x)
     52  (##sys#check-vector x 'vector->record)
     53  (let* ((n (##sys#size x))
     54               (v (##sys#make-structure/size n)) )
     55    (do ((i 0 (fx+ i 1)))
     56              ((fx>= i n) v)
     57      (##sys#setslot v i (##sys#slot x i)) ) ) )
     58
     59(define (string->vector x) (list->vector (string->list x)))
     60(define (vector->string x) (list->string (vector->list x)))
     61
     62#| ;JOKE
     63(define (record->string x) (vector->string (record->vector x)))
     64(define (string->record x) (vector->record (string->vector x)))
     65|#
    4366
    4467;;; Extension
     
    87110;;@2 (which must be one of these symbols).
    88111
    89 (define (error-coerce obj result-type) (error 'coerce "cannot coerce" obj result-type))
    90 
    91 (define (coerce obj result-type #!optional (default-proc error-coerce))
    92   (define (other->other) (other-coerce obj result-type default-proc))
    93   (check-symbol 'coerce result-type 'result-type)
     112(define (error-coerce obj restyp) (error 'coerce "cannot coerce" obj restyp))
     113
     114(define (coerce obj restyp #!optional (default-proc error-coerce))
     115  (define (other->other) (other-coerce obj restyp default-proc))
     116  (check-symbol 'coerce restyp 'result-type)
    94117  (when default-proc (check-procedure 'coerce default-proc 'default-proc))
    95118  (let ((objtyp (type-of obj)))
    96     (if (eq? objtyp result-type) obj
     119    (if (eq? objtyp restyp) obj
    97120        (case objtyp
    98           ((char)   (case result-type
    99                       ((number integer) (char->integer obj) )
    100                       ((string) (string obj) )
    101                       ((symbol) (string->symbol (string obj)) )
    102                       ((list)   (list obj) )
    103                       ((vector) (vector obj) )
    104                       (else     (other->other) ) ) )
    105           ((number) (case result-type
    106                       ((char)    (integer->char obj) )
    107                       ((atom)    obj )
    108                       ((integer) (inexact->exact obj) )
    109                       ((string)  (number->string obj) )
    110                       ((symbol)  (string->symbol (number->string obj)) )
    111                       ((list)    (string->list (number->string obj)) )
    112                       ((vector)  (list->vector (string->list (number->string obj))) )
    113                       (else      (other->other) ) ) )
    114           ((string) (case result-type
    115                       ((char)
    116                         (if (= 1 (string-length obj)) (string-ref obj 0)
    117                             (other->other)))
    118                       ((atom)   (or (string->number obj) (string->symbol obj)) )
    119                       ((number integer) (or (string->number obj) (other->other)) )
    120                       ((symbol) (string->symbol obj) )
    121                       ((list)   (string->list obj) )
    122                       ((vector) (list->vector (string->list obj)) )
    123                       (else     (other->other) ) ) )
    124           ((symbol) (case result-type
    125                       ((char)   (coerce (symbol->string obj) 'char) )
    126                       ((number integer) (coerce (symbol->string obj) result-type) )
    127                       ((string) (symbol->string obj) )
    128                       ((atom)   obj )
    129                       ((list)   (string->list (symbol->string obj)) )
    130                       ((vector) (list->vector (string->list (symbol->string obj))) )
    131                       (else     (other->other) ) ) )
    132           ((list)   (case result-type
    133                       ((char)
    134                         (if (and (= 1 (length obj)) (char? (car obj))) (car obj)
    135                             (other->other)) )
    136                       ((number integer)
    137                        (or (string->number (list->string obj)) (other->other)) )
    138                       ((string) (list->string obj) )
    139                       ((symbol) (string->symbol (list->string obj)) )
    140                       ((vector) (list->vector obj) )
    141                       (else     (other->other) ) ) )
    142           ((vector) (case result-type
    143                       ((char)
    144                         (if (and (= 1 (vector-length obj)) (char? (vector-ref obj 0)))
    145                             (vector-ref obj 0)
    146                             (other->other)) )
    147                       ((number integer )
    148                         (or (string->number (coerce obj 'string)) (other->other)) )
    149                       ((string) (list->string (vector->list obj)) )
    150                       ((symbol) (string->symbol (coerce obj 'string)) )
    151                       ((list)   (list->vector obj) )
    152                       (else     (other->other) ) ) )
    153           (else     (other->other) ) ) ) ) )
     121          ((char)
     122            (case restyp
     123              ((atom)     obj )
     124              ((number integer)
     125                (char->integer obj) )
     126              ((string)   (string obj) )
     127              ((keyword)  (string->keyword (number->string obj)) )
     128              ((symbol)   (string->keyword (number->string obj)) )
     129              ((list)     (list obj) )
     130              ((vector)   (vector obj) )
     131              (else       (other->other) ) ) )
     132          ((number)
     133            (case restyp
     134              ((atom)     obj )
     135              ((char)     (integer->char obj) )
     136              ((integer)  (inexact->exact obj) )
     137              ((string)   (number->string obj) )
     138              ((keyword)  (string->keyword (number->string obj)) )
     139              ((symbol)   (string->symbol (number->string obj)) )
     140              ((list)     (string->list (number->string obj)) )
     141              ((vector)   (string->vector (number->string obj)) )
     142              (else       (other->other) ) ) )
     143          ((keyword)
     144            (case restyp
     145              ((atom)     obj )
     146              ((char)     (coerce (keyword->string obj) 'char) )
     147              ((number integer)
     148                (coerce (keyword->string obj) restyp) )
     149              ((string)   (keyword->string obj) )
     150              ((symbol)   (string->symbol (keyword->string obj)) )
     151              ((list)     (string->list (keyword->string obj)) )
     152              ((vector)   (string->vector (keyword->string obj)) )
     153              (else       (other->other) ) ) )
     154          ((symbol)
     155            (case restyp
     156              ((atom)     obj )
     157              ((char)     (coerce (symbol->string obj) 'char) )
     158              ((number integer)
     159                (coerce (symbol->string obj) restyp) )
     160              ((string)   (symbol->string obj) )
     161              ((keyword)  (string->keyword (symbol->string obj)) )
     162              ((list)     (string->list (symbol->string obj)) )
     163              ((vector)   (string->vector (symbol->string obj)) )
     164              (else       (other->other) ) ) )
     165          ((string)
     166            (case restyp
     167              ((atom)     (or (string->number obj) (string->symbol obj)) )
     168              ((char)
     169                (if (= 1 (string-length obj)) (string-ref obj 0)
     170                    (other->other)))
     171              ((number integer)
     172                (or (string->number obj)
     173                    (other->other)) )
     174              ((keyword)  (string->keyword obj) )
     175              ((symbol)   (string->symbol obj) )
     176              ((list)     (string->list obj) )
     177              ((vector)   (string->vector obj) )
     178              #; ;JOKE
     179              ((record-instance)
     180                (record->string obj) )
     181              (else       (other->other) ) ) )
     182          ((list)
     183            (case restyp
     184              ((atom)     (coerce (list->string obj) 'atom) )
     185              ((char)
     186                (if (and (= 1 (length obj)) (char? (car obj)))
     187                    (car obj)
     188                    (other->other)) )
     189              ((number integer)
     190               (or (string->number (list->string obj))
     191                   (other->other)) )
     192              ((string)   (list->string obj) )
     193              ((keyword)  (string->keyword (list->string obj)) )
     194              ((symbol)   (string->symbol (list->string obj)) )
     195              ((vector)   (list->vector obj) )
     196              #; ;NOT YET
     197              ((record-instance)
     198                (vector->record (list->vector obj)) )
     199              (else       (other->other) ) ) )
     200          ((vector)
     201            (case restyp
     202              ((atom)     (coerce (vector->string obj) 'atom) )
     203              ((char)
     204                (if (and (= 1 (vector-length obj)) (char? (vector-ref obj 0)))
     205                    (vector-ref obj 0)
     206                    (other->other)) )
     207              ((number integer )
     208                (or (string->number (coerce obj 'string))
     209                    (other->other)) )
     210              ((string)   (vector->string obj) )
     211              ((keyword)  (string->keyword (vector->string obj)) )
     212              ((symbol)   (string->symbol (vector->string obj)) )
     213              ((list)     (vector->list obj) )
     214              #; ;NOT YET
     215              ((record-instance)
     216                (vector->record obj) )
     217              (else       (other->other) ) ) )
     218          ((record-instance)
     219            (case restyp
     220              #| ;JOKE
     221              ((atom)     (coerce (record->string obj 'atom) )
     222              ((char)
     223                (if (and (= 1 (record-instance-length obj)) (char? (record-instance-slot obj 0)))
     224                    (record-instance-slot obj 0)
     225                    (other->other)) )
     226              ((number integer)
     227               (or (string->number (record->string obj)
     228                   (other->other)) )
     229              ((string)   (record->string obj )
     230              ((keyword)  (string->keyword (record->string obj) )
     231              ((symbol)   (string->symbol (record->string obj) )
     232              |#
     233              ((list)     (vector->list (record->vector obj)) )
     234              ((vector)   (record->vector obj) )
     235              (else       (other->other) ) ) )
     236          (else
     237            (other->other) ) ) ) ) )
    154238
    155239;;
     
    158242  (check-list 'coerce-all flst "objects")
    159243  (check-list 'coerce-all tlst "types")
    160   #; ;UNNEEDED
     244  #; ;NOT NEEDED
    161245  (unless (= (length flst) (length tlst))
    162246    (signal-type-error 'coerce-all "list length mismatch" flst tlst) )
  • release/4/coerce/trunk/type-of.scm

    r15998 r16004  
    4141          chicken
    4242          (only data-structures identity)
     43          (only lolevel record-instance?)
    4344          (only miscmacros if*)
    4445          (only type-checks check-procedure check-symbol)
    4546          type-extend-support)
    4647
    47   (require-library data-structures miscmacros type-checks type-extend-support)
     48  (require-library data-structures lolevel miscmacros
     49                   type-checks type-extend-support)
    4850
    4951;;@body
     
    5153
    5254(define (type-of obj)
    53   (cond ((boolean? obj)       'boolean)
    54         ((char? obj)          'char)
    55         ((number? obj)        'number)
    56         ((string? obj)        'string)
    57         ((symbol? obj)        'symbol)
    58         ((input-port? obj)    'port)
    59         ((output-port? obj)   'port)
    60         ((procedure? obj)     'procedure)
    61         ((eof-object? obj)    'eof-object)
    62         ((list? obj)          'list)
    63         ((pair? obj)          'pair)
    64         ((vector? obj)        'vector)
    65         (else                 (or (other-type-of obj)
    66                                   'scheme-object)) ) )
     55  (cond ((boolean? obj)           'boolean)
     56        ((char? obj)              'char)
     57        ((number? obj)            'number)
     58        ((string? obj)            'string)
     59        ((keyword? obj)           'keyword)
     60        ((symbol? obj)            'symbol)
     61        ((input-port? obj)        'port)
     62        ((output-port? obj)       'port)
     63        ((procedure? obj)         'procedure)
     64        ((eof-object? obj)        'eof-object)
     65        ((list? obj)              'list)
     66        ((pair? obj)              'pair)
     67        ((vector? obj)            'vector)
     68        ((record-instance? obj)   'record-instance)
     69        ((eq? (void) obj)         'unspecified)
     70        (else
     71          (or (other-type-of obj)
     72              'scheme-object) ) ) )
    6773
    6874;;;
Note: See TracChangeset for help on using the changeset viewer.