;;"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))))))