summaryrefslogtreecommitdiffstats
path: root/coerce.scm
diff options
context:
space:
mode:
authorJames LewisMoss <dres@debian.org>2001-07-27 23:45:29 -0400
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
commitf559c149c83da84d0b1c285f0298c84aec564af9 (patch)
treef1c91bcb9bb5e6dad87b643127c3f878d80d89ee /coerce.scm
parentc394920caedf3dac1981bb6b10eeb47fd6e4bb21 (diff)
parent87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (diff)
downloadslib-f559c149c83da84d0b1c285f0298c84aec564af9.tar.gz
slib-f559c149c83da84d0b1c285f0298c84aec564af9.zip
Import Debian changes 2d2-1debian/2d2-1
slib (2d2-1) unstable; urgency=low * New upstream version * Revert back to free. Is now so. slib (2d1-1) unstable; urgency=low * New upstream version. * Move to non-free. FSF pointed out license doesn't allow modified versions to be distributed. * Get a complete list of copyrights that apply to the source into copyright file. * Remove setup for guile 1.3. * Remove postrm. Just calling install-info (lintian) Move install-info call to prerm since doc-base doesn't do install-info. slib (2c9-3) unstable; urgency=low * Change info location to section "The Algorithmic Language Scheme" to match up with where guile puts it's files. * Postinst is running slibconfig now. (Closes: #75891) slib (2c9-2) unstable; urgency=low * Stop installing slibconfig (for guile). * In postinst if /usr/sbin/slibconnfig exists call it (Close: #75843 #75891). slib (2c9-1) unstable; urgency=low * New upstream (Closes: #74760) * replace string-index with strsrch:string-index in http-cgi.scm. * Add doc-base support (Closes: #31163)
Diffstat (limited to 'coerce.scm')
-rw-r--r--coerce.scm107
1 files changed, 107 insertions, 0 deletions
diff --git a/coerce.scm b/coerce.scm
new file mode 100644
index 0000000..83023df
--- /dev/null
+++ b/coerce.scm
@@ -0,0 +1,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 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))))))