diff options
Diffstat (limited to 'src/interp')
-rw-r--r-- | src/interp/fnewmeta.lisp | 139 | ||||
-rw-r--r-- | src/interp/lexing.boot | 21 | ||||
-rw-r--r-- | src/interp/parsing.lisp | 73 | ||||
-rw-r--r-- | src/interp/spad-parser.boot | 18 |
4 files changed, 87 insertions, 164 deletions
diff --git a/src/interp/fnewmeta.lisp b/src/interp/fnewmeta.lisp index af2861f3..0a79d120 100644 --- a/src/interp/fnewmeta.lisp +++ b/src/interp/fnewmeta.lisp @@ -58,7 +58,7 @@ (DEFUN |PARSE-Command| () - (AND (MATCH-ADVANCE-STRING ")") (MUST (|PARSE-SpecialKeyWord|)) + (AND (|matchAdvanceString| ")") (MUST (|PARSE-SpecialKeyWord|)) (MUST (|PARSE-SpecialCommand|)) (|pushReduction| '|PARSE-Command| NIL))) @@ -70,10 +70,10 @@ (DEFUN |PARSE-SpecialCommand| () - (OR (AND (MATCH-ADVANCE-STRING "show") + (OR (AND (|matchAdvanceString| "show") (BANG FIL_TEST (OPTIONAL - (OR (MATCH-ADVANCE-STRING "?") + (OR (|matchAdvanceString| "?") (|PARSE-Expression|)))) (|pushReduction| '|PARSE-SpecialCommand| (CONS '|show| (CONS (|popStack1|) NIL))) @@ -102,7 +102,7 @@ (DEFUN |PARSE-TokenOption| () - (AND (MATCH-ADVANCE-STRING ")") (MUST (|PARSE-TokenList|)))) + (AND (|matchAdvanceString| ")") (MUST (|PARSE-TokenList|)))) (DEFUN |PARSE-CommandTail| () @@ -114,13 +114,13 @@ (DEFUN |PARSE-PrimaryOrQM| () - (OR (AND (MATCH-ADVANCE-STRING "?") + (OR (AND (|matchAdvanceString| "?") (|pushReduction| '|PARSE-PrimaryOrQM| '?)) (|PARSE-Primary|))) (DEFUN |PARSE-Option| () - (AND (MATCH-ADVANCE-STRING ")") + (AND (|matchAdvanceString| ")") (MUST (STAR REPEATOR (|PARSE-PrimaryOrQM|))))) @@ -128,7 +128,7 @@ (AND (|PARSE-Expr| 0) (OPTIONAL (AND (STAR REPEATOR - (AND (MATCH-ADVANCE-STRING ",") + (AND (|matchAdvanceString| ",") (MUST (|PARSE-Expr| 0)))) (|pushReduction| '|PARSE-Statement| (CONS '|Series| @@ -163,21 +163,21 @@ (CONS (|popStack3|) (CONS (|popStack2|) (CONS (|popStack1|) NIL)))))) - (AND (MATCH-ADVANCE-STRING "(") (MUST (|PARSE-Category|)) + (AND (|matchAdvanceString| "(") (MUST (|PARSE-Category|)) (BANG FIL_TEST (OPTIONAL (STAR REPEATOR - (AND (MATCH-ADVANCE-STRING ";") + (AND (|matchAdvanceString| ";") (MUST (|PARSE-Category|)))))) - (MUST (MATCH-ADVANCE-STRING ")")) + (MUST (|matchAdvanceString| ")")) (|pushReduction| '|PARSE-Category| (CONS 'CATEGORY (CONS (|popStack2|) (APPEND (|popStack1|) NIL))))) (AND (ACTION (SETQ G1 (|lineNumber| |$spadLine|))) (OR (|PARSE-Application|) - (|PARSE-OperatorFunctionName|)) - (MUST (OR (AND (MATCH-ADVANCE-STRING ":") + (|parseOperatorFunctionName|)) + (MUST (OR (AND (|matchAdvanceString| ":") (MUST (|PARSE-Expression|)) (|pushReduction| '|PARSE-Category| (CONS '|%Signature| @@ -202,7 +202,7 @@ (DEFUN |PARSE-Import| () (AND (MATCH-ADVANCE-KEYWORD "import") (MUST (|PARSE-Expr| 1000)) - (OR (AND (MATCH-ADVANCE-STRING ":") + (OR (AND (|matchAdvanceString| ":") (MUST (|PARSE-Expression|)) (MUST (MATCH-ADVANCE-KEYWORD "from")) (MUST (|PARSE-Expr| 1000)) @@ -214,7 +214,7 @@ (AND (BANG FIL_TEST (OPTIONAL (STAR REPEATOR - (AND (MATCH-ADVANCE-STRING ",") + (AND (|matchAdvanceString| ",") (MUST (|PARSE-Expr| 1000)))))) (|pushReduction| '|PARSE-Import| (CONS '|import| @@ -235,7 +235,7 @@ (DEFUN |PARSE-Scheme| () (OR (AND (|PARSE-Quantifier|) (MUST (|PARSE-QuantifiedVariableList|)) - (MUST (MATCH-ADVANCE-STRING ".")) + (MUST (|matchAdvanceString| ".")) (MUST (|PARSE-Expr| 200)) (MUST (|pushReduction| '|PARSE-Forall| (CONS (|popStack3|) @@ -250,21 +250,21 @@ (MUST (|pushReduction| '|PARSE-Quantifier| '|%Exist|))))) (DEFUN |PARSE-QuantifiedVariableList| () - (AND (MATCH-ADVANCE-STRING "(") + (AND (|matchAdvanceString| "(") (MUST (|PARSE-QuantifiedVariable|)) (OPTIONAL (AND (STAR REPEATOR - (AND (MATCH-ADVANCE-STRING ",") + (AND (|matchAdvanceString| ",") (MUST (|PARSE-QuantifiedVariable|)))) (|pushReduction| '|PARSE-QuantifiedVariableList| (CONS '|%Sequence| (CONS (|popStack2|) (APPEND (|popStack1|) NIL)))))) - (MUST (MATCH-ADVANCE-STRING ")")))) + (MUST (|matchAdvanceString| ")")))) (DEFUN |PARSE-QuantifiedVariable| () (AND (|parseName|) - (MUST (MATCH-ADVANCE-STRING ":")) + (MUST (|matchAdvanceString| ":")) (MUST (|PARSE-Application|)) (MUST (|pushReduction| '|PARSE-QuantifiedVariable| (CONS '|:| @@ -308,13 +308,13 @@ (DEFUN |PARSE-Qualification| () - (AND (MATCH-ADVANCE-STRING "$") (MUST (|PARSE-Primary1|)) + (AND (|matchAdvanceString| "$") (MUST (|PARSE-Primary1|)) (|pushReduction| '|PARSE-Qualification| (|dollarTran| (|popStack1|) (|popStack1|))))) (DEFUN |PARSE-SemiColon| () - (AND (MATCH-ADVANCE-STRING ";") + (AND (|matchAdvanceString| ";") (MUST (OR (|PARSE-Expr| 82) (|pushReduction| '|PARSE-SemiColon| '|/throwAway|))) (|pushReduction| '|PARSE-SemiColon| @@ -439,7 +439,7 @@ (DEFUN |PARSE-Variable| () (OR (AND (|parseName|) - (OPTIONAL (AND (MATCH-ADVANCE-STRING ":") + (OPTIONAL (AND (|matchAdvanceString| ":") (MUST (|PARSE-Application|)) (MUST (|pushReduction| '|PARSE-Variable| (CONS '|:| @@ -463,7 +463,7 @@ (CONS (|popStack2|) (CONS (|popStack1|) NIL)))))) (OPTIONAL - (AND (MATCH-ADVANCE-STRING "|") + (AND (|matchAdvanceString| "|") (MUST (|PARSE-Expr| 111)) (|pushReduction| '|PARSE-Iterator| (CONS '|\|| (CONS (|popStack1|) NIL)))))) @@ -493,8 +493,8 @@ (DEFUN |PARSE-Label| () - (AND (MATCH-ADVANCE-STRING "<<") (MUST (|parseName|)) - (MUST (MATCH-ADVANCE-STRING ">>")))) + (AND (|matchAdvanceString| "<<") (MUST (|parseName|)) + (MUST (|matchAdvanceString| ">>")))) (DEFUN |PARSE-LedPart| (RBP) @@ -577,12 +577,12 @@ (DEFUN |PARSE-Selector| () (OR (AND |$nonblank| (EQ (|currentSymbol|) '|.|) - (CHAR-NE (|currentChar|) '| |) (MATCH-ADVANCE-STRING ".") + (CHAR-NE (|currentChar|) '| |) (|matchAdvanceString| ".") (MUST (|PARSE-PrimaryNoFloat|)) (MUST (|pushReduction| '|PARSE-Selector| (CONS (|popStack2|) (CONS (|popStack1|) NIL))))) (AND (OR (|PARSE-Float|) - (AND (MATCH-ADVANCE-STRING ".") + (AND (|matchAdvanceString| ".") (MUST (|PARSE-Primary|)))) (MUST (|pushReduction| '|PARSE-Selector| (CONS (|popStack2|) (CONS (|popStack1|) NIL))))))) @@ -597,7 +597,7 @@ (DEFUN |PARSE-Primary1| () - (OR (AND (|PARSE-VarForm|) + (OR (AND (|parseName|) (OPTIONAL (AND |$nonblank| (EQ (|currentSymbol|) '|(|) (MUST (|PARSE-Primary1|)) @@ -605,7 +605,7 @@ (CONS (|popStack2|) (CONS (|popStack1|) NIL)))))) (|PARSE-Quad|) (|parseString|) (|parseInteger|) (|parseFormalParameter|) - (AND (MATCH-ADVANCE-STRING "'") + (AND (|matchAdvanceString| "'") (MUST (AND (MUST (|PARSE-Data|)) (|pushReduction| '|PARSE-Primary1| (|popStack1|))))) (|PARSE-Sequence|) (|PARSE-Enclosure|))) @@ -634,7 +634,7 @@ (DEFUN |PARSE-FloatBasePart| () - (AND (MATCH-ADVANCE-STRING ".") + (AND (|matchAdvanceString| ".") (MUST (OR (AND (DIGITP (|currentChar|)) (|pushReduction| '|PARSE-FloatBasePart| (|tokenNonblank?| (|currentToken|))) @@ -649,9 +649,9 @@ (OR (AND (MEMBER (|currentSymbol|) '(E |e|)) (FIND (|currentChar|) "+-") (ACTION (|advanceToken|)) (MUST (OR (|parseInteger|) - (AND (MATCH-ADVANCE-STRING "+") + (AND (|matchAdvanceString| "+") (MUST (|parseInteger|))) - (AND (MATCH-ADVANCE-STRING "-") + (AND (|matchAdvanceString| "-") (MUST (|parseInteger|)) (|pushReduction| '|PARSE-FloatExponent| (MINUS (|popStack1|)))) @@ -663,27 +663,27 @@ (DEFUN |PARSE-Enclosure| () - (OR (AND (MATCH-ADVANCE-STRING "(") + (OR (AND (|matchAdvanceString| "(") (MUST (OR (AND (|PARSE-Expr| 6) - (MUST (MATCH-ADVANCE-STRING ")"))) - (AND (MATCH-ADVANCE-STRING ")") + (MUST (|matchAdvanceString| ")"))) + (AND (|matchAdvanceString| ")") (|pushReduction| '|PARSE-Enclosure| (CONS '|%Comma| NIL)))))) - (AND (MATCH-ADVANCE-STRING "{") + (AND (|matchAdvanceString| "{") (MUST (OR (AND (|PARSE-Expr| 6) - (MUST (MATCH-ADVANCE-STRING "}")) + (MUST (|matchAdvanceString| "}")) (|pushReduction| '|PARSE-Enclosure| (CONS '|brace| (CONS (CONS '|construct| (CONS (|popStack1|) NIL)) NIL)))) - (AND (MATCH-ADVANCE-STRING "}") + (AND (|matchAdvanceString| "}") (|pushReduction| '|PARSE-Enclosure| (CONS '|brace| NIL)))))) - (AND (MATCH-ADVANCE-STRING "[|") + (AND (|matchAdvanceString| "[|") (MUST (AND (|PARSE-Statement|) - (MUST (MATCH-ADVANCE-STRING "|]")) + (MUST (|matchAdvanceString| "|]")) (|pushReduction| '|PARSE-Enclosure| (CONS '|[\|\|]| (CONS (|popStack1|) NIL))) @@ -691,38 +691,9 @@ )) (DEFUN |PARSE-Quad| () - (AND (MATCH-ADVANCE-STRING "$") + (AND (|matchAdvanceString| "$") (|pushReduction| '|PARSE-Quad| '$))) -(DEFUN |PARSE-VarForm| () - (AND (|parseName|) - (OPTIONAL - (AND (|PARSE-Scripts|) - (|pushReduction| '|PARSE-VarForm| - (CONS '|Scripts| - (CONS (|popStack2|) (CONS (|popStack1|) NIL)))))) - (|pushReduction| '|PARSE-VarForm| (|popStack1|)))) - - -(DEFUN |PARSE-Scripts| () - (AND |$nonblank| (MATCH-ADVANCE-STRING "[") (MUST (|PARSE-ScriptItem|)) - (MUST (MATCH-ADVANCE-STRING "]")))) - - -(DEFUN |PARSE-ScriptItem| () - (OR (AND (|PARSE-Expr| 90) - (OPTIONAL - (AND (STAR REPEATOR - (AND (MATCH-ADVANCE-STRING ";") - (MUST (|PARSE-ScriptItem|)))) - (|pushReduction| '|PARSE-ScriptItem| - (CONS '|;| - (CONS (|popStack2|) - (APPEND (|popStack1|) NIL))))))) - (AND (MATCH-ADVANCE-STRING ";") (MUST (|PARSE-ScriptItem|)) - (|pushReduction| '|PARSE-ScriptItem| - (CONS '|PrefixSC| (CONS (|popStack1|) NIL)))))) - (DEFUN |PARSE-Data| () (AND (ACTION (SETQ LABLASOC NIL)) (|PARSE-Sexpr|) (|pushReduction| '|PARSE-Data| @@ -736,24 +707,24 @@ (DEFUN |PARSE-Sexpr1| () (OR (|parseInteger|) (|parseString|) - (AND (|PARSE-AnyId|) + (AND (|parseAnyId|) (OPTIONAL (AND (|PARSE-NBGliphTok| '=) (MUST (|PARSE-Sexpr1|)) (ACTION (SETQ LABLASOC (CONS (CONS (|popStack2|) (|nthStack| 1)) LABLASOC)))))) - (AND (MATCH-ADVANCE-STRING "'") (MUST (|PARSE-Sexpr1|)) + (AND (|matchAdvanceString| "'") (MUST (|PARSE-Sexpr1|)) (|pushReduction| '|PARSE-Sexpr1| (CONS 'QUOTE (CONS (|popStack1|) NIL)))) ;; next form disabled -- gdr, 2009-06-15. -; (AND (MATCH-ADVANCE-STRING "-") (MUST (|parseInteger|)) +; (AND (|matchAdvanceString| "-") (MUST (|parseInteger|)) ; (|pushReduction| '|PARSE-Sexpr1| (MINUS (|popStack1|)))) - (AND (MATCH-ADVANCE-STRING "[") + (AND (|matchAdvanceString| "[") (BANG FIL_TEST (OPTIONAL (STAR REPEATOR (|PARSE-Sexpr1|)))) - (MUST (MATCH-ADVANCE-STRING "]")) + (MUST (|matchAdvanceString| "]")) (|pushReduction| '|PARSE-Sexpr1| (LIST2VEC (|popStack1|)))) - (AND (MATCH-ADVANCE-STRING "(") + (AND (|matchAdvanceString| "(") (BANG FIL_TEST (OPTIONAL (AND (STAR REPEATOR (|PARSE-Sexpr1|)) @@ -762,7 +733,7 @@ (MUST (|PARSE-Sexpr1|)) (|pushReduction| '|PARSE-Sexpr1| (|append!| (|popStack2|) (|popStack1|)))))))) - (MUST (MATCH-ADVANCE-STRING ")"))))) + (MUST (|matchAdvanceString| ")"))))) (DEFUN |PARSE-NBGliphTok| (|tok|) @@ -776,21 +747,11 @@ (AND (|matchCurrentToken| 'GLIPH (INTERN |tok|)) (ACTION (|advanceToken|)))) - -(DEFUN |PARSE-AnyId| () - (OR (|parseName|) - (OR (AND (|matchString| "$") - (|pushReduction| '|PARSE-AnyId| (|currentSymbol|)) - (ACTION (|advanceToken|))) - (|parseToken| 'KEYWORD) - (|PARSE-OperatorFunctionName|)))) - - (DEFUN |PARSE-Sequence| () (OR (AND (|PARSE-OpenBracket|) (MUST (|PARSE-Sequence1|)) - (MUST (MATCH-ADVANCE-STRING "]"))) + (MUST (|matchAdvanceString| "]"))) (AND (|PARSE-OpenBrace|) (MUST (|PARSE-Sequence1|)) - (MUST (MATCH-ADVANCE-STRING "}")) + (MUST (|matchAdvanceString| "}")) (|pushReduction| '|PARSE-Sequence| (CONS '|brace| (CONS (|popStack1|) NIL)))))) diff --git a/src/interp/lexing.boot b/src/interp/lexing.boot index 712b1927..8be1464f 100644 --- a/src/interp/lexing.boot +++ b/src/interp/lexing.boot @@ -39,7 +39,9 @@ import sys_-macros namespace BOOT -module lexing +module lexing where + matchString: %String -> %Maybe %Short + matchAdvanceString: %String -> %Maybe %Short --% --% Line abstract datatype @@ -326,10 +328,12 @@ getIdentifier(tok,esc?) == 'IDENTIFIER tokenInstall(s,tt,tok,$nonblank) +escapeKeywords: (%String,%Symbol) -> %String escapeKeywords(nm,id) == symbolMember?(id,Keywords) => strconc('"__",nm) nm +underscore: %String -> %String underscore s == n := #s - 1 and/[alphabetic? stringChar(s,i) for i in 0..n] => s @@ -341,6 +345,7 @@ underscore s == buf := [c,:buf] listToString reverse! buf +quoteIfString: %Thing -> %Maybe %String quoteIfString tok == tok = nil => nil tt := tokenType tok @@ -349,7 +354,7 @@ quoteIfString tok == tt is 'SPECIAL_-CHAR => charString tokenSymbol tok tt is 'IDENTIFIER => escapeKeywords(symbolName tokenSymbol tok,tokenSymbol tok) - tokenSymbol tok + symbolName tokenSymbol tok ungetTokens() == $validTokens = 0 => true @@ -385,6 +390,18 @@ matchString x == and/[stringChar(x,i) = stringChar(buf,idx + i) for i in 0..nx-1] and nx nil +++ Same as matchString except if successful, advance inputstream past `x'. +matchAdvanceString x == + n := #x >= #quoteIfString currentToken() and matchString x => + lineCurrentIndex($spadLine) := lineCurrentIndex $spadLine + n + c := + linePastEnd? $spadLine => charByName '"Space" + lineBuffer($spadLine).(lineCurrentIndex $spadLine) + lineCurrentChar($spadLine) := c + $priorToken := makeToken(makeSymbol x,'IDENTIFIER,$nonblank) + n + nil + --% --% Stack abstract datatype. --% Operational semantics: diff --git a/src/interp/parsing.lisp b/src/interp/parsing.lisp index 1dd53dea..668bf1e3 100644 --- a/src/interp/parsing.lisp +++ b/src/interp/parsing.lisp @@ -46,15 +46,6 @@ ; CONTENTS: ; -; 0. Current I/O Stream definition -; -; 1. Data structure declarations (defstructs) for parsing objects -; -; A. Line Buffer -; B. Stack -; C. Token -; D. Reduction -; ; 2. Recursive descent parsing support routines ; A. Stacking and retrieving reductions of rules. ; B. Applying metagrammatical elements of a production (e.g., Star). @@ -70,10 +61,6 @@ ; ; 5. Routines for inspecting and resetting total I/O system state ; -; METALEX.LISP: Meta file handling, auxiliary parsing actions and tokenizing -; -; BOOTLEX.LISP: Boot file handling, auxiliary parsing actions and tokenizing -; NEWMETA.LISP: Boot parsing (import-module "lexing") @@ -87,34 +74,10 @@ (defparameter out-stream t "Current output stream.") (defparameter File-Closed nil "Way to stop EOF tests for console input.") - -; 1. Data structure declarations (defstructs) for parsing objects -; -; A. Line Buffer - -; 1A. A Line Buffer -; -; The philosophy of lines is that -; -; a) NEXT LINE will always get you a non-blank line or fail. -; b) Every line is terminated by a blank character. -; -; Hence there is always a current character, because there is never a non-blank line, -; and there is always a separator character between tokens on separate lines. -; Also, when a line is read, the character pointer is always positioned ON the first -; character. - -; FUNCTIONS DEFINED IN THIS SECTION: -; -; Line-New-Line, Line-Advance-Char, Line-Past-End-P, Line-At-End-P -; Make-Line - (defun Line-Print (line) (format out-stream "~&~5D> ~A~%" (|lineNumber| line) (|lineBuffer| Line)) (format out-stream "~v@T^~%" (+ 7 (|lineCurrentIndex| line)))) -; *** Next Line - (defun make-string-adjustable (s) (cond ((adjustable-array-p s) s) (t (make-array (array-dimensions s) :element-type 'character @@ -221,16 +184,6 @@ Symbolics read-line returns embedded newlines in a c-m-Y.") (progn (format t "The prior token was~%") (describe |$priorToken|)))) -; Parsing of operator tokens depends on tables initialized by BOTTOMUP.LISP - -(defun |PARSE-OperatorFunctionName| () - (let ((id (|makeSymbolOf| (or (|matchCurrentToken| 'keyword) - (|matchCurrentToken| 'gliph) - (|matchCurrentToken| 'special-char))))) - (when (and id (member id |$OperatorFunctionNames|)) - (|pushReduction| '|PARSE-OperatorFunctionName| id) - (action (|advanceToken|))))) - (defun make-adjustable-string (n) (make-array (list n) :element-type 'character :adjustable t)) @@ -342,32 +295,6 @@ the stack, then stack a NIL. Return the value of prod." ; (3) Line handling: Next Line, Print Next Line ; (X) Random Stuff -; 3A (0). String grabbing - -; String grabbing is the art of matching initial segments of the current -; line, and removing them from the line before the get tokenized if they -; match (or removing the corresponding current tokens). - -; FUNCTIONS DEFINED IN THIS SECTION: -; -; Match-Advance-String - -(defun Match-Advance-String (x) - "Same as matchString except if successful, advance inputstream past X." - (let ((y (if (>= (length (string x)) - (length (string (|quoteIfString| (|currentToken|))))) - (|matchString| x) - nil))) ; must match at least the current token - (if y (progn (incf (|lineCurrentIndex| |$spadLine|) y) - (if (not (|linePastEnd?| |$spadLine|)) - (setf (|lineCurrentChar| |$spadLine|) - (elt (|lineBuffer| |$spadLine|) - (|lineCurrentIndex| |$spadLine|))) - (setf (|lineCurrentChar| |$spadLine|) #\Space)) - (setq |$priorToken| - (|makeToken| (intern (string x)) 'identifier |$nonblank|)) - t)))) - (defun match-advance-keyword (str) (and (|matchToken| (|currentToken|) 'keyword (intern str)) (action (|advanceToken|)))) diff --git a/src/interp/spad-parser.boot b/src/interp/spad-parser.boot index 3ab5c41a..c7f6e8a8 100644 --- a/src/interp/spad-parser.boot +++ b/src/interp/spad-parser.boot @@ -67,6 +67,24 @@ parseName() == parseFormalParameter() == parseToken 'ARGUMENT_-DESIGNATOR +parseOperatorFunctionName() == + id := makeSymbolOf(matchCurrentToken 'KEYWORD + or matchCurrentToken 'GLIPH + or matchCurrentToken 'SPECIAL_-CHAR) + symbolMember?(id,$OperatorFunctionNames) => + pushReduction('parseOperatorFunctionName,id) + advanceToken() + true + false + +parseAnyId() == + parseName() => true + matchString '"$" => + pushReduction('parseAnyId,currentSymbol()) + advanceToken() + true + parseOperatorFunctionName() + --% ++ Given a pathname to a source file containing Spad code, returns |