Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

shadchen: added struct pattern

  • Loading branch information...
commit 6784d57ea181e815f53881f284db7ab725ba5852 1 parent f11b913
@VincentToups authored
View
1  README.txt
@@ -0,0 +1 @@
+This is the stub README.txt for the nil project.
View
9 monads.asd
@@ -0,0 +1,9 @@
+;;;; monads.asd
+
+(asdf:defsystem #:nil
+ :serial t
+ :depends-on (#:lisp-unit
+ #:shadchen)
+ :components ((:file "package")
+ (:file "nil")))
+
View
6 monads.lisp
@@ -0,0 +1,6 @@
+;;;; monads.lisp
+
+(in-package #:nil)
+
+;;; nil goes here. Hacks and glory await!
+
View
5 package.lisp
@@ -0,0 +1,5 @@
+;;;; package.lisp
+
+(defpackage #:nil
+ (:use #:cl))
+
View
42 shadchen.el
@@ -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
BIN  shadchen.elc
Binary file not shown
Please sign in to comment.
Something went wrong with that request. Please try again.