From a0814cce1c974724aa0d95f85316d5fcbf848070 Mon Sep 17 00:00:00 2001 From: Jan Moringen Date: Sun, 30 Mar 2014 03:51:15 +0200 Subject: [PATCH 1/3] Typo fixes in README.md and optima.asd --- README.md | 35 +++++++++++++++++------------------ optima.asd | 30 +++++++++++++++--------------- 2 files changed, 32 insertions(+), 33 deletions(-) diff --git a/README.md b/README.md index b2a334b..9572970 100644 --- a/README.md +++ b/README.md @@ -24,26 +24,26 @@ specifiers are defined as follows: | and-pattern | constructor-pattern | derived-pattern - + constant-pattern ::= t | nil | keyword | atom-except-symbol | (quote VALUE) - + variable-pattern ::= SYMBOL | (variable SYMBOL) - + place-pattern ::= (place SYMBOL) - + guard-pattern ::= (guard PATTERN TEST-FORM) - + not-pattern ::= (not PATTERN) - + or-pattern ::= (or PATTERN*) - + and-pattern ::= (and PATTERN*) - + constructor-pattern ::= (NAME ARG*) - + derived-pattern ::= (NAME PATTERN*) ### Constant-Pattern @@ -214,7 +214,7 @@ Syntax: class-constructor-pattern ::= (class NAME slot*) | (NAME slot*) - + slot ::= SLOT-NAME | (SLOT-NAME PATTERN*) @@ -259,7 +259,7 @@ Syntax: structure-constructor-pattern ::= (structure CONC-NAME slot*) | (CONC-NAME slot*) - + slot ::= SLOT-NAME | (SLOT-NAME PATTERN*) @@ -304,7 +304,7 @@ style pattern syntax like: ### Derived-Pattern A derived-pattern is a pattern that is defined with DEFPATTERN. There -are some builtin dervied patterns as below: +are some builtin derived patterns as below: #### LIST @@ -356,7 +356,7 @@ Define Constructor Patterns --------------------------- You can define your own constructor patterns by using `OPTIMA.CORE` -package. Firstly, define a data structore for the constructor +package. Firstly, define a data structure for the constructor pattern. (defstruct (my-cons-pattern (:include constructor-pattern) @@ -370,13 +370,12 @@ condition when destructor of the constructor patterns can be shared. Sharing destructors removes redundant data checks, that is, pattern-matching can get more faster. - (defmethod constructor-pattern-destructor-sharable-p ((x my-cons-pattern) (y my-cons-pattern)) t) Thirdly, define a destructor generator for the constructor pattern, -whichs generate a destructor that specifies how to check the the -data (`PREDICATE-FORM`) and how to access the data (`ACCESSOR-FORMS`). +which generates a destructor that specifies how to check the data +(`PREDICATE-FORM`) and how to access the data (`ACCESSOR-FORMS`). (defmethod constructor-pattern-make-destructor ((pattern my-cons-pattern) var) (make-destructor :predicate-form `(consp ,var) @@ -386,7 +385,7 @@ Finally, define a parser and an unparser for the constructor pattern. (defmethod parse-constructor-pattern ((name (eql 'my-cons)) &rest args) (apply #'make-my-cons-pattern (mapcar #'parse-pattern args))) - + (defmethod unparse-pattern ((pattern my-cons-pattern)) `(cons ,(unparse-pattern (my-cons-pattern-car-pattern pattern)) ,(unparse-pattern (my-cons-pattern-cdr-pattern pattern)))) @@ -400,7 +399,7 @@ See the source code for more detail. %equal a b -Equality function for comparing patten constants. +Equality function for comparing pattern constants. ### [Macro] %equals diff --git a/optima.asd b/optima.asd index 9eb3e13..6a7d814 100644 --- a/optima.asd +++ b/optima.asd @@ -23,26 +23,26 @@ specifiers are defined as follows: | and-pattern | constructor-pattern | derived-pattern - + constant-pattern ::= t | nil | keyword | atom-except-symbol | (quote VALUE) - + variable-pattern ::= SYMBOL | (variable SYMBOL) - + place-pattern ::= (place SYMBOL) - + guard-pattern ::= (guard PATTERN TEST-FORM) - + not-pattern ::= (not PATTERN) - + or-pattern ::= (or PATTERN*) - + and-pattern ::= (and PATTERN*) - + constructor-pattern ::= (NAME ARG*) - + derived-pattern ::= (NAME PATTERN*) ### Constant-Pattern @@ -213,7 +213,7 @@ Syntax: class-constructor-pattern ::= (class NAME slot*) | (NAME slot*) - + slot ::= SLOT-NAME | (SLOT-NAME PATTERN*) @@ -258,7 +258,7 @@ Syntax: structure-constructor-pattern ::= (structure CONC-NAME slot*) | (CONC-NAME slot*) - + slot ::= SLOT-NAME | (SLOT-NAME PATTERN*) @@ -303,7 +303,7 @@ style pattern syntax like: ### Derived-Pattern A derived-pattern is a pattern that is defined with DEFPATTERN. There -are some builtin dervied patterns as below: +are some builtin derived patterns as below: #### LIST @@ -355,7 +355,7 @@ Define Constructor Patterns --------------------------- You can define your own constructor patterns by using `OPTIMA.CORE` -package. Firstly, define a data structore for the constructor +package. Firstly, define a data structure for the constructor pattern. (defstruct (my-cons-pattern (:include constructor-pattern) @@ -374,7 +374,7 @@ pattern-matching can get more faster. t) Thirdly, define a destructor generator for the constructor pattern, -whichs generate a destructor that specifies how to check the the +which generate a destructor that specifies how to check the data (`PREDICATE-FORM`) and how to access the data (`ACCESSOR-FORMS`). (defmethod constructor-pattern-make-destructor ((pattern my-cons-pattern) var) @@ -385,7 +385,7 @@ Finally, define a parser and an unparser for the constructor pattern. (defmethod parse-constructor-pattern ((name (eql 'my-cons)) &rest args) (apply #'make-my-cons-pattern (mapcar #'parse-pattern args))) - + (defmethod unparse-pattern ((pattern my-cons-pattern)) `(cons ,(unparse-pattern (my-cons-pattern-car-pattern pattern)) ,(unparse-pattern (my-cons-pattern-cdr-pattern pattern)))) From 96e3ad6696f2b659f617e5dd1c0cfe4100e06220 Mon Sep 17 00:00:00 2001 From: Jan Moringen Date: Fri, 5 Jul 2013 23:10:35 +0200 Subject: [PATCH 2/3] Add [SIMPLE-]VECTOR* and SEQUENCE[*] patterns --- README.md | 48 +++++++++++++++++++++ optima.asd | 48 +++++++++++++++++++++ src/packages.lisp | 20 +++++++++ src/pattern.lisp | 107 ++++++++++++++++++++++++++++++++++++++++------ test/suite.lisp | 5 +++ 5 files changed, 215 insertions(+), 13 deletions(-) diff --git a/README.md b/README.md index 9572970..d311b60 100644 --- a/README.md +++ b/README.md @@ -205,6 +205,54 @@ Examples: ((simple-vector a b) (+ a b))) => 3 +#### VECTOR* + +Syntax: + + vector*-constructor-pattern ::= (vector* PATTERN*) + +Examples: + + (match #(1 2 3) + ((vector* a b) (list a b))) + => (1 #(2 3)) + +#### SIMPLE-VECTOR* + +Syntax: + + simple-vector*-constructor-pattern ::= (simple-vector* PATTERN*) + +Examples: + + (match #(1 2 3) + ((simple-vector* a b) (list a b))) + => (1 #(2 3)) + +#### SEQUENCE + +Syntax: + + sequence-constructor-pattern ::= (sequence PATTERN*) + +Examples: + + (match "abc" + ((sequence a b c) (list a b c))) + => (#\a #\b #\c) + +#### SEQUENCE* + +Syntax: + + sequence*-constructor-pattern ::= (sequence* PATTERN*) + +Examples: + + (match "abc" + ((sequence* a b) (list a b))) + => (#\a "bc")) + #### CLASS Matches an instance of a given subclass of standard-class, as well as diff --git a/optima.asd b/optima.asd index 6a7d814..c62ec9f 100644 --- a/optima.asd +++ b/optima.asd @@ -204,6 +204,54 @@ Examples: ((simple-vector a b) (+ a b))) => 3 +#### VECTOR* + +Syntax: + + vector*-constructor-pattern ::= (vector* PATTERN*) + +Examples: + + (match #(1 2 3) + ((vector* a b) (list a b))) + => (1 #(2 3)) + +#### SIMPLE-VECTOR* + +Syntax: + + simple-vector*-constructor-pattern ::= (simple-vector* PATTERN*) + +Examples: + + (match #(1 2 3) + ((simple-vector* a b) (list a b))) + => (1 #(2 3)) + +#### SEQUENCE + +Syntax: + + sequence-constructor-pattern ::= (sequence PATTERN*) + +Examples: + + (match \"abc\" + ((sequence a b c) (list a b c))) + => (#\\a #\\b #\\c) + +#### SEQUENCE* + +Syntax: + + sequence*-constructor-pattern ::= (sequence* PATTERN*) + +Examples: + + (match \"abc\" + ((sequence* a b) (list a b))) + => (#\\a \"bc\")) + #### CLASS Matches an instance of a given subclass of standard-class, as well as diff --git a/src/packages.lisp b/src/packages.lisp index 7bb0053..40c3a62 100644 --- a/src/packages.lisp +++ b/src/packages.lisp @@ -79,6 +79,22 @@ #:simple-vector-pattern-subpatterns #:make-simple-vector-pattern + #:vector*-pattern + #:vector*-pattern-subpatterns + #:make-vector*-pattern + + #:simple-vector*-pattern + #:simple-vector*-pattern-subpatterns + #:make-simple-vector*-pattern + + #:sequence-pattern + #:sequence-pattern-subpatterns + #:make-sequence-pattern + + #:sequence*-pattern + #:sequence*-pattern-subpatterns + #:make-sequence*-pattern + #:class-pattern #:class-pattern-subpatterns #:class-pattern-class-name @@ -111,6 +127,7 @@ (defpackage :optima (:use :cl :optima.core) (:import-from :alexandria + #:length= #:ensure-car #:ensure-list #:mappend @@ -142,6 +159,9 @@ #:place #:guard #:property + #:vector* + #:simple-vector* + #:sequence* #:defpattern)) (defpackage :optima.extra diff --git a/src/pattern.lisp b/src/pattern.lisp index 6c26b48..fb0c46d 100644 --- a/src/pattern.lisp +++ b/src/pattern.lisp @@ -125,28 +125,85 @@ :accessor-forms (list `(car ,it)))))) (defstruct (vector-pattern (:include constructor-pattern) - (:constructor make-vector-pattern (&rest subpatterns)))) + (:constructor make-vector-pattern (&rest subpatterns))) + (vector-type '(vector *)) + (accessor 'aref)) (defmethod constructor-pattern-destructor-sharable-p ((x vector-pattern) (y vector-pattern)) (= (constructor-pattern-arity x) (constructor-pattern-arity y))) (defmethod constructor-pattern-make-destructor ((pattern vector-pattern) var) - (make-destructor :predicate-form `(typep ,var '(vector * ,(constructor-pattern-arity pattern))) - :accessor-forms (loop for i from 0 below (constructor-pattern-arity pattern) - collect `(aref ,var ,i)))) - -(defstruct (simple-vector-pattern (:include constructor-pattern) - (:constructor make-simple-vector-pattern (&rest subpatterns)))) - -(defmethod constructor-pattern-destructor-sharable-p ((x simple-vector-pattern) (y simple-vector-pattern)) + (with-accessors ((vector-type vector-pattern-vector-type) + (accessor vector-pattern-accessor) + (arity constructor-pattern-arity)) pattern + (make-destructor :predicate-form `(typep ,var '(,@vector-type ,arity)) + :accessor-forms (loop for i from 0 below arity + collect `(,accessor ,var ,i))))) + +(defstruct (simple-vector-pattern (:include vector-pattern) + (:constructor + %make-simple-vector-pattern (subpatterns + &optional + (vector-type '(simple-vector)) + (accessor 'svref))))) + +(defun make-simple-vector-pattern (&rest subpatterns) + (%make-simple-vector-pattern subpatterns)) + +(defstruct (vector*-pattern (:include vector-pattern) + (:constructor make-vector*-pattern (&rest subpatterns)))) + +(defmethod constructor-pattern-make-destructor ((pattern vector*-pattern) var) + (with-accessors ((vector-type vector-pattern-vector-type) + (accessor vector-pattern-accessor) + (arity constructor-pattern-arity)) pattern + (make-destructor :predicate-form `(and (typep ,var '(,@vector-type *)) + (>= (length ,var) ,(1- arity))) + :accessor-forms (loop for i from 0 below arity + collect (if (< i (1- arity)) + `(,accessor ,var ,i) + `(subseq ,var ,i)))))) + +(defstruct (simple-vector*-pattern (:include vector*-pattern) + (:constructor + %make-simple-vector*-pattern (subpatterns + &optional + (vector-type '(simple-vector)) + (accessor 'svref))))) + +(defun make-simple-vector*-pattern (&rest subpatterns) + (%make-simple-vector*-pattern subpatterns)) + +(defstruct (sequence-pattern (:include constructor-pattern) + (:constructor make-sequence-pattern (&rest subpatterns)))) + +(defmethod constructor-pattern-destructor-sharable-p ((x sequence-pattern) (y sequence-pattern)) (= (constructor-pattern-arity x) (constructor-pattern-arity y))) -(defmethod constructor-pattern-make-destructor ((pattern simple-vector-pattern) var) - (make-destructor :predicate-form `(typep ,var '(simple-vector ,(constructor-pattern-arity pattern))) - :accessor-forms (loop for i from 0 below (constructor-pattern-arity pattern) - collect `(svref ,var ,i)))) +(defmethod constructor-pattern-make-destructor ((pattern sequence-pattern) var) + (with-accessors ((vector-type vector-pattern-vector-type) + (accessor vector-pattern-accessor) + (arity constructor-pattern-arity)) pattern + (make-destructor :predicate-form `(and (typep ,var 'sequence) + (length= ,var ,arity)) + :accessor-forms (loop for i from 0 below arity + collect `(elt ,var ,i))))) + +(defstruct (sequence*-pattern (:include sequence-pattern) + (:constructor make-sequence*-pattern (&rest subpatterns)))) + +(defmethod constructor-pattern-make-destructor ((pattern sequence*-pattern) var) + (with-accessors ((vector-type vector-pattern-vector-type) + (accessor vector-pattern-accessor) + (arity constructor-pattern-arity)) pattern + (make-destructor :predicate-form `(and (typep ,var 'sequence) + (>= (length ,var) ,(1- arity))) + :accessor-forms (loop for i from 0 below arity + collect (if (< i (1- arity)) + `(elt ,var ,i) + `(subseq ,var ,i)))))) (defstruct (class-pattern (:include constructor-pattern) (:constructor %make-class-pattern)) @@ -466,6 +523,18 @@ Examples: (defmethod parse-constructor-pattern ((name (eql 'simple-vector)) &rest args) (apply #'make-simple-vector-pattern (mapcar #'parse-pattern args))) +(defmethod parse-constructor-pattern ((name (eql 'vector*)) &rest args) + (apply #'make-vector*-pattern (mapcar #'parse-pattern args))) + +(defmethod parse-constructor-pattern ((name (eql 'simple-vector*)) &rest args) + (apply #'make-simple-vector*-pattern (mapcar #'parse-pattern args))) + +(defmethod parse-constructor-pattern ((name (eql 'sequence)) &rest args) + (apply #'make-sequence-pattern (mapcar #'parse-pattern args))) + +(defmethod parse-constructor-pattern ((name (eql 'sequence*)) &rest args) + (apply #'make-sequence*-pattern (mapcar #'parse-pattern args))) + (defun parse-class-pattern (class-name &rest slot-specs) ;; Transform MAKE-INSTANCE style syntax. During the transformation, ;; we also resolve the slot names via MOP. If no slot found or too @@ -569,6 +638,18 @@ Examples: (defmethod unparse-pattern ((pattern simple-vector-pattern)) `(simple-vector ,@(mapcar #'unparse-pattern (simple-vector-pattern-subpatterns pattern)))) +(defmethod unparse-pattern ((pattern vector*-pattern)) + `(vector* ,@(mapcar #'unparse-pattern (vector*-pattern-subpatterns pattern)))) + +(defmethod unparse-pattern ((pattern simple-vector*-pattern)) + `(simple-vector* ,@(mapcar #'unparse-pattern (simple-vector*-pattern-subpatterns pattern)))) + +(defmethod unparse-pattern ((pattern sequence-pattern)) + `(sequence ,@(mapcar #'unparse-pattern (sequence-pattern-subpatterns pattern)))) + +(defmethod unparse-pattern ((pattern sequence*-pattern)) + `(sequence* ,@(mapcar #'unparse-pattern (sequence*-pattern-subpatterns pattern)))) + (defmethod unparse-pattern ((pattern class-pattern)) `(class ,(class-pattern-class-name pattern) ,@(loop for slot-name in (class-pattern-slot-names pattern) diff --git a/test/suite.lisp b/test/suite.lisp index 3d924dd..de99019 100644 --- a/test/suite.lisp +++ b/test/suite.lisp @@ -118,8 +118,13 @@ (is-not-match '(:a 1 :b 2) (property :b 3)) ;; vector (is-match (vector 1 2) (vector 1 2)) + (is-match (vector 1 2 3) (vector* 1 (vector 2 3))) ;; simple-vector (is-match (vector 1 2) (simple-vector 1 2)) + (is-match (vector 1 2 3) (simple-vector* 1 (simple-vector 2 3))) + ;; sequence + (is-match "abc" (sequence #\a #\b #\c)) + (is-match "abc" (sequence* #\a "bc")) ;; class (let ((person (make-instance 'person :name "Bob" :age 31))) (is (equal (match person From 26d7478f93f25fef09f321fd8fb0e63c031b5ae3 Mon Sep 17 00:00:00 2001 From: Jan Moringen Date: Sat, 6 Jul 2013 17:19:22 +0200 Subject: [PATCH 3/3] Check number of arguments in {[SIMPLE-]VECTOR,SEQUENCE}* patterns --- README.md | 6 +++--- src/pattern.lisp | 11 ++++++++++- test/suite.lisp | 11 +++++++++++ 3 files changed, 24 insertions(+), 4 deletions(-) diff --git a/README.md b/README.md index d311b60..561a842 100644 --- a/README.md +++ b/README.md @@ -209,7 +209,7 @@ Examples: Syntax: - vector*-constructor-pattern ::= (vector* PATTERN*) + vector*-constructor-pattern ::= (vector* PATTERN+) Examples: @@ -221,7 +221,7 @@ Examples: Syntax: - simple-vector*-constructor-pattern ::= (simple-vector* PATTERN*) + simple-vector*-constructor-pattern ::= (simple-vector* PATTERN+) Examples: @@ -245,7 +245,7 @@ Examples: Syntax: - sequence*-constructor-pattern ::= (sequence* PATTERN*) + sequence*-constructor-pattern ::= (sequence* PATTERN+) Examples: diff --git a/src/pattern.lisp b/src/pattern.lisp index fb0c46d..706cf8c 100644 --- a/src/pattern.lisp +++ b/src/pattern.lisp @@ -505,7 +505,7 @@ Examples: (defgeneric parse-constructor-pattern (name &rest args)) (defmethod parse-constructor-pattern ((name (eql 'cons)) &rest args) - (unless (= (length args) 2) + (unless (length= 2 args) (error "Malformed pattern: ~S" (list* 'cons args))) (apply #'make-cons-pattern (mapcar #'parse-pattern args))) @@ -524,15 +524,24 @@ Examples: (apply #'make-simple-vector-pattern (mapcar #'parse-pattern args))) (defmethod parse-constructor-pattern ((name (eql 'vector*)) &rest args) + (unless args + (error "Malformed pattern: ~S: invalid number of arguments: ~D" + (list* name args) (length args))) (apply #'make-vector*-pattern (mapcar #'parse-pattern args))) (defmethod parse-constructor-pattern ((name (eql 'simple-vector*)) &rest args) + (unless args + (error "Malformed pattern: ~S: invalid number of arguments: ~D" + (list* name args) (length args))) (apply #'make-simple-vector*-pattern (mapcar #'parse-pattern args))) (defmethod parse-constructor-pattern ((name (eql 'sequence)) &rest args) (apply #'make-sequence-pattern (mapcar #'parse-pattern args))) (defmethod parse-constructor-pattern ((name (eql 'sequence*)) &rest args) + (unless args + (error "Malformed pattern: ~S: invalid number of arguments: ~D" + (list* name args) (length args))) (apply #'make-sequence*-pattern (mapcar #'parse-pattern args))) (defun parse-class-pattern (class-name &rest slot-specs) diff --git a/test/suite.lisp b/test/suite.lisp index de99019..4517e1a 100644 --- a/test/suite.lisp +++ b/test/suite.lisp @@ -29,6 +29,17 @@ ; (check-roundtrip _) does not roundtrip, but that's probably OK. (check-roundtrip x))) +(test syntax-errors + ;; cons requires exactly two arguments + (signals error (parse-pattern '(cons))) + (signals error (parse-pattern '(cons 1))) + (signals error (parse-pattern '(cons 1 2 3))) + ;; these require at least one argument + (signals error (parse-pattern '(list*))) + (signals error (parse-pattern '(vector*))) + (signals error (parse-pattern '(simple-vector*))) + (signals error (parse-pattern '(sequence*)))) + ;;; Pattern matching (defmacro is-match (arg pattern)