aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog26
-rw-r--r--src/boot/parser.boot12
-rw-r--r--src/interp/Makefile.in7
-rw-r--r--src/interp/bootlex.lisp20
-rw-r--r--src/interp/c-doc.boot2
-rw-r--r--src/interp/fnewmeta.lisp627
-rw-r--r--src/interp/lexing.boot43
-rw-r--r--src/interp/newaux.lisp61
-rw-r--r--src/interp/parse.boot8
-rw-r--r--src/interp/parsing.lisp4
-rw-r--r--src/interp/preparse.lisp25
-rw-r--r--src/interp/spad-parser.boot604
-rw-r--r--src/interp/spad.lisp17
-rw-r--r--src/interp/sys-constants.boot2
-rw-r--r--src/lisp/core.lisp.in9
15 files changed, 692 insertions, 775 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index 63ed42d9..2fc0070c 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,29 @@
+2011-10-17 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
+ * lisp/core.lisp.in: Add ref and deref to support references.
+ * interp/sys-constants.boot ($OperatorFunctionNames): Add "by" and
+ "..".
+ * interp/spad.lisp: Tidy.
+ * interp/spad-parser.boot: New parsers.
+ * interp/preparse.lisp: Remove dead codes.
+ * interp/parsing.lisp (MATCH-ADVANCE-KEYWORD): Remove.
+ * interp/parse.boot (doParseCategory): Rename from parseCategory.
+ * interp/newaux.lisp: Tidy.
+ * interp/lexing.boot (getSpadToken): New.
+ (Keywords): Remove 'when'.
+ (matchKeywordNext): New.
+ (matchSpecial): Likewise.
+ (matchAdvanceSpecial): Likewise.
+ (matchAdvanceGlyph): Likewise.
+ * interp/fnewmeta.lisp: Move variable definitions to preparse.lisp.
+ Remove Lisp based parsers.
+ Remove file.
+ * interp/c-doc.boot (recordAttributeDocumentation): Fix thinko.
+ * interp/bootlex.lisp (GET-BOOT-TOKEN): Remove.
+ * interp/Makefile.in: Adjust dependencies.
+ * boot/parser.boot (bpChar): New.
+ (bpPattern): Allow character constants.
+
2011-10-16 Gabriel Dos Reis <gdr@cs.tamu.edu>
* algebra/boolean.spad.pamphlet (Boolean): Implement default
diff --git a/src/boot/parser.boot b/src/boot/parser.boot
index f2c0a721..f9ae96dc 100644
--- a/src/boot/parser.boot
+++ b/src/boot/parser.boot
@@ -383,6 +383,16 @@ bpConstTok() ==
bpPush bfSymbol bpPop1()
bpString()
+bpChar() ==
+ $stok is ["ID",:.] and $ttok is "char" =>
+ a := bpState()
+ bpApplication() =>
+ s := bpPop1()
+ s is ["char",.] => bpPush s
+ bpRestore a
+ false
+ false
+ false
++ Subroutine of bpExportItem. Parses tails of ExportItem.
bpExportItemTail() ==
@@ -1004,7 +1014,7 @@ bpDConstruction()==
bpPattern()==
bpBracketConstruct function bpPatternL
- or bpName() or bpConstTok()
+ or bpChar() or bpName() or bpConstTok()
bpEqual()==
bpEqKey "SHOEEQ" and (bpApplication() or bpConstTok() or
diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in
index 2093e74e..964d7914 100644
--- a/src/interp/Makefile.in
+++ b/src/interp/Makefile.in
@@ -100,7 +100,7 @@ OBJS= boot-pkg.$(FASLEXT) types.$(FASLEXT) \
record.$(FASLEXT) rulesets.$(FASLEXT) \
server.$(FASLEXT) setvars.$(FASLEXT) \
sfsfun-l.$(FASLEXT) sfsfun.$(FASLEXT) \
- slam.$(FASLEXT) fnewmeta.$(FASLEXT) \
+ slam.$(FASLEXT) \
preparse.$(FASLEXT) bootlex.$(FASLEXT) \
spad.$(FASLEXT) spaderror.$(FASLEXT) \
termrw.$(FASLEXT) \
@@ -322,15 +322,14 @@ server.$(FASLEXT): macros.$(FASLEXT)
## The old parser component roughtly is:
##
-spad-parser.$(FASLEXT): parsing.$(FASLEXT) parse.$(FASLEXT) fnewmeta.$(FASLEXT)
+spad-parser.$(FASLEXT): parse.$(FASLEXT) preparse.$(FASLEXT)
parse.$(FASLEXT): parsing.$(FASLEXT) postpar.$(FASLEXT)
packtran.$(FASLEXT): sys-macros.$(FASLEXT)
postpar.$(FASLEXT): macros.$(FASLEXT)
bootlex.$(FASLEXT): preparse.$(FASLEXT) macros.$(FASLEXT) \
nlib.$(FASLEXT) sys-globals.$(FASLEXT)
newaux.$(FASLEXT): macros.$(FASLEXT)
-preparse.$(FASLEXT): fnewmeta.$(FASLEXT)
-fnewmeta.$(FASLEXT): parsing.$(FASLEXT)
+preparse.$(FASLEXT): parsing.$(FASLEXT)
parsing.$(FASLEXT): lexing.$(FASLEXT) macros.$(FASLEXT)
nlib.$(FASLEXT): macros.$(FASLEXT)
macros.$(FASLEXT): sys-macros.$(FASLEXT) sys-utility.$(FASLEXT)
diff --git a/src/interp/bootlex.lisp b/src/interp/bootlex.lisp
index b90cb4ba..93d6b997 100644
--- a/src/interp/bootlex.lisp
+++ b/src/interp/bootlex.lisp
@@ -154,26 +154,6 @@
; *** 3. BOOT Token Handling ***
-(defun get-BOOT-token (token)
-
- "If you have an _, go to the next line.
-If you have a . followed by an integer, get a floating point number.
-Otherwise, get a .. identifier."
-
- (if (not (|skipBlankChars|))
- nil
- (let ((token-type (|tokenLookaheadType| (|currentChar|))))
- (case token-type
- (eof (|tokenInstall| nil '*eof token |$nonblank|))
- (escape (|advanceChar!|)
- (|getIdentifier| token t))
- (argument-designator (get-argument-designator-token token))
- (id (|getIdentifier| token nil))
- (num (get-spad-integer-token token))
- (string (|getSpadString| token))
- (special-char (|getSpecial| token))
- (t (|getGliph| token token-type))))))
-
(defun get-argument-designator-token (token)
(|advanceChar!|)
(get-number-token token)
diff --git a/src/interp/c-doc.boot b/src/interp/c-doc.boot
index fbf666f0..0b341a16 100644
--- a/src/interp/c-doc.boot
+++ b/src/interp/c-doc.boot
@@ -97,7 +97,7 @@ readForDoc fn ==
recordSignatureDocumentation(opSig,lineno) ==
recordDocumentation(rest postTransform opSig,lineno)
-recordAttributeDocumentation(['Attribute,att],lineno) ==
+recordAttributeDocumentation(['%Attribute,att],lineno) ==
name := opOf att
upperCase? stringChar(symbolName name,0) => nil
recordDocumentation([name,['attribute,:IFCDR postTransform att]],lineno)
diff --git a/src/interp/fnewmeta.lisp b/src/interp/fnewmeta.lisp
deleted file mode 100644
index f36d4f37..00000000
--- a/src/interp/fnewmeta.lisp
+++ /dev/null
@@ -1,627 +0,0 @@
-;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-;; All rights reserved.
-;; Copyright (C) 2007-2011, Gabriel Dos Reis.
-;; All rights reserved.
-;;
-;; Redistribution and use in source and binary forms, with or without
-;; modification, are permitted provided that the following conditions are
-;; met:
-;;
-;; - Redistributions of source code must retain the above copyright
-;; notice, this list of conditions and the following disclaimer.
-;;
-;; - Redistributions in binary form must reproduce the above copyright
-;; notice, this list of conditions and the following disclaimer in
-;; the documentation and/or other materials provided with the
-;; distribution.
-;;
-;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the
-;; names of its contributors may be used to endorse or promote products
-;; derived from this software without specific prior written permission.
-;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
-;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
-;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
-;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
-;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
-;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-;; % Binding powers stored under the Led and Red properties of an operator
-;; % are set up by the file BOTTOMUP.LISP. The format for a Led property
-;; % is <Operator Left-Power Right-Power>, and the same for a Nud, except that
-;; % it may also have a fourth component <Special-Handler>. ELEMN attempts to
-;; % get the Nth indicator, counting from 1.
-
-(IMPORT-MODULE "parsing")
-(IN-PACKAGE "BOOT" )
-
-
-(DEFPARAMETER |tmptok| NIL)
-(DEFPARAMETER TOK NIL)
-(DEFPARAMETER |ParseMode| NIL)
-(DEFPARAMETER DEFINITION_NAME NIL)
-(DEFPARAMETER LABLASOC NIL)
-
-(defun |isTokenDelimiter| ()
- (MEMBER (|currentSymbol|) '(\) END\_UNIT NIL)))
-
-(DEFUN |PARSE-SpecialCommand| ()
- (OR (AND (|matchAdvanceString| "show")
- (BANG FIL_TEST
- (OPTIONAL
- (OR (|matchAdvanceString| "?")
- (|PARSE-Expression|))))
- (|pushReduction| '|PARSE-SpecialCommand|
- (CONS '|show| (CONS (|popStack1|) NIL)))
- (MUST (|PARSE-CommandTail|)))
- (AND (MEMBER (|currentSymbol|) |$noParseCommands|)
- (ACTION (FUNCALL (|currentSymbol|))))
- (AND (MEMBER (|currentSymbol|) |$tokenCommands|)
- (|PARSE-TokenList|) (MUST (|PARSE-TokenCommandTail|)))
- (AND (STAR REPEATOR (|parsePrimaryOrQM|))
- (MUST (|PARSE-CommandTail|)))))
-
-
-(DEFUN |PARSE-TokenList| ()
- (STAR REPEATOR
- (AND (NOT (|isTokenDelimiter|))
- (|pushReduction| '|PARSE-TokenList| (|currentSymbol|))
- (ACTION (|advanceToken|)))))
-
-
-(DEFUN |PARSE-TokenCommandTail| ()
- (AND (BANG FIL_TEST (OPTIONAL (STAR REPEATOR (|parseTokenOption|))))
- (|atEndOfLine|)
- (|pushReduction| '|PARSE-TokenCommandTail|
- (CONS (|popStack2|) (APPEND (|popStack1|) NIL)))
- (ACTION (|systemCommand| (|popStack1|)))))
-
-(DEFUN |PARSE-CommandTail| ()
- (AND (BANG FIL_TEST (OPTIONAL (STAR REPEATOR (|PARSE-Option|))))
- (|atEndOfLine|)
- (|pushReduction| '|PARSE-CommandTail|
- (CONS (|popStack2|) (APPEND (|popStack1|) NIL)))
- (ACTION (|systemCommand| (|popStack1|)))))
-
-(DEFUN |PARSE-Option| ()
- (AND (|matchAdvanceString| ")")
- (MUST (STAR REPEATOR (|parsePrimaryOrQM|)))))
-
-
-(DEFUN |PARSE-Statement| ()
- (AND (|PARSE-Expr| 0)
- (OPTIONAL
- (AND (STAR REPEATOR
- (AND (|matchAdvanceString| ",")
- (MUST (|PARSE-Expr| 0))))
- (|pushReduction| '|PARSE-Statement|
- (CONS '|Series|
- (CONS (|popStack2|)
- (APPEND (|popStack1|) NIL))))))))
-
-(DEFUN |PARSE-Category| ()
- (PROG (G1)
- (RETURN
- (OR (AND (MATCH-ADVANCE-KEYWORD "if") (MUST (|PARSE-Expression|))
- (MUST (MATCH-ADVANCE-KEYWORD "then"))
- (MUST (|PARSE-Category|))
- (BANG FIL_TEST
- (OPTIONAL
- (AND (MATCH-ADVANCE-KEYWORD "else")
- (MUST (|PARSE-Category|)))))
- (|pushReduction| '|PARSE-Category|
- (CONS '|if|
- (CONS (|popStack3|)
- (CONS (|popStack2|)
- (CONS (|popStack1|) NIL))))))
- (AND (|matchAdvanceString| "(") (MUST (|PARSE-Category|))
- (BANG FIL_TEST
- (OPTIONAL
- (STAR REPEATOR
- (AND (|matchAdvanceString| ";")
- (MUST (|PARSE-Category|))))))
- (MUST (|matchAdvanceString| ")"))
- (|pushReduction| '|PARSE-Category|
- (CONS 'CATEGORY
- (CONS (|popStack2|)
- (APPEND (|popStack1|) NIL)))))
- (AND (ACTION (SETQ G1 (|lineNumber| |$spadLine|)))
- (OR (|PARSE-Application|)
- (|parseOperatorFunctionName|))
- (MUST (OR (AND (|matchAdvanceString| ":")
- (MUST (|PARSE-Expression|))
- (|pushReduction| '|PARSE-Category|
- (CONS '|%Signature|
- (CONS (|popStack2|)
- (CONS (|popStack1|) NIL))))
- (ACTION (|recordSignatureDocumentation|
- (|nthStack| 1) G1)))
- (AND (|pushReduction| '|PARSE-Category|
- (CONS '|%Attribute|
- (CONS (|popStack1|) NIL)))
- (ACTION (|recordAttributeDocumentation|
- (|nthStack| 1) G1))))))))))
-
-
-(DEFUN |PARSE-Expression| ()
- (AND (|PARSE-Expr|
- (|PARSE-rightBindingPowerOf| (|makeSymbolOf| |$priorToken|)
- |ParseMode|))
- (|pushReduction| '|PARSE-Expression| (|popStack1|))))
-
-
-(DEFUN |PARSE-Import| ()
- (AND (MATCH-ADVANCE-KEYWORD "import")
- (MUST (|PARSE-Expr| 1000))
- (OR (AND (|matchAdvanceString| ":")
- (MUST (|PARSE-Expression|))
- (MUST (MATCH-ADVANCE-KEYWORD "from"))
- (MUST (|PARSE-Expr| 1000))
- (|pushReduction| '|PARSE-Import|
- (CONS '|%SignatureImport|
- (CONS (|popStack3|)
- (CONS (|popStack2|)
- (CONS (|popStack1|) NIL))))))
- (AND (BANG FIL_TEST
- (OPTIONAL
- (STAR REPEATOR
- (AND (|matchAdvanceString| ",")
- (MUST (|PARSE-Expr| 1000))))))
- (|pushReduction| '|PARSE-Import|
- (CONS '|import|
- (CONS (|popStack2|) (APPEND (|popStack1|) NIL))))))))
-
-;; quantified types. At the moment, these are used only in
-;; pattern-mathing cases.
-;; -- gdr, 2009-06-14.
-(DEFUN |PARSE-Scheme| ()
- (OR (AND (|parseQuantifier|)
- (MUST (|PARSE-QuantifiedVariableList|))
- (MUST (|matchAdvanceString| "."))
- (MUST (|PARSE-Expr| 200))
- (MUST (|pushReduction| '|PARSE-Forall|
- (CONS (|popStack3|)
- (CONS (|popStack2|)
- (CONS (|popStack1|) NIL))))))
- (|PARSE-Application|)))
-
-(DEFUN |PARSE-QuantifiedVariableList| ()
- (AND (|matchAdvanceString| "(")
- (MUST (|parseQuantifiedVariable|))
- (OPTIONAL
- (AND (STAR REPEATOR
- (AND (|matchAdvanceString| ",")
- (MUST (|parseQuantifiedVariable|))))
- (|pushReduction| '|PARSE-QuantifiedVariableList|
- (CONS '|%Sequence|
- (CONS (|popStack2|)
- (APPEND (|popStack1|) NIL))))))
- (MUST (|matchAdvanceString| ")"))))
-
-(DEFUN |PARSE-SemiColon| ()
- (AND (|matchAdvanceString| ";")
- (MUST (OR (|PARSE-Expr| 82)
- (|pushReduction| '|PARSE-SemiColon| '|/throwAway|)))
- (|pushReduction| '|PARSE-SemiColon|
- (CONS '|;| (CONS (|popStack2|) (CONS (|popStack1|) NIL))))))
-
-(DEFUN |PARSE-Catch| ()
- (AND (MATCH-SPECIAL ";")
- (MATCH-KEYWORD-NEXT "catch")
- (ACTION (|advanceToken|))
- (ACTION (|advanceToken|))
- (MUST (|PARSE-GlyphTok| "("))
- (MUST (|parseQuantifiedVariable|))
- (MUST (MATCH-ADVANCE-SPECIAL ")"))
- (MUST (|PARSE-GlyphTok| "=>"))
- (MUST (|PARSE-Expression|))
- (|pushReduction| '|PARSE-Catch|
- (CONS (|popStack2|)
- (CONS (|popStack1|) NIL)))))
-
-(DEFUN |PARSE-Finally| ()
- (AND (MATCH-SPECIAL ";")
- (MATCH-KEYWORD-NEXT "finally")
- (ACTION (|advanceToken|))
- (ACTION (|advanceToken|))
- (MUST (|PARSE-Expression|))))
-
-(DEFUN |PARSE-Try| ()
- (AND (MATCH-ADVANCE-KEYWORD "try")
- (MUST (|PARSE-Expression|))
- ;; exception handlers: either a finally-expression, or
- ;; a series of catch-expressions optionally followed by
- ;; a finally-expression.
- (MUST (OR (AND (|PARSE-Finally|)
- (|pushReduction| '|PARSE-Try|
- (CONS '|%Try|
- (CONS (|popStack2|)
- (CONS NIL
- (CONS (|popStack1|) NIL))))))
- (AND (MUST (STAR REPEATOR (|PARSE-Catch|)))
- (BANG FIL_TEST
- (OPTIONAL (|PARSE-Finally|)))
- (|pushReduction| '|PARSE-Try|
- (CONS '|%Try|
- (CONS (|popStack3|)
- (CONS (|popStack2|)
- (CONS (|popStack1|)
- NIL))))))))))
-
-(DEFUN |PARSE-Seg| ()
- (AND (|PARSE-GlyphTok| "..")
- (BANG FIL_TEST (OPTIONAL (|PARSE-Expression|)))
- (|pushReduction| '|PARSE-Seg|
- (CONS 'SEGMENT
- (CONS (|popStack2|) (CONS (|popStack1|) NIL))))))
-
-
-(DEFUN |PARSE-Conditional| ()
- (AND (MATCH-ADVANCE-KEYWORD "if") (MUST (|PARSE-Expression|))
- (MUST (MATCH-ADVANCE-KEYWORD "then")) (MUST (|PARSE-Expression|))
- (BANG FIL_TEST
- (OPTIONAL
- (AND (MATCH-ADVANCE-KEYWORD "else")
- (MUST (|parseElseClause|)))))
- (|pushReduction| '|PARSE-Conditional|
- (CONS '|if|
- (CONS (|popStack3|)
- (CONS (|popStack2|) (CONS (|popStack1|) NIL)))))))
-
-(DEFUN |PARSE-Loop| ()
- (OR (AND (STAR REPEATOR (|PARSE-Iterator|))
- (MUST (MATCH-ADVANCE-KEYWORD "repeat"))
- (MUST (|PARSE-Expr| 110))
- (|pushReduction| '|PARSE-Loop|
- (CONS 'REPEAT
- (APPEND (|popStack2|) (CONS (|popStack1|) NIL)))))
- (AND (MATCH-ADVANCE-KEYWORD "repeat") (MUST (|PARSE-Expr| 110))
- (|pushReduction| '|PARSE-Loop|
- (CONS 'REPEAT (CONS (|popStack1|) NIL))))))
-
-
-(DEFUN |PARSE-Variable| ()
- (OR (AND (|parseName|)
- (OPTIONAL (AND (|matchAdvanceString| ":")
- (MUST (|PARSE-Application|))
- (MUST (|pushReduction| '|PARSE-Variable|
- (CONS '|:|
- (CONS (|popStack2|)
- (CONS (|popStack1|) NIL))))))))
- (|parsePrimary|)))
-
-(DEFUN |PARSE-Iterator| ()
- (OR (AND (MATCH-ADVANCE-KEYWORD "for") (MUST (|PARSE-Variable|))
- (MUST (MATCH-ADVANCE-KEYWORD "in"))
- (MUST (|PARSE-Expression|))
- (MUST (OR (AND (MATCH-ADVANCE-KEYWORD "by")
- (MUST (|PARSE-Expr| 200))
- (|pushReduction| '|PARSE-Iterator|
- (CONS 'INBY
- (CONS (|popStack3|)
- (CONS (|popStack2|)
- (CONS (|popStack1|) NIL))))))
- (|pushReduction| '|PARSE-Iterator|
- (CONS 'IN
- (CONS (|popStack2|)
- (CONS (|popStack1|) NIL))))))
- (OPTIONAL
- (AND (|matchAdvanceString| "|")
- (MUST (|PARSE-Expr| 111))
- (|pushReduction| '|PARSE-Iterator|
- (CONS '|\|| (CONS (|popStack1|) NIL))))))
- (AND (MATCH-ADVANCE-KEYWORD "while") (MUST (|PARSE-Expr| 190))
- (|pushReduction| '|PARSE-Iterator|
- (CONS 'WHILE (CONS (|popStack1|) NIL))))
- (AND (MATCH-ADVANCE-KEYWORD "until") (MUST (|PARSE-Expr| 190))
- (|pushReduction| '|PARSE-Iterator|
- (CONS 'UNTIL (CONS (|popStack1|) NIL))))))
-
-
-(DEFUN |PARSE-Match| ()
- (AND (MATCH-ADVANCE-KEYWORD "case")
- (MUST (|PARSE-Expr| 400))
- (MATCH-ADVANCE-KEYWORD "is")
- (MUST (|PARSE-Expr| 110))
- (|pushReduction| '|PARSE-Match|
- (CONS '|%Match|
- (CONS (|popStack2|)
- (CONS (|popStack1|) NIL))))))
-
-(DEFUN |PARSE-Expr| (RBP)
- (DECLARE (SPECIAL RBP))
- (AND (|PARSE-NudPart| RBP)
- (OPTIONAL (STAR OPT_EXPR (|PARSE-LedPart| RBP)))
- (|pushReduction| '|PARSE-Expr| (|popStack1|))))
-
-(DEFUN |PARSE-LedPart| (RBP)
- (DECLARE (SPECIAL RBP))
- (AND (|PARSE-Operation| '|Led| RBP)
- (|pushReduction| '|PARSE-LedPart| (|popStack1|))))
-
-
-(DEFUN |PARSE-NudPart| (RBP)
- (DECLARE (SPECIAL RBP))
- (AND (OR (|PARSE-Operation| '|Nud| RBP) (|PARSE-Reduction|)
- (|PARSE-Form|))
- (|pushReduction| '|PARSE-NudPart| (|popStack1|))))
-
-
-(DEFUN |PARSE-Operation| (|ParseMode| RBP)
- (DECLARE (SPECIAL |ParseMode| RBP))
- (AND (NOT (|matchCurrentToken| 'IDENTIFIER))
- (GETL (SETQ |tmptok| (|currentSymbol|)) |ParseMode|)
- (LT RBP (|PARSE-leftBindingPowerOf| |tmptok| |ParseMode|))
- (ACTION (SETQ RBP
- (|PARSE-rightBindingPowerOf| |tmptok| |ParseMode|)))
- (|PARSE-getSemanticForm| |tmptok| |ParseMode|
- (ELEMN (GETL |tmptok| |ParseMode|) 5 NIL))))
-
-
-(DEFUN |PARSE-leftBindingPowerOf| (X IND)
- (DECLARE (SPECIAL X IND))
- (LET ((Y (GETL X IND))) (IF Y (ELEMN Y 3 0) 0)))
-
-
-(DEFUN |PARSE-rightBindingPowerOf| (X IND)
- (DECLARE (SPECIAL X IND))
- (LET ((Y (GETL X IND))) (IF Y (ELEMN Y 4 105) 105)))
-
-
-(DEFUN |PARSE-getSemanticForm| (X IND Y)
- (DECLARE (SPECIAL X IND Y))
- (OR (AND Y (EVAL Y)) (AND (EQ IND '|Nud|) (|parsePrefix|))
- (AND (EQ IND '|Led|) (|parseInfix|))))
-
-
-(DEFUN |PARSE-Reduction| ()
- (AND (|PARSE-ReductionOp|) (MUST (|PARSE-Expr| 1000))
- (|pushReduction| '|PARSE-Reduction|
- (CONS '|%Reduce|
- (CONS (|popStack2|) (CONS (|popStack1|) NIL))))))
-
-
-(DEFUN |PARSE-ReductionOp| ()
- (AND (GETL (|currentSymbol|) '|Led|)
- (|matchNextToken| 'GLIPH '/)
- (|pushReduction| '|PARSE-ReductionOp| (|currentSymbol|))
- (ACTION (|advanceToken|)) (ACTION (|advanceToken|))))
-
-
-(DEFUN |PARSE-Form| ()
- (OR (AND (MATCH-ADVANCE-KEYWORD "iterate")
- (|pushReduction| '|PARSE-Form| (CONS '|iterate| NIL)))
- (AND (MATCH-ADVANCE-KEYWORD "yield") (MUST (|PARSE-Application|))
- (|pushReduction| '|PARSE-Form|
- (CONS '|yield| (CONS (|popStack1|) NIL))))
- (|PARSE-Application|)))
-
-
-(DEFUN |PARSE-Application| ()
- (AND (|parsePrimary|) (OPTIONAL (STAR OPT_EXPR (|PARSE-Selector|)))
- (OPTIONAL
- (AND (|PARSE-Application|)
- (|pushReduction| '|PARSE-Application|
- (CONS (|popStack2|) (CONS (|popStack1|) NIL)))))))
-
-
-(DEFUN |PARSE-Selector| ()
- (OR (AND |$nonblank| (EQ (|currentSymbol|) '|.|)
- (CHAR-NE (|currentChar|) '| |) (|matchAdvanceString| ".")
- (MUST (|PARSE-PrimaryNoFloat|))
- (MUST (|pushReduction| '|PARSE-Selector|
- (CONS (|popStack2|) (CONS (|popStack1|) NIL)))))
- (AND (OR (|PARSE-Float|)
- (AND (|matchAdvanceString| ".")
- (MUST (|parsePrimary|))))
- (MUST (|pushReduction| '|PARSE-Selector|
- (CONS (|popStack2|) (CONS (|popStack1|) NIL)))))))
-
-
-(DEFUN |PARSE-PrimaryNoFloat| ()
- (AND (|PARSE-Primary1|) (OPTIONAL (|parseTokenTail|))))
-
-(DEFUN |PARSE-Primary1| ()
- (OR (AND (|parseName|)
- (OPTIONAL
- (AND |$nonblank| (EQ (|currentSymbol|) '|(|)
- (MUST (|PARSE-Primary1|))
- (|pushReduction| '|PARSE-Primary1|
- (CONS (|popStack2|) (CONS (|popStack1|) NIL))))))
- (|parseQuad|) (|parseString|) (|parseInteger|)
- (|parseFormalParameter|)
- (AND (|matchAdvanceString| "'")
- (MUST (AND (MUST (|PARSE-Data|))
- (|pushReduction| '|PARSE-Primary1| (|popStack1|)))))
- (|PARSE-Sequence|) (|PARSE-Enclosure|)))
-
-
-(DEFUN |PARSE-Float| ()
- (AND (|PARSE-FloatBase|)
- (MUST (OR (AND |$nonblank| (|PARSE-FloatExponent|))
- (|pushReduction| '|PARSE-Float| 0)))
- (|pushReduction| '|PARSE-Float|
- (MAKE-FLOAT (|popStack4|) (|popStack2|) (|popStack2|)
- (|popStack1|)))))
-
-
-(DEFUN |PARSE-FloatBase| ()
- (OR (AND (INTEGERP (|currentSymbol|)) (CHAR-EQ (|currentChar|) ".")
- (CHAR-NE (|nextChar|) ".") (|parseInteger|)
- (MUST (|PARSE-FloatBasePart|)))
- (AND (INTEGERP (|currentSymbol|))
- (CHAR-EQ (CHAR-UPCASE (|currentChar|)) 'E)
- (|parseInteger|) (|pushReduction| '|PARSE-FloatBase| 0)
- (|pushReduction| '|PARSE-FloatBase| 0))
- (AND (DIGITP (|currentChar|)) (EQ (|currentSymbol|) '|.|)
- (|pushReduction| '|PARSE-FloatBase| 0)
- (|PARSE-FloatBasePart|))))
-
-
-(DEFUN |PARSE-FloatBasePart| ()
- (AND (|matchAdvanceString| ".")
- (MUST (OR (AND (DIGITP (|currentChar|))
- (|pushReduction| '|PARSE-FloatBasePart|
- (|tokenNonblank?| (|currentToken|)))
- (|parseInteger|))
- (AND (|pushReduction| '|PARSE-FloatBasePart| 0)
- (|pushReduction| '|PARSE-FloatBasePart| 0))))))
-
-
-(DEFUN |PARSE-FloatExponent| ()
- (PROG (G1)
- (RETURN
- (OR (AND (MEMBER (|currentSymbol|) '(E |e|))
- (FIND (|currentChar|) "+-") (ACTION (|advanceToken|))
- (MUST (OR (|parseInteger|)
- (AND (|matchAdvanceString| "+")
- (MUST (|parseInteger|)))
- (AND (|matchAdvanceString| "-")
- (MUST (|parseInteger|))
- (|pushReduction| '|PARSE-FloatExponent|
- (MINUS (|popStack1|))))
- (|pushReduction| '|PARSE-FloatExponent| 0))))
- (AND (IDENTP (|currentSymbol|))
- (SETQ G1 (FLOATEXPID (|currentSymbol|)))
- (ACTION (|advanceToken|))
- (|pushReduction| '|PARSE-FloatExponent| G1))))))
-
-
-(DEFUN |PARSE-Enclosure| ()
- (OR (AND (|matchAdvanceString| "(")
- (MUST (OR (AND (|PARSE-Expr| 6)
- (MUST (|matchAdvanceString| ")")))
- (AND (|matchAdvanceString| ")")
- (|pushReduction| '|PARSE-Enclosure|
- (CONS '|%Comma| NIL))))))
- (AND (|matchAdvanceString| "{")
- (MUST (OR (AND (|PARSE-Expr| 6)
- (MUST (|matchAdvanceString| "}"))
- (|pushReduction| '|PARSE-Enclosure|
- (CONS '|brace|
- (CONS
- (CONS '|construct|
- (CONS (|popStack1|) NIL))
- NIL))))
- (AND (|matchAdvanceString| "}")
- (|pushReduction| '|PARSE-Enclosure|
- (CONS '|brace| NIL))))))
- (AND (|matchAdvanceString| "[|")
- (MUST (AND (|PARSE-Statement|)
- (MUST (|matchAdvanceString| "|]"))
- (|pushReduction| '|PARSE-Enclosure|
- (CONS '|[\|\|]|
- (CONS (|popStack1|) NIL)))
- )))
- ))
-
-(DEFUN |PARSE-Data| ()
- (AND (ACTION (SETQ LABLASOC NIL)) (|PARSE-Sexpr|)
- (|pushReduction| '|PARSE-Data|
- (CONS 'QUOTE (CONS (TRANSLABEL (|popStack1|) LABLASOC) NIL)))))
-
-
-(DEFUN |PARSE-Sexpr| ()
- (AND (ACTION (|advanceToken|)) (|PARSE-Sexpr1|)))
-
-
-(DEFUN |PARSE-Sexpr1| ()
- (OR (|parseInteger|)
- (|parseString|)
- (AND (|parseAnyId|)
- (OPTIONAL
- (AND (|PARSE-NBGliphTok| '=) (MUST (|PARSE-Sexpr1|))
- (ACTION (SETQ LABLASOC
- (CONS (CONS (|popStack2|)
- (|nthStack| 1))
- LABLASOC))))))
- (AND (|matchAdvanceString| "'") (MUST (|PARSE-Sexpr1|))
- (|pushReduction| '|PARSE-Sexpr1|
- (CONS 'QUOTE (CONS (|popStack1|) NIL))))
- ;; next form disabled -- gdr, 2009-06-15.
-; (AND (|matchAdvanceString| "-") (MUST (|parseInteger|))
-; (|pushReduction| '|PARSE-Sexpr1| (MINUS (|popStack1|))))
- (AND (|matchAdvanceString| "[")
- (BANG FIL_TEST (OPTIONAL (STAR REPEATOR (|PARSE-Sexpr1|))))
- (MUST (|matchAdvanceString| "]"))
- (|pushReduction| '|PARSE-Sexpr1| (LIST2VEC (|popStack1|))))
- (AND (|matchAdvanceString| "(")
- (BANG FIL_TEST
- (OPTIONAL
- (AND (STAR REPEATOR (|PARSE-Sexpr1|))
- (OPTIONAL
- (AND (|PARSE-GlyphTok| ".")
- (MUST (|PARSE-Sexpr1|))
- (|pushReduction| '|PARSE-Sexpr1|
- (|append!| (|popStack2|) (|popStack1|))))))))
- (MUST (|matchAdvanceString| ")")))))
-
-
-(DEFUN |PARSE-NBGliphTok| (|tok|)
- (DECLARE (SPECIAL |tok|))
- (AND (|matchCurrentToken| 'GLIPH |tok|) |$nonblank|
- (ACTION (|advanceToken|))))
-
-
-(DEFUN |PARSE-GlyphTok| (|tok|)
- (DECLARE (SPECIAL |tok|))
- (AND (|matchCurrentToken| 'GLIPH (INTERN |tok|))
- (ACTION (|advanceToken|))))
-
-(DEFUN |PARSE-Sequence| ()
- (OR (AND (|PARSE-OpenBracket|) (MUST (|PARSE-Sequence1|))
- (MUST (|matchAdvanceString| "]")))
- (AND (|PARSE-OpenBrace|) (MUST (|PARSE-Sequence1|))
- (MUST (|matchAdvanceString| "}"))
- (|pushReduction| '|PARSE-Sequence|
- (CONS '|brace| (CONS (|popStack1|) NIL))))))
-
-
-(DEFUN |PARSE-Sequence1| ()
- (AND (OR (AND (|PARSE-Expression|)
- (|pushReduction| '|PARSE-Sequence1|
- (CONS (|popStack2|) (CONS (|popStack1|) NIL))))
- (|pushReduction| '|PARSE-Sequence1| (CONS (|popStack1|) NIL)))
- (OPTIONAL
- (AND (|PARSE-IteratorTail|)
- (|pushReduction| '|PARSE-Sequence1|
- (CONS 'COLLECT
- (APPEND (|popStack1|)
- (CONS (|popStack1|) NIL))))))))
-
-
-(DEFUN |PARSE-OpenBracket| ()
- (LET ((G1 (|currentSymbol|)))
- (AND (EQ (|getToken| G1) '[)
- (MUST (OR (AND (EQCAR G1 '|elt|)
- (|pushReduction| '|PARSE-OpenBracket|
- (CONS '|elt|
- (CONS (CADR G1)
- (CONS '|construct| NIL)))))
- (|pushReduction| '|PARSE-OpenBracket| '|construct|)))
- (ACTION (|advanceToken|)))))
-
-
-(DEFUN |PARSE-OpenBrace| ()
- (LET ((G1 (|currentSymbol|)))
- (AND (EQ (|getToken| G1) '{)
- (MUST (OR (AND (EQCAR G1 '|elt|)
- (|pushReduction| '|PARSE-OpenBrace|
- (CONS '|elt|
- (CONS (CADR G1)
- (CONS '|brace| NIL)))))
- (|pushReduction| '|PARSE-OpenBrace| '|construct|)))
- (ACTION (|advanceToken|)))))
-
-
-(DEFUN |PARSE-IteratorTail| ()
- (OR (AND (MATCH-ADVANCE-KEYWORD "repeat")
- (BANG FIL_TEST
- (OPTIONAL (STAR REPEATOR (|PARSE-Iterator|)))))
- (STAR REPEATOR (|PARSE-Iterator|))))
-
diff --git a/src/interp/lexing.boot b/src/interp/lexing.boot
index d0f1c065..325aa513 100644
--- a/src/interp/lexing.boot
+++ b/src/interp/lexing.boot
@@ -188,8 +188,22 @@ tokenInstall(sym,typ,tok,nonblank == true) ==
tokenNonblank?(tok) := nonblank
tok
+getSpadToken tok ==
+ not skipBlankChars() => nil
+ tt := tokenLookaheadType currentChar()
+ tt is 'EOF => tokenInstall(nil,'_*EOF,tok,$nonblank)
+ tt is 'ESCAPE =>
+ advanceChar!()
+ getIdentifier(tok,true)
+ tt is 'ARGUMENT_-DESIGNATOR => GET_-ARGUMENT_-DESIGNATOR_-TOKEN tok
+ tt is 'ID => getIdentifier(tok,false)
+ tt is 'NUM => GET_-SPAD_-INTEGER_-TOKEN tok
+ tt is 'STRING => getSpadString tok
+ tt is 'SPECIAL_-CHAR => getSpecial tok
+ getGliph(tok,tt)
+
tryGetToken tok ==
- GET_-BOOT_-TOKEN tok =>
+ getSpadToken tok =>
$validTokens := $validTokens + 1
tok
nil
@@ -205,9 +219,10 @@ nextToken() ==
$validTokens > 1 => $nextToken
tryGetToken $nextToken
-matchToken(tok,typ,sym == false) ==
+matchToken(tok,typ,sym == nil) ==
tok ~= nil and symbolEq?(tokenType tok,typ) and
- (sym = nil or symbolEq?(sym,tokenSymbol tok)) and tok
+ (sym = nil or sym = tokenSymbol tok) => tok
+ nil
++ Return the current token if it has type `typ', and possibly the
++ same spelling as `sym'.
@@ -299,10 +314,10 @@ getGliph(tok,gliphs) ==
gliphs := rest gliphs
advanceChar!()
s := makeSymbol listToString reverse! buf
- return tokenInstall(property(s,'RENAMETOK) or s,'GLIPH,tok,$nonblank)
+ return tokenInstall(s,'GLIPH,tok,$nonblank)
Keywords == [
- "or", "and", "isnt", "is", "when", "where", "forall", "exist", "try",
+ "or", "and", "isnt", "is", "where", "forall", "exist", "try",
"has", "with", "add", "case", "in", "by", "pretend", "mod", "finally",
"exquo", "div", "quo", "else", "rem", "then", "suchthat", "catch", "throw",
"if", "iterate", "break", "from", "exit", "leave", "return",
@@ -409,6 +424,24 @@ matchAdvanceKeyword kwd ==
true
false
+matchKeywordNext kwd ==
+ matchToken(nextToken(),'KEYWORD,kwd)
+
+matchSpecial c ==
+ matchToken(currentToken(),'SPECIAL_-CHAR,c)
+
+matchAdvanceSpecial c ==
+ matchSpecial c =>
+ advanceToken()
+ true
+ false
+
+matchAdvanceGlyph s ==
+ matchToken(currentToken(),'GLIPH,s) =>
+ advanceToken()
+ true
+ false
+
--%
--% Stack abstract datatype.
--% Operational semantics:
diff --git a/src/interp/newaux.lisp b/src/interp/newaux.lisp
index 555c489c..3d668367 100644
--- a/src/interp/newaux.lisp
+++ b/src/interp/newaux.lisp
@@ -1,6 +1,6 @@
;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
;; All rights reserved.
-;; Copyright (C) 2007-2009, Gabriel Dos Reis.
+;; Copyright (C) 2007-2011, Gabriel Dos Reis.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
@@ -40,7 +40,6 @@
;
; 1. Led and Nud Tables
; 2. GLIPH Table
-; 3. RENAMETOK Table
; 4. GENERIC Table
; 5. Character syntax class predicates
@@ -106,7 +105,7 @@
(\@ 996 997) (|pretend| 995 996)
(\.) (\! \! 1002 1001)
(\, 110 111)
- (\; 81 82 (|PARSE-SemiColon|))
+ (\; 81 82 (|parseSemicolon|))
(< 400 400) (> 400 400)
(<< 400 400) (>> 400 400)
(<= 400 400) (>= 400 400)
@@ -122,7 +121,7 @@
(|is| 400 400) (|isnt| 400 400)
(|and| 250 251) (|or| 200 201)
(/\\ 250 251) (\\/ 200 201)
- (\.\. SEGMENT 401 699 (|PARSE-Seg|))
+ (\.\. SEGMENT 401 699 (|parseSegmentTail|))
(=> 123 103)
(+-> 998 121)
(== DEF 122 121)
@@ -131,14 +130,14 @@
(\:- LETD 125 124) (\:= %LET 125 124)))
(mapcar #'(LAMBDA (J) (MAKENEWOP J `|Nud|))
- '((|for| 130 350 (|PARSE-Loop|))
- (|while| 130 190 (|PARSE-Loop|))
- (|until| 130 190 (|PARSE-Loop|))
- (|repeat| 130 190 (|PARSE-Loop|))
- (|import| 120 0 (|PARSE-Import|) )
+ '((|for| 130 350 (|parseLoop|))
+ (|while| 130 190 (|parseLoop|))
+ (|until| 130 190 (|parseLoop|))
+ (|repeat| 130 190 (|parseLoop|))
+ (|import| 120 0 (|parseImport|) )
(|inline| 120 0 (|parseInline|) )
- (|forall| 998 999 (|PARSE-Scheme|))
- (|exist| 998 999 (|PARSE-Scheme|))
+ (|forall| 998 999 (|parseScheme|))
+ (|exist| 998 999 (|parseScheme|))
(|unless|)
(|add| 900 120)
(|with| 1000 300 (|parseWith|))
@@ -147,14 +146,14 @@
;; (\+ 701 700)
(\# 999 998)
(\! 1002 1001)
- (\' 999 999 (|PARSE-Data|))
+ (\' 999 999 (|parseData|))
(-> 1001 1002)
(\: 194 195)
(|not| 260 259 NIL)
(~ 260 259 nil)
(= 400 700)
(|return| 202 201 (|parseReturn|))
- (|try| 202 201 (|PARSE-Try|))
+ (|try| 202 201 (|parseTry|))
(|throw| 202 201 (|parseThrow|))
(|leave| 202 201 (|parseLeave|))
(|exit| 202 201 (|parseExit|))
@@ -162,45 +161,13 @@
(|iterate| 202 201 (|parseJump|))
(|from|)
(|yield|)
- (|if| 130 0 (|PARSE-Conditional|)) ; was 130
- (|case| 130 190 (|PARSE-Match|))
+ (|if| 130 0 (|parseConditional|)) ; was 130
+ (|case| 130 190 (|parseMatch|))
(\| 0 190)
(|suchthat|)
(|then| 0 114)
(|else| 0 114)))
-
-;; Gliphs are symbol clumps. The gliph property of a symbol gives
-;; the tree describing the tokens which begin with that symbol.
-;; The token reader uses the gliph property to determine the longest token.
-;; Thus `:=' is read as one token not as `:' followed by `='.
-
-(mapcar #'(lambda (x) (makeprop (car x) 'gliph (cdr x)))
- `(
- ( \| (\)) (]) )
- ( * (*) )
- ( \( (\|) )
- ( + (- (>)) )
- ( - (>) )
- ( < (=) (<) )
- ( / (\\) )
- ( \\ (/) )
- ( > (=) (>) )
- ( = (= (>)) (>) )
- ( \. (\.) )
- ( ^ (=) )
- ( \~ (=) )
- ( [ (\|) )
- ( \: (=) (-) (\:))))
-
-;; GENERIC operators be suffixed by `$' qualifications in SPAD code.
-;; `$' is then followed by a domain label, such as I for Integer, which
-;; signifies which domain the operator refers to. For example `+$Integer'
-;; is `+' for Integers.
-
-(mapcar #'(lambda (x) (MAKEPROP X 'GENERIC 'TRUE))
- '(- = * |rem| |mod| |quo| |div| / ** |exquo| + - < > <= >= ~= ))
-
(defun SPECIALCASESYNTAX () (OR (AND (char= TOK '#\#) (DIGITP CHR))))
(defun TERMINATOR (CHR)
diff --git a/src/interp/parse.boot b/src/interp/parse.boot
index 1af246df..9f30064d 100644
--- a/src/interp/parse.boot
+++ b/src/interp/parse.boot
@@ -237,9 +237,9 @@ parseTranCheckForRecord(x,op) ==
x
x
-parseCategory: %ParseForm -> %Form
-parseCategory t ==
- t isnt ["CATEGORY",:x] => systemErrorHere ["parseCategory",t]
+doParseCategory: %ParseForm -> %Form
+doParseCategory t ==
+ t isnt ["CATEGORY",:x] => systemErrorHere ["doParseCategory",t]
$parsingType: local := true
l := parseTranList x
key :=
@@ -445,7 +445,7 @@ for x in [[":", :"parseColon"],_
["::", :"parseCoerce"],_
["@", :"parseAtSign"],_
["and", :"parseAnd"],_
- ["CATEGORY", :"parseCategory"],_
+ ["CATEGORY", :"doParseCategory"],_
["construct", :"parseConstruct"],_
["DEF", :"parseDEF"],_
["exit", :"doParseExit"],_
diff --git a/src/interp/parsing.lisp b/src/interp/parsing.lisp
index 668bf1e3..ce5a2826 100644
--- a/src/interp/parsing.lisp
+++ b/src/interp/parsing.lisp
@@ -295,10 +295,6 @@ the stack, then stack a NIL. Return the value of prod."
; (3) Line handling: Next Line, Print Next Line
; (X) Random Stuff
-(defun match-advance-keyword (str)
- (and (|matchToken| (|currentToken|) 'keyword (intern str))
- (action (|advanceToken|))))
-
(defun match-advance-special (str)
(and (|matchToken| (|currentToken|) 'special-char (character str))
(action (|advanceToken|))))
diff --git a/src/interp/preparse.lisp b/src/interp/preparse.lisp
index 47acccb4..aff89033 100644
--- a/src/interp/preparse.lisp
+++ b/src/interp/preparse.lisp
@@ -57,7 +57,7 @@
-(IMPORT-MODULE "fnewmeta")
+(IMPORT-MODULE "parsing")
(in-package "BOOT")
@@ -70,29 +70,14 @@
(defparameter $EchoLineStack nil "Stack of lines to list.")
(defparameter $IOIndex 0 "Number of latest terminal input line.")
+(DEFPARAMETER TOK NIL)
+(DEFPARAMETER DEFINITION_NAME NIL)
+(DEFPARAMETER LABLASOC NIL)
+
(defun Initialize-Preparse (strm)
(setq $INDEX 0 $LineList nil $EchoLineStack nil)
(setq $preparse-last-line (get-a-line strm)))
-(defmacro pptest () `(/rp ">scratchpad>test.boot"))
-
-(defun /RP (&optional (*boot-input-file* nil) (*boot-output-file* nil)
- ($preparseReportIfTrue t))
- (with-open-stream
- (in-stream (or (and *boot-input-file*
- (open *boot-input-file* :direction :input))
- |$InputStream|))
- (declare (special in-stream))
- (with-open-stream
- (out-stream (if *boot-output-file*
- (open *boot-output-file* :direction :output)
- |$OutputStream|))
- (declare (special out-stream))
- (initialize-preparse in-stream)
- (do ((lines (PREPARSE in-stream) (PREPARSE in-stream))) ((null lines)))))
- T)
-
-
(defvar $skipme)
(defun PREPARSE (Strm &aux (stack ()))
diff --git a/src/interp/spad-parser.boot b/src/interp/spad-parser.boot
index a7780674..43e04256 100644
--- a/src/interp/spad-parser.boot
+++ b/src/interp/spad-parser.boot
@@ -42,15 +42,26 @@
-- -- gdr/2007-11-02
--
-import parsing
+import preparse
import parse
-import fnewmeta
namespace BOOT
--%
macro compulsorySyntax s ==
s or SPAD__SYNTAX__ERROR()
+repeatedSyntax(l,p) ==
+ n := stackSize $reduceStack
+ once := false
+ while apply(p,nil) repeat
+ once := true
+ not once => nil
+ x := nil
+ for i in (n+1)..stackSize $reduceStack repeat
+ x := [popStack1(),:x]
+ x = nil => true
+ pushReduction(l,x)
+
--%
parseToken tt ==
@@ -60,14 +71,77 @@ parseToken tt ==
true
false
+parseGlyph s ==
+ matchCurrentToken('GLIPH,s) =>
+ advanceToken()
+ true
+ false
+
+parseNBGlyph tok ==
+ matchCurrentToken('GLIPH,tok) and $nonblank =>
+ advanceToken()
+ true
+ false
+
parseString() ==
parseToken 'SPADSTRING
parseInteger() ==
parseToken 'NUMBER
+parseFloatBasePart() ==
+ matchAdvanceGlyph "." =>
+ $nonblank and (t := matchCurrentToken 'NUMBER) =>
+ t := copyToken t
+ advanceToken()
+ pushReduction('parseFloatBasePart,tokenNonblank? t)
+ pushReduction('parseFloatBasePart,tokenSymbol t)
+ pushReduction('parseFloatBasePart,0)
+ pushReduction('parseFloatBasePart,0)
+ nil
+
+parseFloatBase() ==
+ integer? currentSymbol() and currentChar() = char "." and
+ nextChar() ~= char "." and parseInteger() =>
+ compulsorySyntax parseFloatBasePart()
+ integer? currentSymbol() and charUpcase currentChar() = char "E"
+ and parseInteger() =>
+ pushReduction('parseBase,0)
+ pushReduction('parseBase,0)
+ digit? currentChar() and currentSymbol() is "." =>
+ pushReduction('parseBase,0)
+ pushReduction('parseBase,0)
+ nil
+
+parseFloatExponent() ==
+ not ident? currentSymbol() => nil
+ symbolMember?(currentSymbol(),'(e E)) and
+ charMember?(currentChar(),[char "+",char "-"]) =>
+ advanceToken()
+ parseInteger() => true
+ matchAdvanceGlyph "+" => compulsorySyntax parseInteger()
+ matchAdvanceGlyph "-" =>
+ compulsorySyntax parseInteger()
+ pushReduction('parseFloatExponent,-popStack1())
+ pushReduction('parseFloatExponent,0)
+ g := FLOATEXPID currentSymbol() =>
+ advanceToken()
+ pushReduction('parseFloatExponent,g)
+ nil
+
+parseFloat() ==
+ parseFloatBase() =>
+ $nonblank and parseFloatExponent()
+ or pushReduction('parseFloat,0)
+ pushReduction('parseFloat,
+ MAKE_-FLOAT(popStack4(),popStack2(),popStack2(),popStack1()))
+ nil
+
parseName() ==
parseToken 'IDENTIFIER and pushReduction('parseName,popStack1())
+
+parseKeyword() ==
+ parseToken 'KEYWORD and pushReduction('parseKeyword,popStack1())
parseFormalParameter() ==
parseToken 'ARGUMENT_-DESIGNATOR
@@ -84,6 +158,7 @@ parseOperatorFunctionName() ==
parseAnyId() ==
parseName() => true
+ parseKeyword() => true
matchString '"$" =>
pushReduction('parseAnyId,currentSymbol())
advanceToken()
@@ -93,8 +168,26 @@ parseAnyId() ==
parseQuad() ==
matchAdvanceString '"$" and pushReduction('parseQuad,"$")
+parsePrimary1() ==
+ parseName() =>
+ $nonblank and currentSymbol() is "(" =>
+ compulsorySyntax parsePrimary1()
+ pushReduction('parsePrimary1,[popStack2(),popStack1()])
+ true
+ parseQuad() or parseString() or parseInteger() or
+ parseFormalParameter() => true
+ matchSpecial char "'" =>
+ compulsorySyntax parseData()
+ pushReduction('parsePrimary1,popStack1())
+ parseSequence() or parseEnclosure()
+
+parsePrimaryNoFloat() ==
+ parsePrimary1() =>
+ parseTokenTail() or true
+ false
+
parsePrimary() ==
- PARSE_-Float() or PARSE_-PrimaryNoFloat()
+ parseFloat() or parsePrimaryNoFloat()
parsePrimaryOrQM() ==
matchAdvanceString '"?" => pushReduction('parsePrimaryOrQM,"?")
@@ -105,8 +198,46 @@ parseSpecialKeyWord() ==
tokenSymbol(currentToken()) := unAbbreviateKeyword currentSymbol()
nil
+parseSexpr1() ==
+ parseInteger() or parseString() => true
+ parseAnyId() =>
+ parseNBGlyph "=" =>
+ compulsorySyntax parseSexpr1()
+ SETQ(LABLASOC,[[popStack2(),:nthStack 1],:LABLASOC])
+ true
+ true
+ matchAdvanceSpecial char "'" =>
+ compulsorySyntax parseSexpr1()
+ pushReduction('parseSexpr1,["QUOTE",popStack1()])
+ matchAdvanceGlyph "[" =>
+ stackUpdated?($reduceStack) := false
+ repeatedSyntax('parseSexpr1,function PARSE_-Sexpr1)
+ if not stackUpdated? $reduceStack then
+ pushReduction('parseSexpr1,nil)
+ compulsorySyntax matchAdvanceGlyph "]"
+ pushReduction('parseSexpr1,LIST2VEC popStack1())
+ matchAdvanceGlyph "(" =>
+ stackUpdated?($reduceStack) := false
+ repeatedSyntax('parseSexpr1,function PARSE_-Sexpr1)
+ if parseGlyph "." then
+ compulsorySyntax parseSexpr1()
+ pushReduction('parseSexpr1,append!(popStack2(),popStack1()))
+ if not stackUpdated? $reduceStack then
+ pushReduction('parseSexpr1,nil)
+ compulsorySyntax matchAdvanceGlyph ")"
+ nil
+
+parseSexpr() ==
+ advanceToken()
+ parseSexpr1()
+
+parseData() ==
+ SETQ(LABLASOC,nil)
+ parseSexpr() and
+ pushReduction('parseData,["QUOTE",TRANSLABEL(popStack1(),LABLASOC)])
+
parseCommand() ==
- matchAdvanceString '")" =>
+ matchAdvanceString '")" => --FIXME: remove matchAdvanceString
compulsorySyntax parseSpecialKeyWord()
compulsorySyntax parseSpecialCommand()
pushReduction('parseStatement,nil)
@@ -117,7 +248,7 @@ parseTokenOption() ==
parseQualification() ==
matchAdvanceString '"$" =>
- compulsorySyntax PARSE_-Primary1()
+ compulsorySyntax parsePrimary1()
pushReduction('parseQualification,dollarTran(popStack1(),popStack1()))
nil
@@ -130,23 +261,137 @@ parseTokenTail() ==
$priorToken := tok
nil
+parseSelector() ==
+ $nonblank and currentSymbol() is "." and currentChar() ~= char " "
+ and matchAdvanceGlyph "." =>
+ compulsorySyntax parsePrimaryNoFloat()
+ pushReduction('parseSelector,[popStack2(),popStack1()])
+ parseFloat()
+ or matchAdvanceGlyph "." and compulsorySyntax parsePrimary() =>
+ pushReduction('parseSelector,[popStack2(),popStack1()])
+ nil
+
+parseApplication() ==
+ parsePrimary() =>
+ repeatedSyntax('selectors,function parseSelector)
+ parseApplication() and
+ pushReduction('parseApplication,[popStack2(),popStack1()])
+ true
+ nil
+
+parseOperation($ParseMode,rbp) ==
+ matchCurrentToken 'IDENTIFIER => nil
+ s := currentSymbol()
+ not symbol? s or property(s,$ParseMode) = nil => nil
+ rbp >= parseLeftBindingPowerOf(s,$ParseMode) => nil
+ parseGetSemanticForm(s,$ParseMode,ELEMN(property(s,$ParseMode),5,nil))
+
+parseLedPart rbp ==
+ parseOperation('Led,rbp) and
+ pushReduction('parseLedPart,popStack1())
+
+parseNudPart rbp ==
+ parseOperation('Nud,rbp) or parseReduction() or parseForm() =>
+ pushReduction('parseNudPart,popStack1())
+
+parseExpr rbp ==
+ parseNudPart rbp =>
+ repeatedSyntax('parseExpr,function(() +-> parseLedPart rbp))
+ pushReduction('parseExpr,popStack1())
+ nil
+
parseInfix() ==
pushReduction('parseInfix,currentSymbol())
advanceToken()
parseTokenTail()
- compulsorySyntax PARSE_-Expression()
+ compulsorySyntax parseExpression()
pushReduction('parseInfix,[popStack2(),popStack2(),popStack1()])
parsePrefix() ==
pushReduction('parsePrefix,currentSymbol())
advanceToken()
parseTokenTail()
- compulsorySyntax PARSE_-Expression()
+ compulsorySyntax parseExpression()
pushReduction('parsePrefix,[popStack2(),popStack1()])
+parseLeftBindingPowerOf(x,p) ==
+ y := property(x,p) => ELEMN(y,3,0)
+ 0
+
+parseRightBindingPowerOf(x,p) ==
+ y := property(x,p) => ELEMN(y,4,105)
+ 105
+
+parseGetSemanticForm(x,p,y) ==
+ z := EVAL y => z -- FIXME get rid of EVAL.
+ p = "Nud" => parsePrefix()
+ p = "Led" => parseInfix()
+ nil
+
+parseExpression() ==
+ parseExpr parseRightBindingPowerOf(makeSymbolOf $priorToken,$ParseMode)
+ and pushReduction('parseExpression,popStack1())
+
+parseSegmentTail() ==
+ parseGlyph ".." =>
+ stackUpdated?($reduceStack) := false
+ parseExpression()
+ if not stackUpdated? $reduceStack then
+ pushReduction('segmentTail,nil)
+ pushReduction('parseSegmentTail,["SEGMENT",popStack2(),popStack1()])
+ nil
+
+parseReductionOp() ==
+ s := currentSymbol()
+ if string? s then
+ s := makeSymbol s -- FIXME: abolish string-quoted operators
+ ident? s and property(s,'Led) and matchNextToken('GLIPH,"/") =>
+ pushReduction('parseReductionOp,s)
+ advanceToken()
+ advanceToken()
+ true
+ false
+
+parseReduction() ==
+ parseReductionOp() =>
+ compulsorySyntax parseExpr 1000
+ pushReduction('parseReduction,["%Reduce",popStack2(),popStack1()])
+ nil
+
+parseCategory() ==
+ matchAdvanceKeyword "if" =>
+ compulsorySyntax parseExpression()
+ compulsorySyntax matchAdvanceKeyword "then"
+ compulsorySyntax parseCategory()
+ stackUpdated?($reduceStack) := false
+ matchAdvanceKeyword "else" and compulsorySyntax parseCategory()
+ if not stackUpdated? $reduceStack then
+ pushReduction('alternateCategory,nil)
+ pushReduction('parseCategory,["if",popStack3(),popStack2(),popStack1()])
+ matchAdvanceGlyph "(" =>
+ compulsorySyntax parseCategory()
+ stackUpdated?($reduceStack) := false
+ repeatedSyntax('unnamedCategory,function(() +->
+ matchAdvanceSpecial char ";" and compulsorySyntax parseCategory()))
+ if not stackUpdated? $reduceStack then
+ pushReduction('unnamedCategory,nil)
+ compulsorySyntax matchAdvanceSpecial char ")"
+ pushReduction('parseCategory,["CATEGORY",popStack2(),:popStack1()])
+ g := lineNumber $spadLine
+ parseApplication() or parseOperatorFunctionName() =>
+ matchAdvanceGlyph ":" =>
+ compulsorySyntax parseExpression()
+ pushReduction('parseCategory,["%Signature",popStack2(),popStack1()])
+ recordSignatureDocumentation(nthStack 1,g)
+ true
+ pushReduction('parseCategory,["%Attribute",popStack1()])
+ recordAttributeDocumentation(nthStack 1,g)
+ true
+ nil
+
parseWith() ==
matchAdvanceKeyword "with" =>
- compulsorySyntax PARSE_-Category()
+ compulsorySyntax parseCategory()
pushReduction('parseWith,["with",popStack1()])
nil
@@ -155,17 +400,8 @@ parseInfixWith() ==
pushReduction('parseInfixWith,["Join",popStack2(),popStack1()])
parseElseClause() ==
- currentSymbol() is "if" => PARSE_-Conditional()
- PARSE_-Expression()
-
-++ 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
+ currentSymbol() is "if" => parseConditional()
+ parseExpression()
parseQuantifier() ==
matchAdvanceKeyword "forall" =>
@@ -176,28 +412,68 @@ parseQuantifier() ==
parseQuantifiedVariable() ==
parseName() =>
- compulsorySyntax matchAdvanceString '":"
- compulsorySyntax PARSE_-Application()
+ compulsorySyntax matchAdvanceGlyph ":"
+ compulsorySyntax parseApplication()
pushReduction('parseQuantifiedVariable,[":",popStack2(),popStack1()])
nil
+parseQuantifiedVariableList() ==
+ matchAdvanceGlyph "(" =>
+ compulsorySyntax parseQuantifiedVariable()
+ repeatedSyntax('repeatedVars,function(() +->
+ matchAdvanceSpecial char "," and parseQuantifiedVariable()))
+ and pushReduction('parseQuantifiedVariableList,
+ ["%Sequence",popStack2(),:popStack1()])
+ compulsorySyntax matchAdvanceSpecial char ")"
+ nil
+
+++ quantified types. At the moment, these are used only in
+++ pattern-mathing cases.
+++ -- gdr, 2009-06-14.
+parseScheme() ==
+ parseQuantifier() =>
+ compulsorySyntax parseQuantifiedVariableList()
+ compulsorySyntax matchAdvanceGlyph "."
+ compulsorySyntax parseExpr 200
+ pushReduction('parseScheme,[popStack3(),popStack2(),popStack1()])
+ parseApplication()
+
+parseConditional() ==
+ matchAdvanceKeyword "if" =>
+ compulsorySyntax parseExpression()
+ compulsorySyntax matchAdvanceKeyword "then"
+ compulsorySyntax parseExpression()
+ stackUpdated?($reduceStack) := false
+ if matchAdvanceKeyword "else" then
+ parseElseClause()
+ if not stackUpdated? $reduceStack then
+ pushReduction('elseBranch,nil)
+ pushReduction('parseConditional,["if",popStack3(),popStack2(),popStack1()])
+ nil
+
+parseSemicolon() ==
+ matchAdvanceSpecial char ";" =>
+ parseExpr 82 or pushReduction('parseSemicolon,"/throwAway")
+ pushReduction('parseSemicolon,[";",popStack2(),popStack1()])
+ nil
+
++ We should factorize these boilerplates
parseReturn() ==
matchAdvanceKeyword "return" =>
- compulsorySyntax PARSE_-Expression()
+ compulsorySyntax parseExpression()
pushReduction('parseReturn,["return",popStack1()])
nil
parseThrow() ==
matchAdvanceKeyword "throw" =>
- compulsorySyntax PARSE_-Expression()
+ compulsorySyntax parseExpression()
pushReduction('parseReturn,["%Throw",popStack1()])
nil
parseExit() ==
matchAdvanceKeyword "exit" =>
x :=
- PARSE_-Expression() => popStack1()
+ parseExpression() => popStack1()
"$NoValue"
pushReduction('parseExit,["exit",x])
nil
@@ -205,7 +481,7 @@ parseExit() ==
parseLeave() ==
matchAdvanceKeyword "leave" =>
x :=
- PARSE_-Expression() => popStack1()
+ parseExpression() => popStack1()
"$NoValue"
pushReduction('parseLeave,["leave",x])
nil
@@ -216,12 +492,256 @@ parseJump() ==
pushReduction('parseJump,s)
nil
+parseForm() ==
+ matchAdvanceKeyword "iterate" =>
+ pushReduction('parseForm,["iterate"])
+ matchAdvanceKeyword "yield" =>
+ compulsorySyntax parseApplication()
+ pushReduction('parseForm,["yield",popStack1()])
+ parseApplication()
+
+parseVariable() ==
+ parseName() =>
+ matchAdvanceGlyph ":" =>
+ compulsorySyntax parseApplication()
+ pushReduction('parseVariable,[":",popStack2(),popStack1()])
+ true
+ parsePrimary()
+
+parseIterator() ==
+ matchAdvanceKeyword "for" =>
+ compulsorySyntax parseVariable()
+ compulsorySyntax matchAdvanceKeyword "in"
+ compulsorySyntax parseExpression()
+ matchAdvanceKeyword "by" and compulsorySyntax parseExpr 200 and
+ pushReduction('parseIterator,["INBY",popStack3(),popStack2(),popStack1()])
+ or pushReduction('parseIterator,["IN",popStack2(),popStack1()])
+ matchAdvanceGlyph "|" and compulsorySyntax parseExpr 111 and
+ pushReduction('parseIterator,["|",popStack1()])
+ true
+ matchAdvanceKeyword "while" =>
+ compulsorySyntax parseExpr 190
+ pushReduction('parseIterator,["WHILE",popStack1()])
+ matchAdvanceKeyword "until" =>
+ compulsorySyntax parseExpr 190
+ pushReduction('parseIterator,["UNTIL",popStack1()])
+ nil
+
+parseIteratorTails() ==
+ matchAdvanceKeyword "repeat" =>
+ stackUpdated?($reduceStack) := false
+ repeatedSyntax('parseIteratorTails,function parseIterator)
+ if not stackUpdated? $reduceStack then
+ pushReduction('crossIterators,nil)
+ repeatedSyntax('parseIteratorTails,function parseIterator)
+
+parseLoop() ==
+ repeatedSyntax('iterators,function parseIterator) =>
+ compulsorySyntax matchAdvanceKeyword "repeat"
+ compulsorySyntax parseExpr 110
+ pushReduction('parseLoop,["REPEAT",:popStack2(),popStack1()])
+ matchAdvanceKeyword "repeat" =>
+ compulsorySyntax parseExpr 110
+ pushReduction('parseLoop,["REPEAT",popStack1()])
+ nil
+
+parseOpenBracket() ==
+ s := currentSymbol()
+ getToken s is "[" =>
+ do
+ s is ["elt",:.] =>
+ pushReduction('parseOpenBracket,["elt",second s,"construct"])
+ pushReduction('parseOpenBracket,"construct")
+ advanceToken()
+ true
+ false
+
+parseOpenBrace() ==
+ s := currentSymbol()
+ getToken s is "{" =>
+ do
+ s is ["elt",:.] =>
+ pushReduction('parseOpenBracket,["elt",second s,"brace"])
+ pushReduction('parseOpenBracket,"construct") --FIXME: should be brace
+ advanceToken()
+ true
+ false
+
+parseSequence1() ==
+ do
+ parseExpression() =>
+ pushReduction('parseSequence1,[popStack2(),popStack1()])
+ pushReduction('parseSequence1,[popStack1()])
+ parseIteratorTails() and
+ pushReduction('parseSequence1,["COLLECT",:popStack1(),popStack1()])
+ true
+
+parseSequence() ==
+ parseOpenBracket() =>
+ compulsorySyntax parseSequence1()
+ compulsorySyntax matchAdvanceSpecial char "]"
+ parseOpenBrace() =>
+ compulsorySyntax parseSequence1()
+ compulsorySyntax matchAdvanceSpecial char "}"
+ pushReduction('parseSequence,["brace",popStack1()])
+ nil
+
+parseEnclosure() ==
+ matchAdvanceGlyph "(" =>
+ parseExpr 6 =>
+ compulsorySyntax matchAdvanceSpecial char ")"
+ matchAdvanceSpecial char ")" =>
+ pushReduction('parseEnclosure,["%Comma"])
+ SPAD__SYNTAX__ERROR()
+ matchAdvanceGlyph "{" =>
+ parseExpr 6 =>
+ compulsorySyntax matchAdvanceSpecial char "}"
+ pushReduction('parseEnclosure,["brace",["construct",popStack1()]])
+ matchAdvanceSpecial char "}" =>
+ pushReduction('parseEnclosure,["brace"])
+ SPAD__SYNTAX__ERROR()
+ matchAdvanceGlyph "[|" =>
+ parseStatement() =>
+ compulsorySyntax matchAdvanceGlyph "|]"
+ pushReduction('parseEnclosure,["[||]",popStack1()])
+ SPAD__SYNTAX__ERROR()
+ nil
+
+parseCatch() ==
+ matchSpecial char ";" and matchKeywordNext "catch" =>
+ advanceToken()
+ advanceToken()
+ compulsorySyntax parseGlyph "("
+ compulsorySyntax parseQuantifiedVariable()
+ compulsorySyntax matchAdvanceSpecial char ")"
+ compulsorySyntax parseGlyph "=>"
+ compulsorySyntax parseExpression()
+ pushReduction('parseCatch,[popStack2(),popStack1()])
+ nil
+
+parseFinally() ==
+ matchSpecial char ";" and matchKeywordNext "finally" =>
+ advanceToken()
+ advanceToken()
+ compulsorySyntax parseExpression()
+ nil
+
+parseTry() ==
+ matchAdvanceKeyword "try" =>
+ compulsorySyntax parseExpression()
+ -- exception handlers: either a finally-expression, or
+ -- a series of catch-expressions optionally followed by
+ -- a finally-expression.
+ parseFinally() =>
+ pushReduction('parseTry,["%Try",popStack2(),nil,popStack1()])
+ compulsorySyntax repeatedSyntax('handlers,function parseCatch) =>
+ stackUpdated?($reduceStack) := false
+ parseFinally()
+ if not stackUpdated? $reduceStack then
+ pushReduction('finalizer,nil)
+ pushReduction('parseTry,["%Try",popStack3(),popStack2(),popStack1()])
+ SPAD__SYNTAX__ERROR()
+ nil
+
+parseMatch() ==
+ matchAdvanceKeyword "case" =>
+ compulsorySyntax parseExpr 400
+ compulsorySyntax matchAdvanceKeyword "is"
+ compulsorySyntax parseExpr 110
+ pushReduction('parseMatch,["%Match",popStack2(),popStack1()])
+ nil
+
+++ 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 parseExpr 1000
+ pushReduction('parseInline,["%Inline",popStack1()])
+ nil
+
+parseImport() ==
+ matchAdvanceKeyword "import" =>
+ compulsorySyntax parseExpr 1000
+ matchAdvanceGlyph ":" =>
+ compulsorySyntax parseExpression()
+ compulsorySyntax matchAdvanceKeyword "from"
+ compulsorySyntax parseExpr 1000
+ pushReduction('parseImport,
+ ["%SignatureImport",popStack3(),popStack2(),popStack1()])
+ stackUpdated?($reduceStack) := false
+ repeatedSyntax('imports,function(() +-> matchAdvanceSpecial char ","
+ and compulsorySyntax parseExpr 1000))
+ if not stackUpdated? $reduceStack then
+ pushReduction('imports,nil)
+ pushReduction('parseImport,["import",popStack2(),:popStack1()])
+ nil
+
+parseStatement() ==
+ parseExpr 0 =>
+ repeatedSyntax('statements,function(() +-> matchAdvanceGlyph ","
+ and compulsorySyntax parseExpr 0)) =>
+ pushReduction('parseStatement,["Series",popStack2(),:popStack1()])
+ true
+ false
+
parseNewExpr() ==
matchString '")" =>
processSynonyms()
compulsorySyntax parseCommand()
SETQ(DEFINITION__NAME,currentSymbol())
- PARSE_-Statement()
+ parseStatement()
+
+--%
+
+isTokenDelimiter() ==
+ symbolMember?(currentSymbol(),[")","END__UNIT","NIL"])
+
+parseTokenList() ==
+ repeatedSyntax('tokenList,function(() +->
+ (isTokenDelimiter() => nil; pushReduction('parseTokenList,currentSymbol());
+ advanceToken(); true)))
+
+parseCommandTail() ==
+ stackUpdated?($reduceStack) := false
+ repeatedSyntax('options,function parseTokenOption)
+ if not stackUpdated? $reduceStack then
+ pushReduction('options,nil)
+ atEndOfLine() and
+ pushReduction('parseCommandTail,[popStack2(),:popStack1()])
+ systemCommand popStack1()
+ true
+
+parseOption() ==
+ matchAdvanceString '")" => --FIXME: kill matchAdvanceString
+ compulsorySyntax repeatedSyntax('options,function parsePrimaryOrQM)
+
+parseTokenCommandTail() ==
+ stackUpdated?($reduceStack) := false
+ repeatedSyntax('options,function parseOption)
+ if not stackUpdated? $reduceStack then
+ pushReduction('options,nil)
+ atEndOfLine() and
+ pushReduction('parseCommandTail,[popStack2(),:popStack1()])
+ systemCommand popStack1()
+ true
+
+parseSpecialCommand() ==
+ matchAdvanceString '"show" => --FIXME: kill matchAdvanceString
+ stackUpdated?($reduceStack) := true
+ repeatedSyntax('commands,function(() +-> matchAdvanceString '"?"
+ or parseExpression()))
+ if not stackUpdated? $reduceStack then
+ pushReduction('commdnds,nil)
+ pushReduction('parseSpecialCommand,["show",popStack1()])
+ compulsorySyntax parseCommandTail()
+ symbolMember?(currentSymbol(),$noParseCommands) =>
+ apply(currentSymbol(),nil)
+ true
+ symbolMember?(currentSymbol(),$tokenCommands) and parseTokenList() =>
+ compulsorySyntax parseTokenCommandTail()
+ repeatedSyntax('parseSpecialCommand,function parsePrimaryOrQM) and
+ compulsorySyntax parseCommandTail()
--%
@@ -267,3 +787,35 @@ parseSpadFile sourceFile ==
-- we accumulated the parse trees in reverse order
reverse! asts
+--%
+
+++ Gliphs are symbol clumps. The gliph property of a symbol gives
+++ the tree describing the tokens which begin with that symbol.
+++ The token reader uses the gliph property to determine the longest token.
+++ Thus `:=' is read as one token not as `:' followed by `='.
+for x in [
+ ["|", [")"], ["]"]],_
+ ["*", ["*"]],_
+ ["(", ["|"]],_
+ ["+", ["-", [">"]]],_
+ ["-", [">"]],_
+ ["<", ["="], ["<"]],
+ ["/", ["\"]],_
+ ["\", ["/"]],_
+ [">", ["="], [">"]],_
+ ["=", ["=", [">"]] ,[">"]],_
+ [".", ["."]],_
+ ["^", ["="]],_
+ ["~", ["="]],_
+ ["[", ["|"]],_
+ [":", ["="], ["-"], [":"]]_
+ ] repeat
+ property(first x,'GLIPH) := rest x
+
+++ Generic infix operators
+for x in ["-", "=", "*", "rem", "mod", "quo", "div", "/", "^",
+ "**", "exquo", "+", "-", "<", ">", "<=", ">=", "~=",
+ "and", "or", "/\", "\/", "<<", ">>"] _
+ repeat
+ property(x,'GENERIC) := true
+
diff --git a/src/interp/spad.lisp b/src/interp/spad.lisp
index 2b883cae..fc517d67 100644
--- a/src/interp/spad.lisp
+++ b/src/interp/spad.lisp
@@ -42,7 +42,6 @@
;;; Common Block
-(defvar |$preserveSystemLisplib| t "if nil finalizeLisplib does MA REP")
(defvar |$reportInstantiations| nil)
(defvar |$reportEachInstantiation| nil)
(defvar |$reportCounts| nil)
@@ -55,13 +54,10 @@
(defvar |$algebraFormat| t "produce 2-d algebra output")
(defvar |$HiFiAccess| nil "if true maintain history file")
-(defvar |boot-NewKEY| NIL)
-
(DEFVAR _ '&)
(defvar /EDIT-FM 'A1)
(defvar /EDIT-FT 'SPAD)
(defvar /RELEASE '"UNKNOWN")
-(defvar /rp '/RP)
(defvar error-print)
(defvar ind)
(defvar INITCOLUMN 0)
@@ -69,18 +65,14 @@
(defvar m-chrbuffer)
(defvar m-chrindex)
(defvar MARG 0 "Margin for testing by ?OP")
-(defvar NewFlag)
-(defvar ParseMode)
(defvar RLGENSYMFG NIL)
(defvar RLGENSYMLST NIL)
(defvar S-SPADTOK 'SPADSYSTOK)
(defvar sortpred)
(defvar SPADSYSKEY '(EOI EOL))
(defvar STAKCOLUMN -1)
-(defvar xtrans '|boot-new|)
(defvar |$IOAlist| '((|%i| . (|gauss| 0 1))))
(defvar |InteractiveMode|)
-(defvar |NewFLAG| t)
(defvar |uc| 'UC)
(DEFUN INTEGER-BIT (N I) (LOGBITP I N))
@@ -181,7 +173,6 @@
(COND
(Q (/RQ))
('T (/RF)) )
- (FLAG |boot-NewKEY| 'KEY)
(|terminateSystemCommand|))
(defun /EDIT (L)
@@ -263,17 +254,14 @@
(S-PROCESS x))))
(defun |New,ENTRY,1| ()
- (let (ZZ str N RLGENSYMFG RLGENSYMLST |NewFLAG|
+ (let (ZZ str N RLGENSYMFG RLGENSYMLST
SINGLELINEMODE OK ISID NBLNK COUNT CHR ULCASEFG ($LINESTACK 'BEGIN_UNIT)
- $TOKSTACK COMMENTCHR TOK LINE BACK INPUTSTREAM XTRANS
+ $TOKSTACK COMMENTCHR TOK LINE BACK INPUTSTREAM
STACK STACKX TRAPFLAG)
- (SETQ XTRANS '|boot-New|)
- (FLAG |boot-NewKEY| 'KEY)
(PROMPT)
(SETQ COMMENTCHR 'IGNORE)
(SETQ INITCOLUMN 0)
(SETQ SINGLELINEMODE T) ; SEE NewSYSTOK
- (SETQ NewFLAG T)
(SETQ ULCASEFG T)
(setq STR (|New,ENTRY,2| '|PARSE-NewEXPR| '|process| |$InputStream|))
(if (/= 0 (setq N (NOTE STR)))
@@ -286,7 +274,6 @@
(INITIALIZE)
(SETQ |$previousTime| (TEMPUS-FUGIT))
(setq ZZ (CONVERSATION '|PARSE-NewExpr| '|process|))
- (REMFLAG |boot-NewKEY| 'KEY)
INPUTSTREAM))
(defun INITIALIZE ()
diff --git a/src/interp/sys-constants.boot b/src/interp/sys-constants.boot
index 2aefc81d..8349e810 100644
--- a/src/interp/sys-constants.boot
+++ b/src/interp/sys-constants.boot
@@ -700,7 +700,7 @@ $defaultOptimizationLevel == 2
$OperatorFunctionNames ==
["**", "^", "*", "/", "rem", "quo", "mod", "div", "exquo",
"+", "-", ">", ">=", "=", "~=", "<", "<=", "#", "~", "not",
- "case", "and", "or", "<<", ">>", "/\", "\/" ]
+ "case", "and", "or", "<<", ">>", "/\", "\/", "..", "by" ]
--%
%categoryKind == 'category
diff --git a/src/lisp/core.lisp.in b/src/lisp/core.lisp.in
index 7bdf5d13..a7f244d8 100644
--- a/src/lisp/core.lisp.in
+++ b/src/lisp/core.lisp.in
@@ -86,6 +86,8 @@
"tableValue" ; value associated with a key in a table
"tableLength" ; number of entries in the table.
"tableRemove!" ; remove an entry from a table
+ "ref"
+ "deref"
;; IO
"$InputStream"
@@ -494,6 +496,13 @@
(defmacro |tableLength| (ht)
`(hash-table-count ,ht))
+;; -*- Reference -*-
+(defmacro |ref| (v)
+ `(cons ,v nil))
+
+(defmacro |deref| (r)
+ `(car ,r))
+
;; -*- File IO -*-
(defparameter |$InputStream| (make-synonym-stream '*standard-input*))
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-28 01:35:48 +0000