summaryrefslogtreecommitdiffstats
path: root/coerce.scm
blob: 0842c9ea487b8c20fa8be840324e7feac5567ee6 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
;;"coerce.scm" Scheme Implementation of COMMON-LISP COERCE and TYPE-OF.
; Copyright (C) 1995, 2001 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
;granted, subject to the following restrictions and understandings.
;
;1.  Any copy made of this software must include this copyright notice
;in full.
;
;2.  I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3.  In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.

(require-if 'compiling 'array)

;;@body
;;Returns a symbol name for the type of @1.
(define (type-of obj)
  (cond
   ((boolean? obj)	'boolean)
   ((char? obj)		'char)
   ((number? obj)	'number)
   ((string? obj)	'string)
   ((symbol? obj)	'symbol)
   ((input-port? obj)	'port)
   ((output-port? obj)	'port)
   ((procedure? obj)	'procedure)
   ((eof-object? obj)	'eof-object)
   ((list? obj)		'list)
   ((pair? obj)		'pair)
   ((vector? obj)	'vector)
   ((and (provided? 'array) (array? obj))	'array)
   (else		'?)))

;;@body
;;Converts and returns @1 of type @code{char}, @code{number},
;;@code{string}, @code{symbol}, @code{list}, or @code{vector} to
;;@2 (which must be one of these symbols).
(define (coerce obj result-type)
  (define (err) (slib:error 'coerce 'not obj '-> result-type))
  (define obj-type (type-of obj))
  (cond
   ((eq? obj-type result-type) obj)
   (else
    (case obj-type
      ((char)   (case result-type
		  ((number integer) (char->integer obj))
		  ((string) (string obj))
		  ((symbol) (string->symbol (string obj)))
		  ((list)   (list obj))
		  ((vector) (vector obj))
		  (else     (err))))
      ((number) (case result-type
		  ((char)   (integer->char obj))
		  ((atom)   obj)
		  ((integer) obj)
		  ((string) (number->string obj))
		  ((symbol) (string->symbol (number->string obj)))
		  ((list)   (string->list (number->string obj)))
		  ((vector) (list->vector (string->list (number->string obj))))
		  (else     (err))))
      ((string) (case result-type
		  ((char)   (if (= 1 (string-length obj)) (string-ref obj 0)
				(err)))
		  ((atom)   (or (string->number obj) (string->symbol obj)))
		  ((number integer) (or (string->number obj) (err)))
		  ((symbol) (string->symbol obj))
		  ((list)   (string->list obj))
		  ((vector) (list->vector (string->list obj)))
		  (else     (err))))
      ((symbol) (case result-type
		  ((char)   (coerce (symbol->string obj) 'char))
		  ((number integer) (coerce (symbol->string obj) 'number))
		  ((string) (symbol->string obj))
		  ((atom)   obj)
		  ((list)   (string->list (symbol->string obj)))
		  ((vector) (list->vector (string->list (symbol->string obj))))
		  (else     (err))))
      ((list)   (case result-type
		  ((char)   (if (and (= 1 (length obj))
				     (char? (car obj)))
				(car obj)
				(err)))
		  ((number integer)
		   (or (string->number (list->string obj)) (err)))
		  ((string) (list->string obj))
		  ((symbol) (string->symbol (list->string obj)))
		  ((vector) (list->vector obj))
		  (else     (err))))
      ((vector) (case result-type
		  ((char)   (if (and (= 1 (vector-length obj))
				     (char? (vector-ref obj 0)))
				(vector-ref obj 0)
				(err)))
		  ((number integer)
		   (or (string->number (coerce obj string)) (err)))
		  ((string) (list->string (vector->list obj)))
		  ((symbol) (string->symbol (coerce obj string)))
		  ((list)   (list->vector obj))
		  (else     (err))))
      (else (err))))))