module/slib/coerce.scm

   1 ;;"coerce.scm" Scheme Implementation of COMMON-LISP COERCE and TYPE-OF.
   2 ; Copyright (C) 1995, 2001 Aubrey Jaffer.
   3 ;
   4 ;Permission to copy this software, to redistribute it, and to use it
   5 ;for any purpose is granted, subject to the following restrictions and
   6 ;understandings.
   7 ;
   8 ;1.  Any copy made of this software must include this copyright notice
   9 ;in full.
  10 ;
  11 ;2.  I have made no warrantee or representation that the operation of
  12 ;this software will be error-free, and I am under no obligation to
  13 ;provide any services, by way of maintenance, update, or otherwise.
  14 ;
  15 ;3.  In conjunction with products arising from the use of this
  16 ;material, there shall be no use of my name in any advertising,
  17 ;promotional, or sales literature without prior written consent in
  18 ;each case.
  19
  20 ;;@body
  21 ;;Returns a symbol name for the type of @1.
  22 (define (type-of obj)
  23   (cond
  24    ;;((null? obj)               'null)
  25    ((boolean? obj)      'boolean)
  26    ((char? obj)         'char)
  27    ((number? obj)       'number)
  28    ((string? obj)       'string)
  29    ((symbol? obj)       'symbol)
  30    ((input-port? obj)   'port)
  31    ((output-port? obj)  'port)
  32    ((procedure? obj)    'procedure)
  33    ((eof-object? obj)   'eof-object)
  34    ((list? obj)         'list)
  35    ((pair? obj)         'pair)
  36    ((and (provided? 'array) (array? obj))       'array)
  37    ((and (provided? 'record) (record? obj))     'record)
  38    ((vector? obj)       'vector)
  39    (else                '?)))
  40
  41 ;;@body
  42 ;;Converts and returns @1 of type @code{char}, @code{number},
  43 ;;@code{string}, @code{symbol}, @code{list}, or @code{vector} to
  44 ;;@2 (which must be one of these symbols).
  45 (define (coerce obj result-type)
  46   (define (err) (slib:error 'coerce 'not obj '-> result-type))
  47   (define obj-type (type-of obj))
  48   (cond
  49    ((eq? obj-type result-type) obj)
  50    (else
  51     (case obj-type
  52       ((char)   (case result-type
  53                   ((number integer) (char->integer obj))
  54                   ((string) (string obj))
  55                   ((symbol) (string->symbol (string obj)))
  56                   ((list)   (list obj))
  57                   ((vector) (vector obj))
  58                   (else     (err))))
  59       ((number) (case result-type
  60                   ((char)   (integer->char obj))
  61                   ((atom)   obj)
  62                   ((integer) obj)
  63                   ((string) (number->string obj))
  64                   ((symbol) (string->symbol (number->string obj)))
  65                   ((list)   (string->list (number->string obj)))
  66                   ((vector) (list->vector (string->list (number->string obj))))
  67                   (else     (err))))
  68       ((string) (case result-type
  69                   ((char)   (if (= 1 (string-length obj)) (string-ref obj 0)
  70                                 (err)))
  71                   ((atom)   (or (string->number obj) (string->symbol obj)))
  72                   ((number integer) (or (string->number obj) (err)))
  73                   ((symbol) (string->symbol obj))
  74                   ((list)   (string->list obj))
  75                   ((vector) (list->vector (string->list obj)))
  76                   (else     (err))))
  77       ((symbol) (case result-type
  78                   ((char)   (coerce (symbol->string obj) 'char))
  79                   ((number integer) (coerce (symbol->string obj) 'number))
  80                   ((string) (symbol->string obj))
  81                   ((atom)   obj)
  82                   ((list)   (string->list (symbol->string obj)))
  83                   ((vector) (list->vector (string->list (symbol->string obj))))
  84                   (else     (err))))
  85       ((list)   (case result-type
  86                   ((char)   (if (and (= 1 (length obj))
  87                                      (char? (car obj)))
  88                                 (car obj)
  89                                 (err)))
  90                   ((number integer)
  91                    (or (string->number (list->string obj)) (err)))
  92                   ((string) (list->string obj))
  93                   ((symbol) (string->symbol (list->string obj)))
  94                   ((vector) (list->vector obj))
  95                   (else     (err))))
  96       ((vector) (case result-type
  97                   ((char)   (if (and (= 1 (vector-length obj))
  98                                      (char? (vector-ref obj 0)))
  99                                 (vector-ref obj 0)
 100                                 (err)))
 101                   ((number integer)
 102                    (or (string->number (coerce obj string)) (err)))
 103                   ((string) (list->string (vector->list obj)))
 104                   ((symbol) (string->symbol (coerce obj string)))
 105                   ((list)   (list->vector obj))
 106                   (else     (err))))
 107       (else (err))))))