Permalink
Browse files

shadchen: added struct pattern

  • Loading branch information...
1 parent f11b913 commit 6784d57ea181e815f53881f284db7ab725ba5852 @VincentToups committed Jan 19, 2012
Showing with 63 additions and 0 deletions.
  1. +1 −0 README.txt
  2. +9 −0 monads.asd
  3. +6 −0 monads.lisp
  4. +5 −0 package.lisp
  5. +42 −0 shadchen.el
  6. BIN shadchen.elc
View
@@ -0,0 +1 @@
+This is the stub README.txt for the nil project.
View
@@ -0,0 +1,9 @@
+;;;; monads.asd
+
+(asdf:defsystem #:nil
+ :serial t
+ :depends-on (#:lisp-unit
+ #:shadchen)
+ :components ((:file "package")
+ (:file "nil")))
+
View
@@ -0,0 +1,6 @@
+;;;; monads.lisp
+
+(in-package #:nil)
+
+;;; nil goes here. Hacks and glory await!
+
View
@@ -0,0 +1,5 @@
+;;;; package.lisp
+
+(defpackage #:nil
+ (:use #:cl))
+
View
@@ -129,11 +129,33 @@ two terms, a function and a match against the result. Got
`(setf (gethash ',name *extended-patterns*)
#'(lambda ,args ,@body)))
+(defun match-literal-string (match-expression match-value body)
+ `(if (string= ,match-expression ,match-value)
+ (progn ,@body)
+ *match-fail*))
+
+(defun match-literal-number (match-expression match-value body)
+ `(if (= ,match-expression ,match-value)
+ (progn ,@body)
+ *match-fail*))
+
+(defun match-literal-keyword (match-expression match-value body)
+ `(if (eq ,match-expression ,match-value)
+ (progn ,@body)
+ *match-fail*))
+
+
(defmacro* match1 (match-expression match-value &body body)
(cond
((non-keyword-symbol match-expression)
`(let ((,match-expression ,match-value))
,@body))
+ ((stringp match-expression)
+ (match-literal-string match-expression match-value body))
+ ((numberp match-expression)
+ (match-literal-number match-expression match-value body))
+ ((keywordp match-expression)
+ (match-literal-keyword match-expression match-value body))
((extended-patternp (car match-expression))
(match-extended-pattern-expander match-expression match-value body))
((listp match-expression)
@@ -200,6 +222,26 @@ An error is thrown when no matches are found."
(funcall #'cdr
(list-rest ,@pats))))))
+(defun cl-struct-prepend (s)
+ (intern (format "cl-struct-%s" s)))
+
+(defun make-cl-struct-accessor (struct-name slot)
+ (intern (format "%s-%s" struct-name slot)))
+
+
+(defpattern struct (struct-name &rest fields)
+ `(and
+ (? #'vectorp)
+ (? #'(lambda (x) (> (length x) 0)))
+ (? #'(lambda (o)
+ (eq (elt o 0) ',(cl-struct-prepend struct-name))))
+ ,@(loop for f in fields collect
+ `(funcall
+ #',(make-cl-struct-accessor struct-name (car f))
+ ,(cadr f)))))
+
+
+
(provide 'shadchen)
View
Binary file not shown.

0 comments on commit 6784d57

Please sign in to comment.