1 files changed, 220 insertions, 0 deletions
diff --git a/parser/pattern-parser.scm b/parser/pattern-parser.scm
new file mode 100644
index 0000000..39a82cc
--- /dev/null
+++ b/parser/pattern-parser.scm
@@ -0,0 +1,220 @@
+;;;  File: pattern-parser        Author: John
+
+;;; This parses the pattern syntax except for the parts which need to be
+;;; resolved by precedence parsing.
+
+;;; This parses a list of alternating pats & conops.
+
+(define (parse-pat)
+ (trace-parser pat
+   (let ((res (parse-pat/list)))
+     (if (null? (cdr res))
+	 (car res)
+	 (make pp-pat-list (pats res))))))
+
+;;; This parses a list of patterns with intervening conops and + patterns
+
+(define (parse-pat/list)
+  (token-case
+    (con (let ((pcon (pcon->ast)))
+	   (setf (pcon-pats pcon) (parse-apat-list))
+	   (cons pcon (parse-pat/tail))))
+    (-n
+     (advance-token) ; past -
+     (token-case
+      (numeric (let ((val (literal->ast)))
+		 (cons (make pp-pat-negated)
+		       (cons (make const-pat (value val))
+			     (parse-pat/tail)))))
+      (else
+       (signal-missing-token "<number>" "negative literal pattern"))))
+    (var
+     (let ((var (var->ast)))
+       (token-case
+	(+k (cons (make var-pat (var var))
+		  (parse-+k-pat)))
+	(@  (let ((pattern (parse-apat)))
+	      (cons (make as-pat (var var) (pattern pattern))
+		    (parse-pat/tail))))
+	(else (cons (make var-pat (var var)) (parse-pat/tail))))))
+    (_
+     (let ((pat (make wildcard-pat)))
+       (token-case
+	(+k (cons pat (parse-+k-pat)))
+	(else (cons pat (parse-pat/tail))))))
+    (else (let ((apat (parse-apat)))
+	    (cons apat (parse-pat/tail))))))
+
+
+(define (parse-+k-pat)
+  (advance-token)  ; past +
+  (token-case
+   (k (let ((val (literal->ast)))
+	(cons (make pp-pat-plus)
+	      (cons (make const-pat (value val))
+		    (parse-pat/tail)))))
+   (else (signal-missing-token "<integer>" "successor pattern"))))
+
+(define (parse-pat/tail)
+   (token-case
+     (conop
+      (let ((con (pconop->ast)))
+	(cons con (parse-pat/list))))
+     (else '())))
+
+(define (parse-apat)
+ (trace-parser apat
+   (token-case
+     (var (let ((var (var->ast)))
+	    (token-case
+	     (@
+	      (let ((pattern (parse-apat)))
+		(make as-pat (var var) (pattern pattern))))
+	     (else (make var-pat (var var))))))
+     (con (pcon->ast))
+     (literal (let ((value (literal->ast)))
+		(make const-pat (value value))))
+     (_ (make wildcard-pat))
+     (\( (token-case
+           (\) (**pcon/def (core-symbol "UnitConstructor") '()))
+	   (else
+	    (let ((pat (parse-pat)))
+	      (token-case
+		(\, (**pcon/tuple (cons pat (parse-pat-list '\)))))
+		(\) pat)
+		(else
+		 (signal-missing-token "`)' or `,'" "pattern")))))))
+     (\[ (token-case
+	  (\] (make list-pat (pats '())))
+	  (else (make list-pat (pats (parse-pat-list '\]))))))
+     (\~ (let ((pattern (parse-apat)))
+	   (make irr-pat (pattern pattern))))
+     (else
+      (signal-invalid-syntax "an apat")))))
+
+(define (parse-pat-list term)  ;; , separated
+  (let ((pat (parse-pat)))
+    (token-case
+     (\, (cons pat (parse-pat-list term)))
+     ((unquote term) (list pat))
+     (else
+      (signal-missing-token
+        (if (eq? term '\)) "`)'" "`]'")
+	"pattern")))))
+
+(define (parse-apat-list)  ;; space separated
+  (token-case
+    (apat-start
+     (let ((pat (parse-apat)))
+       (cons pat (parse-apat-list))))
+    (else
+     '())))
+
+;;; The following routine scans patterns without creating ast structure.
+;;; They return #t or #f depending on whether a valid pattern was encountered.
+;;; The leave the scanner pointing to the next token after the pattern.
+
+(define (scan-pat)  ; same as parse-pat/list
+  (and
+   (token-case
+    (con (scan-con)
+	 (scan-apat-list))
+    (-n (advance-token)
+	(token-case
+	 (numeric (advance-token)
+		  '#t)
+	 (else '#f)))
+    (var (and (scan-var)
+	      (token-case
+	       (@ (scan-apat))
+	       (+k (scan-+k))
+	       (else '#t))))
+    (_ (scan-+k))
+    (else (scan-apat)))
+   (scan-pat/tail)))
+
+(define (scan-pat/tail)
+  (token-case
+   (conop (and (scan-conop)
+	       (scan-pat)))
+   (else '#t)))
+
+(define (scan-apat)
+  (token-case
+   (var (scan-var)
+	(token-case
+	 (@ (scan-apat))
+	 (else '#t)))
+   (con (scan-con))
+   (literal (advance-token)
+	    '#t)
+   (_ '#t)
+   (\( (token-case
+	(\) '#t)
+	(else
+	 (and (scan-pat)
+	      (token-case
+	       (\, (scan-pat-list '\)))
+	       (\) '#t)
+	       (else '#f))))))
+   (\[ (token-case
+	(\] '#t)
+	(else (scan-pat-list '\]))))
+   (\~ (scan-apat))
+   (else '#f)))
+
+(define (scan-pat-list term)
+  (and (scan-pat)
+       (token-case
+	(\, (scan-pat-list term))
+	((unquote term) '#t)
+	(else '#f))))
+
+(define (scan-apat-list)
+  (token-case
+   (apat-start
+    (and (scan-apat)
+	 (scan-apat-list)))
+   (else '#t)))
+
+(define (scan-var)
+  (token-case
+   (varid '#t)
+   (\( (token-case
+	(varsym
+	 (token-case
+	  (\) '#t)
+	  (else '#f)))
+	(else '#f)))
+   (else '#f)))
+
+(define (scan-con)
+  (token-case
+   (conid '#t)
+   (\( (token-case
+	(consym
+	 (token-case
+	  (\) '#t)
+	  (else '#f)))
+	(else '#f)))
+   (else '#f)))
+
+(define (scan-conop)
+  (token-case
+   (consym '#t)
+   (\` (token-case
+	(conid
+	 (token-case
+	  (\` '#t)
+	  (else '#f)))
+	(else '#f)))
+   (else '#f)))
+
+(define (scan-+k)
+  (token-case
+   (+k (advance-token)  ; past the +
+       (token-case
+	(integer '#t)
+	(else '#f)))
+   (else '#t)))
+