diff options
| -rw-r--r-- | lisplib.c | 16 | ||||
| -rw-r--r-- | share/txr/stdlib/type.tl | 38 | ||||
| -rw-r--r-- | txr.1 | 43 |
3 files changed, 97 insertions, 0 deletions
@@ -242,6 +242,21 @@ static val except_instantiate(val set_fun) return nil; } +static val type_set_entries(val dlt, val fun) +{ + val name[] = { lit("typecase"), nil }; + set_dlt_entries(dlt, name, fun); + return nil; +} + +static val type_instantiate(val set_fun) +{ + funcall1(set_fun, nil); + load(format(nil, lit("~a/type.tl"), stdlib_path, nao)); + return nil; +} + + val dlt_register(val dlt, val (*instantiate)(val), @@ -264,6 +279,7 @@ void lisplib_init(void) dlt_register(dl_table, with_stream_instantiate, with_stream_set_entries); dlt_register(dl_table, hash_instantiate, hash_set_entries); dlt_register(dl_table, except_instantiate, except_set_entries); + dlt_register(dl_table, type_instantiate, type_set_entries); } val lisplib_try_load(val sym) diff --git a/share/txr/stdlib/type.tl b/share/txr/stdlib/type.tl new file mode 100644 index 00000000..830c5700 --- /dev/null +++ b/share/txr/stdlib/type.tl @@ -0,0 +1,38 @@ +;; Copyright 2015 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; All rights reserved. +;; +;; Redistribution of this software in source and binary forms, with or without +;; modification, is permitted provided that the following two conditions are met. +;; +;; Use of this software in any manner constitutes agreement with the disclaimer +;; which follows the two conditions. +;; +;; 1. Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; 2. Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED +;; WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF +;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. IN NO EVENT SHALL THE +;; COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DAMAGES, HOWEVER CAUSED, +;; AND UNDER ANY THEORY OF LIABILITY, ARISING IN ANY WAY OUT OF THE USE OF THIS +;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(defmacro typecase (expr . clauses) + (let* ((val (gensym)) + (cond-pairs (collect-each ((cl clauses)) + (tree-case cl + ((type . body) + (if (symbolp type) + ^((typep ,val ',type) ,*body) + :)) + (else (throwf 'eval-error + "~s: bad clause syntax: ~s" + 'typecase cl)))))) + ^(let ((,val ,expr)) + (cond ,*cond-pairs)))) @@ -13173,6 +13173,49 @@ The following equivalence holds: (typep a b) --> (subtypep (typeof a) b) .cble +.coNP Macro @ typecase +.synb +.mets (typecase < test-form >> {( type-sym << clause-form *)}*) +.syne +.desc +The +.code typecase +macro evaluates +.meta test-form +and then successively tests its type against each clause. + +Each clause consists of a type symbol +.meta type-sym +and zero or more +.metn clause-form -s. + +The first clause whose +.meta type-sym +is a supertype of the type of +.metn test-form 's +value is considered to be the matching clause. +That clause's +.metn clause-form -s +are evaluated, and the value of the last form is returned. + +If there is no matching clause, or there are no clauses present, +or the matching clause has no +.metn clause-form -s, +then +.code nil +is returned. + +Note: since +.code t +is the supertype of every type, a clause whose +.meta type-sym +is the symbol +.code t +always matches. If such a clause is placed as the last clause of a +.codn typecase , +it provides a fallback case, whose forms are evaluated if none of the +previous clauses match. + .coNP Function @ identity .synb .mets (identity << value ) |