* interp/lexing.boot (matchAdvanceKeyword): New.

	* interp/spad-parser.boot: New parsing functions.
	* interp/fnewmeta.lisp: Use them.
	(PARSE-NewExpr): Remove.
	(PARSE-Command): Likewise.
	(PARSE-SpecialKeyWord): Likewise.
	(PARSE-TokenOption): Likewise.
	(PARSE-PrimaryOrQM): Likewise.
	(PARSE-InfixWith): Likewise.
	(PARSE-With): Likewise.
	(PARSE-Inline): Likewise.
	(PARSE-Quanifier): Likewise.
	(PARSE-QuantifiedVariable): Likewise.
	(PARSE-Infix): Likewise.
	(PARSE-Prefix): Likewise.
	(PARSE-Suffix): Likewise.
	(PARSE-TokTail): Likewise.
	(PARSE-Qualification): Likewise.
	(PARSE-Primary): Likewise.
	(PARSE-PrimaryNoFloat): Likewise.
	(PARSE-Quad): Likewise.

7 files changed, 150 insertions, 139 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index 1d148d1f..a66981c8 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,29 @@
 2011-10-11  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
+	* interp/lexing.boot (matchAdvanceKeyword): New.
+	* interp/spad-parser.boot: New parsing functions.
+	* interp/fnewmeta.lisp: Use them.
+	(PARSE-NewExpr): Remove.
+	(PARSE-Command): Likewise.
+	(PARSE-SpecialKeyWord): Likewise.
+	(PARSE-TokenOption): Likewise.
+	(PARSE-PrimaryOrQM): Likewise.
+	(PARSE-InfixWith): Likewise.
+	(PARSE-With): Likewise.
+	(PARSE-Inline): Likewise.
+	(PARSE-Quanifier): Likewise.
+	(PARSE-QuantifiedVariable): Likewise.
+	(PARSE-Infix): Likewise.
+	(PARSE-Prefix): Likewise.
+	(PARSE-Suffix): Likewise.
+	(PARSE-TokTail): Likewise.
+	(PARSE-Qualification): Likewise.
+	(PARSE-Primary): Likewise.
+	(PARSE-PrimaryNoFloat): Likewise.
+	(PARSE-Quad): Likewise.
+
+2011-10-11  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
 	* interp/lexing.boot (matchAdvanceString): New.
 	* interp/spad-parser.boot: New parsing functions.
 	* interp/fnewmeta.lisp: Use them.
diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in
index 85a00d98..2093e74e 100644
--- a/src/interp/Makefile.in
+++ b/src/interp/Makefile.in
@@ -322,7 +322,7 @@ server.$(FASLEXT): macros.$(FASLEXT)
 
 ## The old parser component roughtly is:
 ##
-spad-parser.$(FASLEXT): parsing.$(FASLEXT) parse.$(FASLEXT)
+spad-parser.$(FASLEXT): parsing.$(FASLEXT) parse.$(FASLEXT) fnewmeta.$(FASLEXT)
 parse.$(FASLEXT): parsing.$(FASLEXT) postpar.$(FASLEXT)
 packtran.$(FASLEXT): sys-macros.$(FASLEXT)
 postpar.$(FASLEXT): macros.$(FASLEXT)
diff --git a/src/interp/bootlex.lisp b/src/interp/bootlex.lisp
index e932ede3..b90cb4ba 100644
--- a/src/interp/bootlex.lisp
+++ b/src/interp/bootlex.lisp
@@ -121,7 +121,7 @@
          (if (setq |$lineStack| (PREPARSE in-stream))
              (let ((LINE (cdar |$lineStack|)))
                (declare (special LINE))
-               (|PARSE-NewExpr|)
+               (|parseNewExpr|)
                (let ((parseout (|popStack1|)) )
                  (when parseout
                        (let ((|$OutputStream| out-stream))
diff --git a/src/interp/fnewmeta.lisp b/src/interp/fnewmeta.lisp
index 0a79d120..cb8d2f18 100644
--- a/src/interp/fnewmeta.lisp
+++ b/src/interp/fnewmeta.lisp
@@ -50,25 +50,6 @@
 (defun |isTokenDelimiter| () 
        (MEMBER (|currentSymbol|) '(\) END\_UNIT NIL)))
 
-(DEFUN |PARSE-NewExpr| ()
-  (OR (AND (|matchString| ")") (ACTION (|processSynonyms|))
-           (MUST (|PARSE-Command|)))
-      (AND (ACTION (SETQ DEFINITION_NAME (|currentSymbol|)))
-           (|PARSE-Statement|)))) 
-
-
-(DEFUN |PARSE-Command| ()
-  (AND (|matchAdvanceString| ")") (MUST (|PARSE-SpecialKeyWord|))
-       (MUST (|PARSE-SpecialCommand|))
-       (|pushReduction| '|PARSE-Command| NIL))) 
-
-
-(DEFUN |PARSE-SpecialKeyWord| ()
-  (AND (|matchCurrentToken| 'IDENTIFIER)
-       (ACTION (SETF (|tokenSymbol| (|currentToken|))
-                     (|unAbbreviateKeyword| (|currentSymbol|)))))) 
-
-
 (DEFUN |PARSE-SpecialCommand| ()
   (OR (AND (|matchAdvanceString| "show")
            (BANG FIL_TEST
@@ -82,7 +63,7 @@
            (ACTION (FUNCALL (|currentSymbol|))))
       (AND (MEMBER (|currentSymbol|) |$tokenCommands|)
            (|PARSE-TokenList|) (MUST (|PARSE-TokenCommandTail|)))
-      (AND (STAR REPEATOR (|PARSE-PrimaryOrQM|))
+      (AND (STAR REPEATOR (|parsePrimaryOrQM|))
            (MUST (|PARSE-CommandTail|))))) 
 
 
@@ -94,17 +75,12 @@
 
 
 (DEFUN |PARSE-TokenCommandTail| ()
-  (AND (BANG FIL_TEST (OPTIONAL (STAR REPEATOR (|PARSE-TokenOption|))))
+  (AND (BANG FIL_TEST (OPTIONAL (STAR REPEATOR (|parseTokenOption|))))
        (|atEndOfLine|)
        (|pushReduction| '|PARSE-TokenCommandTail|
            (CONS (|popStack2|) (APPEND (|popStack1|) NIL)))
        (ACTION (|systemCommand| (|popStack1|))))) 
 
-
-(DEFUN |PARSE-TokenOption| ()
-  (AND (|matchAdvanceString| ")") (MUST (|PARSE-TokenList|)))) 
-
-
 (DEFUN |PARSE-CommandTail| ()
   (AND (BANG FIL_TEST (OPTIONAL (STAR REPEATOR (|PARSE-Option|))))
        (|atEndOfLine|)
@@ -112,16 +88,9 @@
            (CONS (|popStack2|) (APPEND (|popStack1|) NIL)))
        (ACTION (|systemCommand| (|popStack1|))))) 
 
-
-(DEFUN |PARSE-PrimaryOrQM| ()
-  (OR (AND (|matchAdvanceString| "?")
-           (|pushReduction| '|PARSE-PrimaryOrQM| '?))
-      (|PARSE-Primary|))) 
-
-
 (DEFUN |PARSE-Option| ()
   (AND (|matchAdvanceString| ")")
-       (MUST (STAR REPEATOR (|PARSE-PrimaryOrQM|))))) 
+       (MUST (STAR REPEATOR (|parsePrimaryOrQM|))))) 
 
 
 (DEFUN |PARSE-Statement| ()
@@ -135,19 +104,6 @@
                           (CONS (|popStack2|)
                                 (APPEND (|popStack1|) NIL)))))))) 
 
-
-(DEFUN |PARSE-InfixWith| ()
-  (AND (|PARSE-With|)
-       (|pushReduction| '|PARSE-InfixWith|
-           (CONS '|Join| (CONS (|popStack2|) (CONS (|popStack1|) NIL)))))) 
-
-
-(DEFUN |PARSE-With| ()
-  (AND (MATCH-ADVANCE-KEYWORD "with") (MUST (|PARSE-Category|))
-       (|pushReduction| '|PARSE-With|
-           (CONS '|with| (CONS (|popStack1|) NIL))))) 
-
-
 (DEFUN |PARSE-Category| ()
   (PROG (G1)
     (RETURN
@@ -220,20 +176,11 @@
                     (CONS '|import|
 			  (CONS (|popStack2|) (APPEND (|popStack1|) NIL))))))))
 
-;; domain inlining.  Same syntax as import directive; except
-;; deliberate restriction on naming one type at a time.
-;; -- gdr, 2009-02-28.
-(DEFUN |PARSE-Inline| ()
-  (AND (MATCH-ADVANCE-KEYWORD "inline")
-       (MUST (|PARSE-Expr| 1000))
-       (|pushReduction| '|PARSE-Inline|
-           (CONS '|%Inline| (CONS (|popStack1|) NIL)))))
-
 ;; quantified types.  At the moment, these are used only in
 ;; pattern-mathing cases.
 ;; -- gdr, 2009-06-14.
 (DEFUN |PARSE-Scheme| ()
-  (OR (AND (|PARSE-Quantifier|)
+  (OR (AND (|parseQuantifier|)
 	   (MUST (|PARSE-QuantifiedVariableList|))
 	   (MUST (|matchAdvanceString| "."))
 	   (MUST (|PARSE-Expr| 200))
@@ -243,76 +190,19 @@
 					     (CONS (|popStack1|) NIL))))))
       (|PARSE-Application|)))
 
-(DEFUN |PARSE-Quantifier| ()
-  (OR (AND (MATCH-ADVANCE-KEYWORD "forall")
-	   (MUST (|pushReduction| '|PARSE-Quantifier| '|%Forall|)))
-      (AND (MATCH-ADVANCE-KEYWORD "exist")
-	   (MUST (|pushReduction| '|PARSE-Quantifier| '|%Exist|)))))
-
 (DEFUN |PARSE-QuantifiedVariableList| ()
   (AND (|matchAdvanceString| "(")
-       (MUST (|PARSE-QuantifiedVariable|))
+       (MUST (|parseQuantifiedVariable|))
        (OPTIONAL 
 	(AND (STAR REPEATOR 
 		   (AND (|matchAdvanceString| ",")
-			(MUST (|PARSE-QuantifiedVariable|))))
+			(MUST (|parseQuantifiedVariable|))))
 	     (|pushReduction| '|PARSE-QuantifiedVariableList|
 			     (CONS '|%Sequence|
 				   (CONS (|popStack2|) 
 					 (APPEND (|popStack1|) NIL))))))
        (MUST (|matchAdvanceString| ")"))))
 
-(DEFUN |PARSE-QuantifiedVariable| ()
-  (AND (|parseName|)
-       (MUST (|matchAdvanceString| ":"))
-       (MUST (|PARSE-Application|))
-       (MUST (|pushReduction| '|PARSE-QuantifiedVariable|
-			     (CONS '|:| 
-				   (CONS (|popStack2|)
-					 (CONS (|popStack1|) NIL)))))))
-
-(DEFUN |PARSE-Infix| ()
-  (AND (|pushReduction| '|PARSE-Infix| (|currentSymbol|))
-       (ACTION (|advanceToken|)) (OPTIONAL (|PARSE-TokTail|))
-       (MUST (|PARSE-Expression|))
-       (|pushReduction| '|PARSE-Infix|
-           (CONS (|popStack2|)
-                 (CONS (|popStack2|) (CONS (|popStack1|) NIL)))))) 
-
-
-(DEFUN |PARSE-Prefix| ()
-  (AND (|pushReduction| '|PARSE-Prefix| (|currentSymbol|))
-       (ACTION (|advanceToken|)) (OPTIONAL (|PARSE-TokTail|))
-       (MUST (|PARSE-Expression|))
-       (|pushReduction| '|PARSE-Prefix|
-           (CONS (|popStack2|) (CONS (|popStack1|) NIL))))) 
-
-
-(DEFUN |PARSE-Suffix| ()
-  (AND (|pushReduction| '|PARSE-Suffix| (|currentSymbol|))
-       (ACTION (|advanceToken|)) (OPTIONAL (|PARSE-TokTail|))
-       (|pushReduction| '|PARSE-Suffix|
-           (CONS (|popStack1|) (CONS (|popStack1|) NIL))))) 
-
-
-(DEFUN |PARSE-TokTail| ()
-  (PROG (G1)
-    (RETURN
-      (AND (EQ (|currentSymbol|) '$)
-           (OR (ALPHA-CHAR-P (|currentChar|))
-               (CHAR-EQ (|currentChar|) "$")
-               (CHAR-EQ (|currentChar|) "%")
-               (CHAR-EQ (|currentChar|) "("))
-           (ACTION (SETQ G1 (|copyToken| |$priorToken|)))
-           (|PARSE-Qualification|) (ACTION (SETQ |$priorToken| G1)))))) 
-
-
-(DEFUN |PARSE-Qualification| ()
-  (AND (|matchAdvanceString| "$") (MUST (|PARSE-Primary1|))
-       (|pushReduction| '|PARSE-Qualification|
-           (|dollarTran| (|popStack1|) (|popStack1|))))) 
-
-
 (DEFUN |PARSE-SemiColon| ()
   (AND (|matchAdvanceString| ";")
        (MUST (OR (|PARSE-Expr| 82)
@@ -338,7 +228,7 @@
        (ACTION (|advanceToken|))
        (ACTION (|advanceToken|))
        (MUST (|PARSE-GlyphTok| "("))
-       (MUST (|PARSE-QuantifiedVariable|))
+       (MUST (|parseQuantifiedVariable|))
        (MUST (MATCH-ADVANCE-SPECIAL ")"))
        (MUST (|PARSE-GlyphTok| "=>"))
        (MUST (|PARSE-Expression|))
@@ -445,7 +335,7 @@
 				   (CONS '|:| 
 				      (CONS (|popStack2|)
 					    (CONS (|popStack1|) NIL))))))))
-      (|PARSE-Primary|)))
+      (|parsePrimary|)))
 
 (DEFUN |PARSE-Iterator| ()
   (OR (AND (MATCH-ADVANCE-KEYWORD "for") (MUST (|PARSE-Variable|))
@@ -533,8 +423,8 @@
 
 (DEFUN |PARSE-getSemanticForm| (X IND Y)
   (DECLARE (SPECIAL X IND Y))
-  (OR (AND Y (EVAL Y)) (AND (EQ IND '|Nud|) (|PARSE-Prefix|))
-      (AND (EQ IND '|Led|) (|PARSE-Infix|)))) 
+  (OR (AND Y (EVAL Y)) (AND (EQ IND '|Nud|) (|parsePrefix|))
+      (AND (EQ IND '|Led|) (|parseInfix|)))) 
 
 
 (DEFUN |PARSE-Reduction| ()
@@ -568,7 +458,7 @@
 
 
 (DEFUN |PARSE-Application| ()
-  (AND (|PARSE-Primary|) (OPTIONAL (STAR OPT_EXPR (|PARSE-Selector|)))
+  (AND (|parsePrimary|) (OPTIONAL (STAR OPT_EXPR (|PARSE-Selector|)))
        (OPTIONAL
            (AND (|PARSE-Application|)
                 (|pushReduction| '|PARSE-Application|
@@ -583,18 +473,13 @@
                      (CONS (|popStack2|) (CONS (|popStack1|) NIL)))))
       (AND (OR (|PARSE-Float|)
                (AND (|matchAdvanceString| ".")
-                    (MUST (|PARSE-Primary|))))
+                    (MUST (|parsePrimary|))))
            (MUST (|pushReduction| '|PARSE-Selector|
                      (CONS (|popStack2|) (CONS (|popStack1|) NIL))))))) 
 
 
 (DEFUN |PARSE-PrimaryNoFloat| ()
-  (AND (|PARSE-Primary1|) (OPTIONAL (|PARSE-TokTail|)))) 
-
-
-(DEFUN |PARSE-Primary| ()
-  (OR (|PARSE-Float|) (|PARSE-PrimaryNoFloat|))) 
-
+  (AND (|PARSE-Primary1|) (OPTIONAL (|parseTokenTail|)))) 
 
 (DEFUN |PARSE-Primary1| ()
   (OR (AND (|parseName|)
@@ -603,7 +488,7 @@
                     (MUST (|PARSE-Primary1|))
                     (|pushReduction| '|PARSE-Primary1|
                         (CONS (|popStack2|) (CONS (|popStack1|) NIL))))))
-      (|PARSE-Quad|) (|parseString|) (|parseInteger|)
+      (|parseQuad|) (|parseString|) (|parseInteger|)
       (|parseFormalParameter|)
       (AND (|matchAdvanceString| "'")
            (MUST (AND (MUST (|PARSE-Data|))
@@ -690,10 +575,6 @@
 		      )))
       )) 
 
-(DEFUN |PARSE-Quad| ()
-  (AND (|matchAdvanceString| "$")
-       (|pushReduction| '|PARSE-Quad| '$)))
-
 (DEFUN |PARSE-Data| ()
   (AND (ACTION (SETQ LABLASOC NIL)) (|PARSE-Sexpr|)
        (|pushReduction| '|PARSE-Data|
diff --git a/src/interp/lexing.boot b/src/interp/lexing.boot
index 8be1464f..d0f1c065 100644
--- a/src/interp/lexing.boot
+++ b/src/interp/lexing.boot
@@ -42,6 +42,7 @@ namespace BOOT
 module lexing where
   matchString: %String -> %Maybe %Short
   matchAdvanceString: %String -> %Maybe %Short
+  matchAdvanceKeyword: %Symbol -> %Thing
 
 --%
 --% Line abstract datatype
@@ -402,6 +403,12 @@ matchAdvanceString x ==
     n
   nil
 
+matchAdvanceKeyword kwd ==
+  matchToken(currentToken(),'KEYWORD,kwd) =>
+    advanceToken()
+    true
+  false
+
 --%
 --% Stack abstract datatype.
 --%  Operational semantics:
diff --git a/src/interp/newaux.lisp b/src/interp/newaux.lisp
index 3a10a738..eb99de79 100644
--- a/src/interp/newaux.lisp
+++ b/src/interp/newaux.lisp
@@ -115,7 +115,7 @@
           (|in| 400 400) 
 	  (|case| 400 400)
           (|add| 400 120)
-	  (|with| 2000 400 (|PARSE-InfixWith|))
+	  (|with| 2000 400 (|parseInfixWith|))
           (|has| 400 400)
           (|where| 121 104)     ; must be 121 for SPAD, 126 for boot--> nboot
           (|when| 112 190)
@@ -136,12 +136,12 @@
           (|until| 130 190 (|PARSE-Loop|))
           (|repeat| 130 190 (|PARSE-Loop|))
           (|import| 120 0 (|PARSE-Import|) )
-          (|inline| 120 0 (|PARSE-Inline|) )
+          (|inline| 120 0 (|parseInline|) )
 	  (|forall| 998 999 (|PARSE-Scheme|))
 	  (|exist| 998 999 (|PARSE-Scheme|))
           (|unless|)
           (|add| 900 120)
-          (|with| 1000 300 (|PARSE-With|))
+          (|with| 1000 300 (|parseWith|))
           (|has| 400 400)
           (- 701 700)  ; right-prec. wants to be -1 + left-prec
 ;;        (\+ 701 700)
diff --git a/src/interp/spad-parser.boot b/src/interp/spad-parser.boot
index c7f6e8a8..7a381471 100644
--- a/src/interp/spad-parser.boot
+++ b/src/interp/spad-parser.boot
@@ -44,9 +44,14 @@
 
 import parsing
 import parse
+import fnewmeta
 namespace BOOT
 
 --%
+macro compulsorySyntax s ==
+  s or SPAD__SYNTAX__ERROR()
+
+--%
 
 parseToken tt ==
   tok := matchCurrentToken tt =>
@@ -85,6 +90,100 @@ parseAnyId() ==
     true
   parseOperatorFunctionName()
 
+parseQuad() ==
+  matchAdvanceString '"$" and pushReduction('parseQuad,"$")
+
+parsePrimary() ==
+  PARSE_-Float() or PARSE_-PrimaryNoFloat()
+
+parsePrimaryOrQM() ==
+  matchAdvanceString '"?" => pushReduction('parsePrimaryOrQM,"?")
+  parsePrimary()
+
+parseSpecialKeyWord() ==
+  matchCurrentToken 'IDENTIFIER =>
+    tokenSymbol(currentToken()) := unAbbreviateKeyword currentSymbol()
+  nil
+
+parseCommand() ==
+  matchAdvanceString '")" =>
+    compulsorySyntax parseSpecialKeyWord()
+    compulsorySyntax parseSpecialCommand()
+    pushReduction('parseStatement,nil)
+  nil
+
+parseTokenOption() ==
+  matchAdvanceString '")" and compulsorySyntax PARSE_-TokenList()
+  
+parseQualification() ==
+  matchAdvanceString '"$" =>
+    compulsorySyntax PARSE_-Primary1()
+    pushReduction('parseQualification,dollarTran(popStack1(),popStack1()))
+  nil
+
+parseTokenTail() ==
+  currentSymbol() is "$" and
+    (alphabetic? currentChar() or currentChar() = char "$"
+      or currentChar() = char "%" or currentChar() = char "(") =>
+        tok := copyToken $priorToken
+        parseQualification()
+        $priorToken := tok
+  nil
+
+parseInfix() ==
+  pushReduction('parseInfix,currentSymbol())
+  advanceToken()
+  parseTokenTail()
+  compulsorySyntax PARSE_-Expression()
+  pushReduction('parseInfix,[popStack2(),popStack2(),popStack1()])
+
+parsePrefix() ==
+  pushReduction('parsePrefix,currentSymbol())
+  advanceToken()
+  parseTokenTail()
+  compulsorySyntax PARSE_-Expression()
+  pushReduction('parsePrefix,[popStack2(),popStack1()])
+
+parseWith() ==
+  matchAdvanceKeyword "with" =>
+    compulsorySyntax PARSE_-Category()
+    pushReduction('parseWith,["with",popStack1()])
+  nil
+
+parseInfixWith() ==
+  parseWith() and
+    pushReduction('parseInfixWith,["Join",popStack2(),popStack1()])
+
+++ domain inlining.  Same syntax as import directive; except
+++ deliberate restriction on naming one type at a time.
+++ -- gdr, 2009-02-28.
+parseInline() ==
+  matchAdvanceKeyword "inline" =>
+    compulsorySyntax PARSE_-Expr 1000
+    pushReduction('parseInline,["%Inline",popStack1()])
+  nil
+
+parseQuantifier() ==
+  matchAdvanceKeyword "forall" =>
+    pushReduction('parseQuantifier,'%Forall)
+  matchAdvanceKeyword "exist" =>
+    pushReduction('parseQuantifier,'%Exist)
+  nil
+
+parseQuantifiedVariable() ==
+  parseName() =>
+    compulsorySyntax matchAdvanceString '":"
+    compulsorySyntax PARSE_-Application()
+    pushReduction('parseQuantifiedVariable,[":",popStack2(),popStack1()])
+  nil
+
+parseNewExpr() ==
+  matchString '")" =>
+    processSynonyms()
+    compulsorySyntax parseCommand()
+  SETQ(DEFINITION__NAME,currentSymbol())
+  PARSE_-Statement()
+
 --%
 
 ++ Given a pathname to a source file containing Spad code, returns
@@ -120,7 +219,7 @@ parseSpadFile sourceFile ==
   while not (_*EOF_* or FILE_-CLOSED) repeat
     BOOT_-LINE_-STACK : local := PREPARSE IN_-STREAM
     LINE : local := CDAR BOOT_-LINE_-STACK
-    CATCH('SPAD__READER,PARSE_-NewExpr())
+    CATCH('SPAD__READER,parseNewExpr())
     asts := [parseTransform postTransform popStack1(), :asts]
   -- clean up the mess, and get out of here
   IOCLEAR(IN_-STREAM, OUT_-STREAM)