Created
December 28, 2012 21:31
-
-
Save darius/4402125 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
;; (mcase subject-expr (pattern action) ...) | |
(defmacro mcase (subject &rest clauses) | |
`(funcall (mlambda ,@clauses) ,subject)) | |
;; (mlambda (pattern action) ...) | |
(defmacro mlambda (&rest clauses) | |
(if (null clauses) | |
'(lambda (x) (match-error x)) | |
(let ((subject (gensym)) (fail (gensym))) | |
`(lambda (,subject) | |
(let ((,fail (lambda () (mcase ,subject ,@(cdr clauses))))) | |
,(expand-pattern subject (caar clauses) `(funcall ,fail) (cadar clauses))))))) | |
(defun match-error (subject) (error "Match error")) | |
;; pattern = atom | 'constant | ,variable | (pattern . pattern) | |
(defun expand-pattern (subject pat fail succeed) | |
(if (not (consp pat)) | |
`(if (not (equal ,subject ',pat)) ,fail ,succeed) | |
(case (car pat) | |
((quote) | |
`(if (not (equal ,subject ,pat)) ,fail ,succeed)) | |
((\,) | |
`(let ((,(cadr pat) ,subject)) | |
,succeed)) | |
(otherwise | |
`(if (not (consp ,subject)) | |
,fail | |
,(expand-pattern `(car ,subject) (car pat) fail | |
(expand-pattern `(cdr ,subject) (cdr pat) fail | |
succeed))))))) | |
(funcall (mlambda ((hello (,world) 42) world)) | |
'(hello (hi) 42)) | |
(mcase '(hi) | |
((,x) x) | |
(,_ 'nope)) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment