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

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

Rel 1.0.0

File size: 6.9 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(module type-coerce (;export
28  make-case-coerce
29  (case-coerce *make-case-coerce) *make-case-coerce
30  coerce
31  coerce-all)
32
33  (import scheme
34          chicken
35          (only data-structures alist-ref)
36          (only srfi-1 every reverse!)
37          (only miscmacros if*)
38          (only type-checks check-procedure check-symbol check-list check-alist)
39          (only type-errors signal-type-error)
40          type-of)
41
42  (require-library data-structures srfi-1 miscmacros type-checks type-errors type-of)
43
44;;; Extension
45
46(define ((*make-case-coerce func al) obj typ err)
47  (func obj typ (lambda () (if* (alist-ref typ al eq?) (it obj) (err)))) )
48
49;;
50
51(define (make-case-coerce func #!optional (al '()))
52  (check-procedure 'make-case-coerce func 'func)
53  (check-alist 'make-case-coerce al 'alist)
54  (*make-case-coerce func al) )
55
56;;
57
58(define-syntax case-coerce
59  (lambda (frm rnm cmp)
60    (let ((_lambda (rnm 'lambda))
61          (_case (rnm 'case))
62          (_else (rnm 'else))
63          (_*make-case-coerce (rnm '*make-case-coerce))
64          (_typ (rnm 'typ)) )
65      (let ((else-clause `(,_else (on-error))))
66        (let loop ((clauses (cdr frm)) (sym-clauses '()))
67          (if (null? clauses)
68              `(,_*make-case-coerce
69                 (,_lambda (object ,_typ on-error)
70                   (,_case ,_typ ,@(reverse! sym-clauses) ,else-clause))
71                 '())
72              (let* ((clause (car clauses))
73                     (rest (cdr clauses))
74                     (tst (car clause))
75                     (bdy (cdr clause)) )
76                (##sys#check-syntax 'case-coerce bdy '#(_ 1))
77                (cond ((and (symbol? tst) (cmp tst _else))
78                        (set! else-clause clause)
79                        (loop rest sym-clauses) )
80                      (else
81                        (##sys#check-syntax 'case-coerce tst '#(symbol 1))
82                        (loop rest (cons clause sym-clauses)) ) ) ) ) ) ) ) ) )
83
84;;@body
85;;Converts and returns @1 of type @code{char}, @code{number},
86;;@code{string}, @code{symbol}, @code{list}, or @code{vector} to
87;;@2 (which must be one of these symbols).
88
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)
94  (when default-proc (check-procedure 'coerce default-proc 'default-proc))
95  (let ((objtyp (type-of obj)))
96    (if (eq? objtyp result-type) obj
97        (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) ) ) ) ) )
154
155;;
156
157(define (coerce-all flst tlst #!optional default-proc)
158  (check-list 'coerce-all flst "objects")
159  (check-list 'coerce-all tlst "types")
160  #; ;UNNEEDED
161  (unless (= (length flst) (length tlst))
162    (signal-type-error 'coerce-all "list length mismatch" flst tlst) )
163  (map (cut coerce <> <> default-proc) flst tlst) )
164
165) ;module type-coerce
Note: See TracBrowser for help on using the repository browser.