summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--stdlib/type.tl40
-rw-r--r--tests/012/compile.tl2
-rw-r--r--tests/012/typecase.tl18
3 files changed, 40 insertions, 20 deletions
diff --git a/stdlib/type.tl b/stdlib/type.tl
index 8a83a171..680a4061 100644
--- a/stdlib/type.tl
+++ b/stdlib/type.tl
@@ -24,27 +24,29 @@
;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;; POSSIBILITY OF SUCH DAMAGE.
-(defmacro typecase (form . clauses)
+(defun sys:typecase-expander (form obj clauses)
(let* ((val (gensym))
(cond-pairs (collect-each ((cl clauses))
(tree-case cl
((type . body)
- (if (symbolp type)
- ^((typep ,val ',type) ,*(or body '(nil)))
- :))
- (else (throwf 'eval-error
- "~s: bad clause syntax: ~s"
- 'typecase cl))))))
- ^(let ((,val ,form))
- (cond ,*cond-pairs))))
+ (cond
+ ((eq type t)
+ ^(t ,*(or body '(nil))))
+ ((symbolp type)
+ ^((typep ,val ',type) ,*(or body '(nil))))
+ (t :)))
+ (else (compile-error form
+ "~s: bad clause syntax: ~s"
+ 'typecase cl))))))
+ ^(let ((,val ,obj))
+ (cond ,*cond-pairs
+ ,*(if (eq (car form) 'etypecase)
+ ^((t (throwf 'case-error
+ "~s: unhandled type: ~s"
+ 'etypecase (typeof ,val)))))))))
-(defmacro etypecase (form . clauses)
- (if [find t clauses eq car]
- ^(typecase ,form ,*clauses)
- (let ((val (gensym)))
- ^(let ((,val ,form))
- (typecase ,val
- ,*clauses
- (t (throwf 'case-error
- "~s: unhandled type: ~s"
- 'etypecase (typeof ,val))))))))
+(defmacro typecase (:form f obj . clauses)
+ (sys:typecase-expander f obj clauses))
+
+(defmacro etypecase (:form f obj . clauses)
+ (sys:typecase-expander f obj clauses))
diff --git a/tests/012/compile.tl b/tests/012/compile.tl
index d0c4913e..9b22d92a 100644
--- a/tests/012/compile.tl
+++ b/tests/012/compile.tl
@@ -5,7 +5,7 @@
(each ((f '#"aseq ashwin circ cont defset except \
fini ifa man-or-boy oop-mi oop-seq oop \
- parse syms quasi quine seq stslot const"))
+ parse syms quasi quine seq stslot const type"))
(let ((exf `@{%this-dir%}/@f.expected`))
(when (path-exists-p exf)
(file-append-string %expected-file%
diff --git a/tests/012/typecase.tl b/tests/012/typecase.tl
new file mode 100644
index 00000000..97b3da48
--- /dev/null
+++ b/tests/012/typecase.tl
@@ -0,0 +1,18 @@
+(load "../common")
+
+(mtest
+ (typecase) :error
+ (typecase nil) nil
+ (typecase nil a) :error
+ (typecase 0 (symbol 1)) nil
+ (typecase 0 (integer 1)) 1
+ (typecase 0 (integer 1) (integer 2)) 1
+ (typecase 0 (t 3) (integer 1)) 3)
+
+(mtest
+ (etypecase) :error
+ (etypecase nil) :error
+ (etypecase nil a) :error
+ (etypecase 0 (string 1)) :error
+ (etypecase 0 (string 1) (integer 2)) 2
+ (etypecase 0 (string 1) (t 2)) 2)