source: project/release/4/coerce/trunk/type-coerce.scm @ 16004

Last change on this file since 16004 was 16004, checked in by Kon Lovett, 10 years ago

Forgot record

File size: 9.4 KB
Line 
1;;;; type-coerce.scm
2;;;; Kon Lovett, Sep '09
3
4;;"coerce.scm" Scheme Implementation of COMMON-LISP COERCE and TYPE-OF.
5; Copyright (C) 1995, 2001 Aubrey Jaffer
6;
7;Permission to copy this software, to modify it, to redistribute it,
8;to distribute modified versions, and to use it for any purpose is
9;granted, subject to the following restrictions and understandings.
10;
11;1.  Any copy made of this software must include this copyright notice
12;in full.
13;
14;2.  I have made no warranty or representation that the operation of
15;this software will be error-free, and I am under no obligation to
16;provide any services, by way of maintenance, update, or otherwise.
17;
18;3.  In conjunction with products arising from the use of this
19;material, there shall be no use of my name in any advertising,
20;promotional, or sales literature without prior written consent in
21;each case.
22
23;; Issues
24;;
25;; - Cannot know before attempt if coercion possible.
26;;
27;; - The coercion of a composite object to a scalar often makes no sense.
28
29(module type-coerce (;export
30  make-case-coerce
31  (case-coerce *make-case-coerce) *make-case-coerce
32  coerce
33  coerce-all)
34
35  (import scheme
36          chicken
37          (only data-structures alist-ref)
38          (only lolevel record->vector)
39          (only srfi-1 every reverse!)
40          (only miscmacros if*)
41          (only type-checks check-procedure check-symbol check-list check-alist)
42          (only type-errors signal-type-error)
43          type-of)
44
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|#
66
67;;; Extension
68
69(define ((*make-case-coerce func al) obj typ err)
70  (func obj typ (lambda () (if* (alist-ref typ al eq?) (it obj) (err)))) )
71
72;;
73
74(define (make-case-coerce func #!optional (al '()))
75  (check-procedure 'make-case-coerce func 'func)
76  (check-alist 'make-case-coerce al 'alist)
77  (*make-case-coerce func al) )
78
79;;
80
81(define-syntax case-coerce
82  (lambda (frm rnm cmp)
83    (let ((_lambda (rnm 'lambda))
84          (_case (rnm 'case))
85          (_else (rnm 'else))
86          (_*make-case-coerce (rnm '*make-case-coerce))
87          (_typ (rnm 'typ)) )
88      (let ((else-clause `(,_else (on-error))))
89        (let loop ((clauses (cdr frm)) (sym-clauses '()))
90          (if (null? clauses)
91              `(,_*make-case-coerce
92                 (,_lambda (object ,_typ on-error)
93                   (,_case ,_typ ,@(reverse! sym-clauses) ,else-clause))
94                 '())
95              (let* ((clause (car clauses))
96                     (rest (cdr clauses))
97                     (tst (car clause))
98                     (bdy (cdr clause)) )
99                (##sys#check-syntax 'case-coerce bdy '#(_ 1))
100                (cond ((and (symbol? tst) (cmp tst _else))
101                        (set! else-clause clause)
102                        (loop rest sym-clauses) )
103                      (else
104                        (##sys#check-syntax 'case-coerce tst '#(symbol 1))
105                        (loop rest (cons clause sym-clauses)) ) ) ) ) ) ) ) ) )
106
107;;@body
108;;Converts and returns @1 of type @code{char}, @code{number},
109;;@code{string}, @code{symbol}, @code{list}, or @code{vector} to
110;;@2 (which must be one of these symbols).
111
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)
117  (when default-proc (check-procedure 'coerce default-proc 'default-proc))
118  (let ((objtyp (type-of obj)))
119    (if (eq? objtyp restyp) obj
120        (case objtyp
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) ) ) ) ) )
238
239;;
240
241(define (coerce-all flst tlst #!optional default-proc)
242  (check-list 'coerce-all flst "objects")
243  (check-list 'coerce-all tlst "types")
244  #; ;NOT NEEDED
245  (unless (= (length flst) (length tlst))
246    (signal-type-error 'coerce-all "list length mismatch" flst tlst) )
247  (map (cut coerce <> <> default-proc) flst tlst) )
248
249) ;module type-coerce
Note: See TracBrowser for help on using the repository browser.