diff options
| -rw-r--r-- | stdlib/type.tl | 40 | ||||
| -rw-r--r-- | tests/012/compile.tl | 2 | ||||
| -rw-r--r-- | tests/012/typecase.tl | 18 |
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) |