From: Mark Wooding <mdw@distorted.org.uk>
Date: Tue, 13 Aug 2019 09:56:14 +0000 (+0100)
Subject: src/parser/parser-expr-proto.lisp: Get `expr' to cache operators.
X-Git-Url: https://git.distorted.org.uk/~mdw/sod/commitdiff_plain/288c7651d95b3d75af6d38d8ed40e87d63886b4f

src/parser/parser-expr-proto.lisp: Get `expr' to cache operators.

Add a new feature to `expr': if you write the operator parsers in a
special way, it will cache the operator objects around the whole
parser.  Use this in the property-set expression parser.  (Admittedly,
it previously cached the operators at load time, but there's an upcoming
change which will prevent this anyway.)
---

diff --git a/src/parser/parser-expr-proto.lisp b/src/parser/parser-expr-proto.lisp
index 9052e54..c4b433f 100644
--- a/src/parser/parser-expr-proto.lisp
+++ b/src/parser/parser-expr-proto.lisp
@@ -64,16 +64,55 @@
    protocol.  The final output of the `expr' parse is the result of
    evaluating the parsed expression.  (Of course, the definition of
    `evaluation' here is determined entirely by the methods on
-   `apply-operator', so the final value may be a parse tree, for example.)"
+   `apply-operator', so the final value may be a parse tree, for example.)
+
+   Alternatively, the BINOP, PREOP, and POSTOP parsers may be /lists/ of
+   parsers (distinguished because the head of a parser form is expected to be
+   an atom).  These are implicitly `or'red together.  Within such a list, a
+   parser form beginning `:op' is given special interpretation.  The syntax
+   is expected to be
+
+	(:op MAKE-OP RECOG &rest ARGS)
+
+   which has the following effects:
+
+     * around the expression parser, the expression
+
+	(MAKE-OP . ARGS)
+
+      is evaluated once and the result stashed away; and
+
+    * a parser of the form
+
+	(seq (RECOG) OP)
+
+      is added as one of the alternatives of the disjunction, where OP is the
+      cached operator built in the first step."
 
   (flet ((wrap (parser)
 	   `(parser (,nestedp)
 	      (declare (ignorable ,nestedp))
-	      ,parser)))
-    `(parse-expression ,(wrap operand)
-		       ,(wrap binop)
-		       ,(wrap preop)
-		       ,(wrap postop))))
+	      ,parser))
+	 (hack-oplist (oplist)
+	   (if (or (atom oplist) (atom (car oplist))) (values nil oplist)
+	       (let ((binds nil) (ops nil))
+		 (dolist (op oplist)
+		   (if (and (consp op) (eq (car op) :op))
+		       (destructuring-bind
+			   (recog make-op &rest args) (cdr op)
+			 (with-gensyms (var)
+			   (push `(,var (,make-op ,@args)) binds)
+			   (push `(seq ((nil ,recog)) ,var) ops)))
+		       (push op ops)))
+		 (values (nreverse binds) `(or ,@(nreverse ops)))))))
+    (multiple-value-bind (binvars binops) (hack-oplist binop)
+      (multiple-value-bind (prevars preops) (hack-oplist preop)
+	(multiple-value-bind (postvars postops) (hack-oplist postop)
+	  `(let (,@binvars ,@prevars ,@postvars)
+	     (parse-expression ,(wrap operand)
+			       ,(wrap binops)
+			       ,(wrap preops)
+			       ,(wrap postops))))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Numerical precedence.
diff --git a/src/pset-parse.lisp b/src/pset-parse.lisp
index a2199b6..7091016 100644
--- a/src/pset-parse.lisp
+++ b/src/pset-parse.lisp
@@ -45,36 +45,13 @@
 			  name
 			  (mapcar #'car args))
 		 (cons :invalid nil)))))
-  (let ((add (binop "+" (x y 5)
-	       (dispatch "+" (list x y) (list :int #'+ :int :int))))
-	(sub (binop "-" (x y 5)
-	       (dispatch "-" (list x y) (list :int #'- :int :int))))
-	(mul (binop "*" (x y 7)
-	       (dispatch "*" (list x y) (list :int #'* :int :int))))
-	(div (binop "/" (x y 7)
-	       (dispatch "/" (list x y)
-			 (list :int
-			       (lambda (x y)
-				 (cond ((zerop y)
-					(cerror*
-					 "Division by zero")
-					(cons :invalid nil))
-				       (t
-					(floor x y))))
-			       :int :int))))
-	(nop (preop "+" (x 9)
-	       (dispatch "+" (list x) (list :int #'+ :int))))
-	(neg (preop "-" (x 9)
-	       (dispatch "-" (list x) (list :int #'- :int))))
-	(lp (lparen #\)))
-	(rp (rparen #\))))
-
-    (defun parse-expression (scanner)
-      "Parse and evaluate a simple expression.
+
+  (defun parse-expression (scanner)
+    "Parse and evaluate a simple expression.
 
    The result is a pair (TYPE . VALUE).  Currently, type types are `:id',
-   `:int', `:string', `:char', `:fragment', `:type'.  If an error prevented a sane value from
-   being produced, the type `:invalid' is returned.
+   `:int', `:string', `:char', `:fragment', `:type'.  If an error prevented a
+   sane value from being produced, the type `:invalid' is returned.
 
    The syntax of expressions is rather limited at the moment, but more may be
    added later.
@@ -86,50 +63,68 @@
      | `<' declspec+ declarator[empty] `>' | `?' lisp-expression
 
    Only operators for dealing with integers are provided."
-      (with-parser-context (token-scanner-context :scanner scanner)
-	(parse (expr (:nestedp nestedp)
-		 (lisp (flet ((prop (type value)
-				(scanner-step scanner)
-				(values (cons type value) t t)))
-			 (case (token-type scanner)
-			   ((:int :id :char :string)
-			    (prop (token-type scanner)
-				  (token-value scanner)))
-			   (#\?
-			    (let* ((stream (make-scanner-stream scanner))
-				   (sexp (read stream t)))
+    (with-parser-context (token-scanner-context :scanner scanner)
+      (parse (expr (:nestedp nestedp)
+	       (lisp (flet ((prop (type value)
 			      (scanner-step scanner)
-			      (multiple-value-bind (type value)
-				  (restart-case (decode-property (eval sexp))
-				    (continue () (values :invalid nil)))
-				(values (cons type value) t t))))
-			   (#\{
-			    (values (cons :fragment
-					  (parse-delimited-fragment scanner
-								    #\{ #\}))
-					  t t))
-			   (#\<
-			    (parse (seq (#\<
-					 (ds (parse-c-type scanner))
-					 (dc (parse-declarator
-					      scanner ds
-					      :kernel (lambda ()
-							(values nil t nil))
-					      :abstractp t))
-					 #\>)
-				     (values (cons :type (car dc))
-					     t t))))
-			   (t
-			    (values (list :int :id :char :string #\? #\{ #\<)
-				    nil nil)))))
-		 (or (seq (#\+) add)
-		     (seq (#\-) sub)
-		     (seq (#\*) mul)
-		     (seq (#\/) div))
-		 (or (seq (#\() lp)
-		     (seq (#\+) nop)
-		     (seq (#\-) neg))
-		 (when nestedp (seq (#\)) rp))))))))
+			      (values (cons type value) t t)))
+		       (case (token-type scanner)
+			 ((:int :id :char :string)
+			  (prop (token-type scanner)
+				(token-value scanner)))
+			 (#\?
+			  (let* ((stream (make-scanner-stream scanner))
+				 (sexp (read stream t)))
+			    (scanner-step scanner)
+			    (multiple-value-bind (type value)
+				(restart-case (decode-property (eval sexp))
+				  (continue () (values :invalid nil)))
+			      (values (cons type value) t t))))
+			 (#\{
+			  (values (cons :fragment
+					(parse-delimited-fragment scanner
+								  #\{ #\}))
+					t t))
+			 (#\<
+			  (parse (seq (#\<
+				       (ds (parse-c-type scanner))
+				       (dc (parse-declarator
+					    scanner ds
+					    :kernel (lambda ()
+						      (values nil t nil))
+					    :abstractp t))
+				       #\>)
+				   (values (cons :type (car dc))
+					   t t))))
+			 (t
+			  (values (list :int :id :char :string #\? #\{ #\<)
+				  nil nil)))))
+
+	       ((:op #\* binop "*" (x y 7)
+		     (dispatch "*" (list x y) (list :int #'* :int :int)))
+		(:op #\/ binop "/" (x y 7)
+		     (dispatch "/" (list x y)
+			       (list :int
+				     (lambda (x y)
+				       (cond ((zerop y)
+					      (cerror*
+					       "Division by zero")
+					      (cons :invalid nil))
+					     (t
+					      (floor x y))))
+				     :int :int)))
+		(:op #\+ binop "+" (x y 5)
+		     (dispatch "+" (list x y) (list :int #'+ :int :int)))
+		(:op #\- binop "-" (x y 5)
+		     (dispatch "-" (list x y) (list :int #'- :int :int))))
+
+	       ((:op #\+ preop "+" (x 9)
+		     (dispatch "+" (list x) (list :int #'+ :int)))
+		(:op #\- preop "-" (x 9)
+		     (dispatch "-" (list x) (list :int #'- :int)))
+		(:op #\( lparen #\)))
+
+	       ((:op (when nestedp #\)) rparen #\))))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Parsing property sets.