Skip to content

Instantly share code, notes, and snippets.

@darius
Created December 28, 2012 21:31
Show Gist options
  • Save darius/4402125 to your computer and use it in GitHub Desktop.
Save darius/4402125 to your computer and use it in GitHub Desktop.
;; (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