mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-11 00:00:49 +02:00
107 lines
3.7 KiB
Scheme
107 lines
3.7 KiB
Scheme
;;"coerce.scm" Scheme Implementation of COMMON-LISP COERCE and TYPE-OF.
|
|
; Copyright (C) 1995, 2001 Aubrey Jaffer.
|
|
;
|
|
;Permission to copy this software, to redistribute it, 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 warrantee 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.
|
|
|
|
;;@body
|
|
;;Returns a symbol name for the type of @1.
|
|
(define (type-of obj)
|
|
(cond
|
|
;;((null? obj) 'null)
|
|
((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)
|
|
((and (provided? 'array) (array? obj)) 'array)
|
|
((and (provided? 'record) (record? obj)) 'record)
|
|
((vector? obj) 'vector)
|
|
(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))))))
|