aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog24
-rw-r--r--src/interp/Makefile.in2
-rw-r--r--src/interp/bootlex.lisp2
-rw-r--r--src/interp/fnewmeta.lisp147
-rw-r--r--src/interp/lexing.boot7
-rw-r--r--src/interp/newaux.lisp6
-rw-r--r--src/interp/spad-parser.boot101
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)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-06 16:46:30 +0000