Added SYMBOL-MACRO pattern.

README.md

@@ -17,6 +17,7 @@ specifiers are defined as follows:
 
     pattern-specifier ::= constant-pattern
                         | variable-pattern
+                        | symbol-macro-pattern
                         | constructor-pattern
                         | derived-pattern
                         | guard-pattern
@@ -29,6 +30,8 @@ specifiers are defined as follows:
                        | (quote VALUE)
 
     variable-pattern ::= SYMBOL | (variable SYMBOL)
+
+    symbol-macro-pattern ::= (symbol-macrolet SYMBOL)
 
     constructor-pattern ::= (NAME PATTERN*)
 
@@ -67,6 +70,17 @@ Examples:
       (otherwise 'otherwise))
     => OTHERWISE
 
+### Symbol-Macro-Pattern
+
+A symbol-macro-pattern matches any value as variable-patterns but bind
+the value with SYMBOL-MACROLET.
+
+Examples:
+
+    (defvar c (cons 1 2))
+    (match c ((cons (symbol-macrolet x) y) (incf x) (incf y)))
+    c => (2 . 2)
+
 ### Constructor-Pattern
 
 A constructor-pattern matches not a value itself but a structure of
@@ -231,7 +245,7 @@ Examples:
     smatch arg &body clauses
 
 Same as MATCH, except SMATCH binds variables by SYMBOL-MACROLET
-instead of LET.
+instead of LET. See the documentation of symbol-macro-pattern.
 
 ## [Macro] multiple-value-smatch
 

optima.asd

@@ -16,6 +16,7 @@ specifiers are defined as follows:
 
     pattern-specifier ::= constant-pattern
                         | variable-pattern
+                        | symbol-macro-pattern
                         | constructor-pattern
                         | derived-pattern
                         | guard-pattern
@@ -28,6 +29,8 @@ specifiers are defined as follows:
                        | (quote VALUE)
     
     variable-pattern ::= SYMBOL | (variable SYMBOL)
+
+    symbol-macro-pattern ::= (symbol-macrolet SYMBOL)
     
     constructor-pattern ::= (NAME PATTERN*)
 
@@ -66,6 +69,17 @@ Examples:
       (otherwise 'otherwise))
     => OTHERWISE
 
+### Symbol-Macro-Pattern
+
+A symbol-macro-pattern matches any value as variable-patterns but bind
+the value with SYMBOL-MACROLET.
+
+Examples:
+
+    (defvar c (cons 1 2))
+    (match c ((cons (symbol-macrolet x) y) (incf x) (incf y)))
+    c => (2 . 2)
+
 ### Constructor-Pattern
 
 A constructor-pattern matches not a value itself but a structure of

src/compiler.lisp

@@ -1,7 +1,5 @@
 (in-package :optima)
 
-(defvar *let* 'let)
-
 (defun compile-clause-body (body)
   (cond ((null body)
          nil)
@@ -39,7 +37,18 @@
          for name = (variable-pattern-name pattern)
          collect
          (if name
-             `(,rest (,*let* ((,name ,(car vars))) . ,then))
+             `(,rest (let ((,name ,(car vars))) . ,then))
+             `(,rest . ,then)))
+   else))
+
+(defun compile-match-symbol-macro-group (vars clauses else)
+  (compile-match
+   (cdr vars)
+   (loop for ((pattern . rest) . then) in clauses
+         for name = (symbol-macro-pattern-name pattern)
+         collect
+         (if name
+             `(,rest (symbol-macrolet ((,name ,(car vars))) . ,then))
              `(,rest . ,then)))
    else))
 
@@ -57,21 +66,36 @@
   (with-slots (arity arguments predicate accessor) (caaar clauses)
     (let* ((var (car vars))
            (test-form (funcall predicate var))
-           (new-vars (make-gensym-list arity)))
-      `(if ,test-form
-           (,*let*
-            ,(loop for i from 0
-                   for new-var in new-vars
-                   for access = (funcall accessor var i)
-                   collect `(,new-var ,access))
-            (declare (ignorable ,@new-vars))
-            ,(compile-match
-              (append new-vars (cdr vars))
-              (loop for ((pattern . rest) . then) in clauses
-                    for args = (constructor-pattern-arguments pattern)
-                    collect `((,@args . ,rest) . ,then))
-              else))
-           ,else))))
+           (new-vars (make-gensym-list arity))
+           (then (compile-match
+                  (append new-vars (cdr vars))
+                  (loop for ((pattern . rest) . then) in clauses
+                        for args = (constructor-pattern-arguments pattern)
+                        collect `((,@args . ,rest) . ,then))
+                  else)))
+      (loop for i from 0 below arity
+            for new-var in new-vars
+            for access = (funcall accessor var i)
+            for binding = `(,new-var ,access)
+            if (loop for ((pattern . rest) . then) in clauses
+                     for arg = (nth i (constructor-pattern-arguments pattern))
+                     never (pattern-symbol-macro-included-p arg))
+              collect binding into let-bindings
+            else
+              collect binding into symbol-macro-bindings
+            finally
+               (when symbol-macro-bindings
+                 (setq then `(symbol-macrolet ,symbol-macro-bindings
+                               (declare (ignorable ,@(mapcar #'car symbol-macro-bindings)))
+                               ,then)))
+               (when let-bindings
+                 (setq then `(let ,let-bindings
+                               (declare (ignorable ,@(mapcar #'car let-bindings)))
+                               ,then)))
+               (return
+                 `(if ,test-form
+                      ,then
+                      ,else))))))
 
 (defun compile-match-guard-group (vars clauses else)
   (assert (= (length clauses) 1))
@@ -156,6 +180,8 @@
           (etypecase it
             (variable-pattern
              (compile-match-variable-group vars group fail))
+            (symbol-macro-pattern
+             (compile-match-symbol-macro-group vars group fail))
             (constant-pattern
              (compile-match-constant-group vars group fail))
             (constructor-pattern

src/match.lisp

@@ -45,14 +45,14 @@ Examples:
 
 (defmacro smatch (arg &body clauses)
   "Same as MATCH, except SMATCH binds variables by SYMBOL-MACROLET
-instead of LET."
-  (let ((*let* 'symbol-macrolet))
+instead of LET. See the documentation of symbol-macro-pattern."
+  (let ((*parse-variable-as-symbol-macro* t))
     (compile-match-1 arg clauses nil)))
 
 (defmacro multiple-value-smatch (values-form &body clauses)
   "Same as MULTIPLE-VALUE-MATCH, except MULTIPLE-VALUE-SMATCH binds
 variables by SYMBOL-MACROLET instead of LET."
-  (let ((*let* 'symbol-macrolet))
+  (let ((*parse-variable-as-symbol-macro* t))
     (compile-multiple-value-match values-form clauses nil)))
 
 (defmacro ematch (arg &body clauses)
@@ -73,7 +73,7 @@ not matched."
 (defmacro esmatch (arg &body clauses)
   "Same as EMATCH, except ESMATCH binds variables by SYMBOL-MACROLET
 instead of LET."
-  (let ((*let* 'symbol-macrolet)
+  (let ((*parse-variable-as-symbol-macro* t)
         (else `(error 'match-error
                       :values (list ,arg)
                       :patterns ',(mapcar #'car clauses))))
@@ -82,7 +82,7 @@ instead of LET."
 (defmacro multiple-value-esmatch (values-form &body clauses)
   "Same as MULTIPLE-VALUE-EMATCH, except MULTIPLE-VALUE-ESMATCH binds
 variables by SYMBOL-MACROLET instead of LET."
-  (let ((*let* 'symbol-macrolet)
+  (let ((*parse-variable-as-symbol-macro* t)
         (else `(error 'match-error
                       :values (list ,values-form)
                       :patterns ',(mapcar #'car clauses))))
@@ -109,7 +109,7 @@ be raised if not matched."
 (defmacro csmatch (arg &body clauses)
   "Same as CMATCH, except CSMATCH binds variables by SYMBOL-MACROLET
 instead of LET."
-  (let ((*let* 'symbol-macrolet)
+  (let ((*parse-variable-as-symbol-macro* t)
         (else `(cerror "Continue."
                        'match-error
                        :values (list ,arg)
@@ -119,7 +119,7 @@ instead of LET."
 (defmacro multiple-value-csmatch (values-form &body clauses)
   "Same as MULTIPLE-VALUE-CMATCH, except MULTIPLE-VALUE-CSMATCH binds
 variables by SYMBOL-MACROLET instead of LET."
-  (let ((*let* 'symbol-macrolet)
+  (let ((*parse-variable-as-symbol-macro* t)
         (else `(cerror "Continue."
                        'match-error
                        :values (list ,values-form)

src/pattern.lisp

@@ -1,19 +1,23 @@
 (in-package :optima)
 
+(defvar *parse-variable-as-symbol-macro* nil)
+
 ;;; Pattern Data Structure
 
 (defstruct pattern)
 
 (defstruct (variable-pattern (:include pattern))
   name)
 
+(defstruct (symbol-macro-pattern (:include pattern))
+  name)
+
 (defstruct (constant-pattern (:include pattern))
   value)
 
 (defstruct (constructor-pattern (:include pattern))
   name
   arity
-  type
   arguments
   predicate
   accessor)
@@ -44,6 +48,18 @@
     ((or or-pattern and-pattern)
      (mappend #'pattern-variables (slot-value pattern 'sub-patterns)))))
 
+(defun pattern-symbol-macro-included-p (pattern)
+  (typecase pattern
+    (symbol-macro-pattern t)
+    (constructor-pattern
+     (some #'pattern-symbol-macro-included-p
+           (constructor-pattern-arguments pattern)))
+    (not-pattern
+     (pattern-symbol-macro-included-p (not-pattern-sub-pattern pattern)))
+    ((or or-pattern and-pattern)
+     (some #'pattern-symbol-macro-included-p
+           (slot-value pattern 'sub-patterns)))))
+
 ;;; Pattern Specifier
 
 (defun pattern-expand-function (name)
@@ -118,11 +134,17 @@ Examples:
       ((or (eql t) null keyword)
        (make-constant-pattern :value pattern))
       (symbol
-       (make-variable-pattern :name (var-name pattern)))
+       (if *parse-variable-as-symbol-macro*
+           (make-symbol-macro-pattern :name pattern)
+           (make-variable-pattern :name (var-name pattern))))
       (cons
        (destructuring-case pattern
          ((variable name)
-          (make-variable-pattern :name (var-name name)))
+          (if *parse-variable-as-symbol-macro*
+              (make-symbol-macro-pattern :name name)
+              (make-variable-pattern :name (var-name name))))
+         ((symbol-macrolet name)
+          (make-symbol-macro-pattern :name name))
          ((quote value)
           (make-constant-pattern :value value))
          ((when test-form)