aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog11
-rw-r--r--src/interp/Makefile.in9
-rw-r--r--src/interp/fnewmeta.lisp58
-rw-r--r--src/interp/metalex.lisp279
-rw-r--r--src/interp/parsing.lisp178
-rw-r--r--src/interp/spad-parser.boot25
6 files changed, 233 insertions, 327 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index 834af42f..bd27c57d 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,16 @@
2011-10-10 Gabriel Dos Reis <gdr@cs.tamu.edu>
+ * interp/metalex.lisp (DEFUN-PARSE-TOKEN): Remove.
+ Move remaining to parsing.lisp.
+ * interp/fnewmeta.lisp (PARSE-IntegerTok): Remove.
+ (PARSE-FloatTok): Likewise.
+ (PARSE-FormalParameter): Likewise.
+ (PARSE-FormalParameterTok): Likewise.
+ (PARSE-String): Likewise.
+ (PARSE-Name): Likewise.
+
+2011-10-10 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
* interp/postpar.boot: Remove functions and references to Scripts.
2011-10-08 Gabriel Dos Reis <gdr@cs.tamu.edu>
diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in
index 8f6feade..85a00d98 100644
--- a/src/interp/Makefile.in
+++ b/src/interp/Makefile.in
@@ -59,7 +59,7 @@ OBJS= boot-pkg.$(FASLEXT) types.$(FASLEXT) \
sys-utility.$(FASLEXT) lexing.$(FASLEXT) \
diagnostics.$(FASLEXT) \
union.$(FASLEXT) sys-macros.$(FASLEXT) \
- macros.$(FASLEXT) metalex.$(FASLEXT) \
+ macros.$(FASLEXT) \
parsing.$(FASLEXT) util.$(FASLEXT) \
unlisp.$(FASLEXT) g-util.$(FASLEXT) \
g-opt.$(FASLEXT) c-util.$(FASLEXT) \
@@ -322,8 +322,8 @@ server.$(FASLEXT): macros.$(FASLEXT)
## The old parser component roughtly is:
##
-spad-parser.$(FASLEXT): parse.$(FASLEXT)
-parse.$(FASLEXT): metalex.$(FASLEXT) postpar.$(FASLEXT)
+spad-parser.$(FASLEXT): parsing.$(FASLEXT) parse.$(FASLEXT)
+parse.$(FASLEXT): parsing.$(FASLEXT) postpar.$(FASLEXT)
packtran.$(FASLEXT): sys-macros.$(FASLEXT)
postpar.$(FASLEXT): macros.$(FASLEXT)
bootlex.$(FASLEXT): preparse.$(FASLEXT) macros.$(FASLEXT) \
@@ -331,8 +331,7 @@ bootlex.$(FASLEXT): preparse.$(FASLEXT) macros.$(FASLEXT) \
newaux.$(FASLEXT): macros.$(FASLEXT)
preparse.$(FASLEXT): fnewmeta.$(FASLEXT)
fnewmeta.$(FASLEXT): parsing.$(FASLEXT)
-parsing.$(FASLEXT): metalex.$(FASLEXT)
-metalex.$(FASLEXT): lexing.$(FASLEXT) macros.$(FASLEXT)
+parsing.$(FASLEXT): lexing.$(FASLEXT) macros.$(FASLEXT)
nlib.$(FASLEXT): macros.$(FASLEXT)
macros.$(FASLEXT): sys-macros.$(FASLEXT) sys-utility.$(FASLEXT)
lexing.$(FASLEXT): sys-utility.$(FASLEXT) sys-macros.$(FASLEXT)
diff --git a/src/interp/fnewmeta.lisp b/src/interp/fnewmeta.lisp
index 8ea479a7..62b1a34d 100644
--- a/src/interp/fnewmeta.lisp
+++ b/src/interp/fnewmeta.lisp
@@ -263,7 +263,7 @@
(MUST (MATCH-ADVANCE-STRING ")"))))
(DEFUN |PARSE-QuantifiedVariable| ()
- (AND (|PARSE-Name|)
+ (AND (|parseName|)
(MUST (MATCH-ADVANCE-STRING ":"))
(MUST (|PARSE-Application|))
(MUST (|pushReduction| '|PARSE-QuantifiedVariable|
@@ -438,7 +438,7 @@
(DEFUN |PARSE-Variable| ()
- (OR (AND (|PARSE-Name|)
+ (OR (AND (|parseName|)
(OPTIONAL (AND (MATCH-ADVANCE-STRING ":")
(MUST (|PARSE-Application|))
(MUST (|pushReduction| '|PARSE-Variable|
@@ -493,7 +493,7 @@
(DEFUN |PARSE-Label| ()
- (AND (MATCH-ADVANCE-STRING "<<") (MUST (|PARSE-Name|))
+ (AND (MATCH-ADVANCE-STRING "<<") (MUST (|parseName|))
(MUST (MATCH-ADVANCE-STRING ">>"))))
@@ -603,8 +603,8 @@
(MUST (|PARSE-Primary1|))
(|pushReduction| '|PARSE-Primary1|
(CONS (|popStack2|) (CONS (|popStack1|) NIL))))))
- (|PARSE-Quad|) (|PARSE-String|) (|PARSE-IntegerTok|)
- (|PARSE-FormalParameter|)
+ (|PARSE-Quad|) (|parseString|) (|parseInteger|)
+ (|parseFormalParameter|)
(AND (MATCH-ADVANCE-STRING "'")
(MUST (AND (MUST (|PARSE-Data|))
(|pushReduction| '|PARSE-Primary1| (|popStack1|)))))
@@ -622,11 +622,11 @@
(DEFUN |PARSE-FloatBase| ()
(OR (AND (INTEGERP (|currentSymbol|)) (CHAR-EQ (|currentChar|) ".")
- (CHAR-NE (|nextChar|) ".") (|PARSE-IntegerTok|)
+ (CHAR-NE (|nextChar|) ".") (|parseInteger|)
(MUST (|PARSE-FloatBasePart|)))
(AND (INTEGERP (|currentSymbol|))
(CHAR-EQ (CHAR-UPCASE (|currentChar|)) 'E)
- (|PARSE-IntegerTok|) (|pushReduction| '|PARSE-FloatBase| 0)
+ (|parseInteger|) (|pushReduction| '|PARSE-FloatBase| 0)
(|pushReduction| '|PARSE-FloatBase| 0))
(AND (DIGITP (|currentChar|)) (EQ (|currentSymbol|) '|.|)
(|pushReduction| '|PARSE-FloatBase| 0)
@@ -638,7 +638,7 @@
(MUST (OR (AND (DIGITP (|currentChar|))
(|pushReduction| '|PARSE-FloatBasePart|
(|tokenNonblank?| (|currentToken|)))
- (|PARSE-IntegerTok|))
+ (|parseInteger|))
(AND (|pushReduction| '|PARSE-FloatBasePart| 0)
(|pushReduction| '|PARSE-FloatBasePart| 0))))))
@@ -648,11 +648,11 @@
(RETURN
(OR (AND (MEMBER (|currentSymbol|) '(E |e|))
(FIND (|currentChar|) "+-") (ACTION (|advanceToken|))
- (MUST (OR (|PARSE-IntegerTok|)
+ (MUST (OR (|parseInteger|)
(AND (MATCH-ADVANCE-STRING "+")
- (MUST (|PARSE-IntegerTok|)))
+ (MUST (|parseInteger|)))
(AND (MATCH-ADVANCE-STRING "-")
- (MUST (|PARSE-IntegerTok|))
+ (MUST (|parseInteger|))
(|pushReduction| '|PARSE-FloatExponent|
(MINUS (|popStack1|))))
(|pushReduction| '|PARSE-FloatExponent| 0))))
@@ -690,31 +690,12 @@
)))
))
-
-(DEFUN |PARSE-IntegerTok| () (PARSE-NUMBER))
-
-
-(DEFUN |PARSE-FloatTok| ()
- (AND (PARSE-NUMBER)
- (|pushReduction| '|PARSE-FloatTok| (|popStack1|))))
-
-
-(DEFUN |PARSE-FormalParameter| () (|PARSE-FormalParameterTok|))
-
-
-(DEFUN |PARSE-FormalParameterTok| () (PARSE-ARGUMENT-DESIGNATOR))
-
-
(DEFUN |PARSE-Quad| ()
(AND (MATCH-ADVANCE-STRING "$")
(|pushReduction| '|PARSE-Quad| '$)))
-
-(DEFUN |PARSE-String| () (PARSE-SPADSTRING))
-
-
(DEFUN |PARSE-VarForm| ()
- (AND (|PARSE-Name|)
+ (AND (|parseName|)
(OPTIONAL
(AND (|PARSE-Scripts|)
(|pushReduction| '|PARSE-VarForm|
@@ -742,11 +723,6 @@
(|pushReduction| '|PARSE-ScriptItem|
(CONS '|PrefixSC| (CONS (|popStack1|) NIL))))))
-
-(DEFUN |PARSE-Name| ()
- (AND (PARSE-IDENTIFIER) (|pushReduction| '|PARSE-Name| (|popStack1|))))
-
-
(DEFUN |PARSE-Data| ()
(AND (ACTION (SETQ LABLASOC NIL)) (|PARSE-Sexpr|)
(|pushReduction| '|PARSE-Data|
@@ -758,8 +734,8 @@
(DEFUN |PARSE-Sexpr1| ()
- (OR (|PARSE-IntegerTok|)
- (|PARSE-String|)
+ (OR (|parseInteger|)
+ (|parseString|)
(AND (|PARSE-AnyId|)
(OPTIONAL
(AND (|PARSE-NBGliphTok| '=) (MUST (|PARSE-Sexpr1|))
@@ -771,7 +747,7 @@
(|pushReduction| '|PARSE-Sexpr1|
(CONS 'QUOTE (CONS (|popStack1|) NIL))))
;; next form disabled -- gdr, 2009-06-15.
-; (AND (MATCH-ADVANCE-STRING "-") (MUST (|PARSE-IntegerTok|))
+; (AND (MATCH-ADVANCE-STRING "-") (MUST (|parseInteger|))
; (|pushReduction| '|PARSE-Sexpr1| (MINUS (|popStack1|))))
(AND (MATCH-ADVANCE-STRING "[")
(BANG FIL_TEST (OPTIONAL (STAR REPEATOR (|PARSE-Sexpr1|))))
@@ -802,11 +778,11 @@
(DEFUN |PARSE-AnyId| ()
- (OR (|PARSE-Name|)
+ (OR (|parseName|)
(OR (AND (MATCH-STRING "$")
(|pushReduction| '|PARSE-AnyId| (|currentSymbol|))
(ACTION (|advanceToken|)))
- (PARSE-KEYWORD)
+ (|parseToken| 'KEYWORD)
(|PARSE-OperatorFunctionName|))))
diff --git a/src/interp/metalex.lisp b/src/interp/metalex.lisp
deleted file mode 100644
index ed1b588e..00000000
--- a/src/interp/metalex.lisp
+++ /dev/null
@@ -1,279 +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.
-
-
-; NAME: MetaLex.lisp
-; PURPOSE: Parsing support routines for Meta code
-; CONTENTS:
-;
-; 1. META File Handling
-; 2. META Line Handling
-; 4. META Token Parsing Actions
-; 5. META Error Handling
-
-(IMPORT-MODULE "lexing")
-(IMPORT-MODULE "macros")
-(in-package "BOOT")
-
-; 0. Current I/O Stream definition
-
-(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
- :adjustable t :initial-contents s))))
-
-(defun get-a-line (stream)
- (if (and (IS-CONSOLE stream) (not |$leanMode|))
- (|printPrompt|))
- (let ((ll (read-a-line stream)))
- (if (stringp ll) (make-string-adjustable ll) ll)))
-
-(defparameter Current-Fragment nil
- "A string containing remaining chars from readline; needed because
-Symbolics read-line returns embedded newlines in a c-m-Y.")
-
-(defun input-clear () (setq Current-Fragment nil))
-
-(defun Next-Lines-Clear () (setq |$lineStack| nil))
-
-(defun Next-Lines-Show ()
- (and |$lineStack| (format t "Currently preparsed lines are:~%~%"))
- (mapcar #'(lambda (line)
- (format t "~&~5D> ~A~%" (car line) (cdr Line)))
- |$lineStack|))
-
-
-; 3. Routines for handling lexical scanning
-;
-; Lexical scanning of tokens is performed off of the current line. No
-; token can span more than 1 line. All real I/O is handled in a line-oriented
-; fashion (in a slight paradox) below the character level. All character
-; routines implicitly assume the parameter |$spadLine|. We do not make
-; |$spadLine| an explicit optional parameter for reasons of efficiency.
-
-(defmacro current-line-print () '(Line-Print |$spadLine|))
-
-(defmacro current-line-show ()
- `(if (|linePastEnd?| |$spadLine|)
- (format t "~&The current line is empty.~%")
- (progn (format t "~&The current line is:~%~%")
- (current-line-print))))
-
-(defmacro current-line-clear () `(|lineClear!| |$spadLine|))
-
-(defun read-a-line (&optional (stream t))
- (let (cp)
- (if (and Current-Fragment (> (length Current-Fragment) 0))
- (let ((line (with-input-from-string
- (s Current-Fragment :index cp :start 0)
- (read-line s nil nil))))
- (setq Current-Fragment (subseq Current-Fragment cp))
- line)
- (prog nil
- (if (stream-eof in-stream)
- (progn (setq File-Closed t *EOF* t)
- (|lineNewLine!| (make-string 0) |$spadLine|)
- (return nil)))
- (if (setq Current-Fragment (read-line stream))
- (return (read-a-line stream)))))))
-
-; *** Print New Line
-
-(defparameter Printer-Line-Stack (|makeStack|)
- "Stack of output listing lines waiting to print. [local to PRINT-NEW-LINE]")
-
-(defparameter Read-Quietly nil
- "Whether or not to produce an output listing. [local to PRINT-NEW-LINE]")
-
-(defun Print-New-Line (string &optional (strm |$OutputStream|))
- "Makes output listings."
- (if Read-Quietly (|stackPush!| (copy-tree string) Printer-Line-Stack)
- (progn (mapc #'(lambda (x) (format strm "; ~A~%" x) (terpri))
- (|reverse!| (|stackStore| Printer-Line-Stack)))
- (|stackClear!| Printer-Line-Stack)
- (format strm "~&; ~A~%" string))))
-
-; 1C. Token
-(defun Token-Print (token)
- (format out-stream "(token (symbol ~S) (type ~S))~%"
- (|tokenSymbol| token) (|tokenType| token)))
-
-(defun reduce-stack-show ()
- (let ((store (|stackStore| |$reduceStack|))
- (*print-pretty* t))
- (if store
- (progn (format t "~%Reduction stack contains:~%")
- (mapcar #'(lambda (x)
- (if (eq (type-of x) 'token)
- (describe x)
- (print x)))
- (|stackStore| |$reduceStack|)))
- (format t "~%There is nothing on the reduction stack.~%"))))
-
-
-; *** 3. META Token Handling
-
-; STRING: "'" { Chars - "'" }* "'"
-; BSTRING: "[" ... "]*"
-; ID: letters, _ and then numbers
-; NUMBER: digits, ., digits, e, +-, digits
-
-; 3A (1) Token Handling.
-
-; Tokens are acquired from a stream of characters. Lexical analysis is performed
-; by the functiond Get Token. One-token lookahead is maintained in variables
-; |$CurrentToken| and |$NextToken| by procedures Current Token, Next Token, and
-; Advance Token. The functions Match Current Token and Match Next Token recognize
-; classes of tokens, by type, or by type and symbol. The current and next tokens
-; can be shoved back on the input stream (to the current line) with Unget-Tokens.
-
-(defmacro Defun-Parse-Token (token)
- `(defun ,(intern (concatenate 'string "PARSE-" (string token))) ()
- (let* ((tok (|matchCurrentToken| ',token))
- (symbol (if tok (|tokenSymbol| tok))))
- (if tok (progn (|pushReduction|
- ',(intern (concatenate 'string (string token)
- "-TOKEN"))
- (copy-tree symbol))
- (|advanceToken|)
- t)))))
-
-(defun token-stack-show ()
- (if (= |$validTokens| 0) (format t "~%There are no valid tokens.~%")
- (format t "~%The number of valid tokens is ~S.~%" |$validTokens|))
- (if (> |$validTokens| 0)
- (progn (format t "The current token is~%")
- (describe |$currentToken|)))
- (if (> |$validTokens| 1)
- (progn (format t "The next token is~%")
- (describe |$nextToken|)))
- (if (|tokenType| |$priorToken|)
- (progn (format t "The prior token was~%")
- (describe |$priorToken|))))
-
-
-(defun-parse-token STRING)
-(defun-parse-token BSTRING)
-(defun-parse-token IDENTIFIER)
-(defun-parse-token NUMBER)
-
-; Parsing of operator tokens depends on tables initialized by BOTTOMUP.LISP
-
-(defun-parse-token SPADSTRING)
-(defun-parse-token KEYWORD)
-(defun-parse-token ARGUMENT-DESIGNATOR)
-
-(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))
-
-(defun get-number-token (token)
- "Take a number off the input stream."
- (prog ((buf (make-adjustable-string 0)))
- nu1
- (suffix (|currentChar|) buf) ; Integer part
- (let ((next-chr (|nextChar|)))
- (cond ((digitp next-chr)
- (|advanceChar!|)
- (go nu1))))
- (|advanceChar!|)
- (return (|tokenInstall| (read-from-string buf)
- 'number token
- (size buf) ;used to keep track of digit count
- ))))
-
-; *** 4. META Auxiliary Parsing Actions
-
-(defparameter Meta_Prefix nil)
-
-(defun make-defun (nametok vars body)
- (let ((name (INTERN (STRCONC |META_PREFIX| nametok))))
- (if vars
- `(DEFUN ,name ,vars (declare (special . ,vars)) ,body)
- `(DEFUN ,name ,vars ,body))))
-
-(defun print-fluids (fluids)
- (terpri out-stream)
- (mapcar #'(lambda (x) (format out-stream "~&(DEFPARAMETER ~S NIL)~%" x)) fluids)
- (terpri out-stream))
-
-(defun print-package (package)
- (format out-stream "~&~%(IN-PACKAGE ~S )~%~%" package))
-
-(defun set-prefix (prefix) (setq META_PREFIX prefix))
-
-(defun print-rule (x) (print x out-stream) (format out-stream "~%~%"))
-
-; *** 5. META Error Handling
-
-(defparameter $num_of_meta_errors 0)
-
-(defparameter Meta_Errors_Occurred nil "Did any errors occur")
diff --git a/src/interp/parsing.lisp b/src/interp/parsing.lisp
index 42d5efbc..b8ca2142 100644
--- a/src/interp/parsing.lisp
+++ b/src/interp/parsing.lisp
@@ -76,9 +76,185 @@
; NEWMETA.LISP: Boot parsing
-(import-module "metalex")
+(import-module "lexing")
+(import-module "macros")
+
(in-package "BOOT")
+
+; 0. Current I/O Stream definition
+
+(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
+ :adjustable t :initial-contents s))))
+
+(defun get-a-line (stream)
+ (if (and (IS-CONSOLE stream) (not |$leanMode|))
+ (|printPrompt|))
+ (let ((ll (read-a-line stream)))
+ (if (stringp ll) (make-string-adjustable ll) ll)))
+
+(defparameter Current-Fragment nil
+ "A string containing remaining chars from readline; needed because
+Symbolics read-line returns embedded newlines in a c-m-Y.")
+
+(defun input-clear () (setq Current-Fragment nil))
+
+(defun Next-Lines-Clear () (setq |$lineStack| nil))
+
+(defun Next-Lines-Show ()
+ (and |$lineStack| (format t "Currently preparsed lines are:~%~%"))
+ (mapcar #'(lambda (line)
+ (format t "~&~5D> ~A~%" (car line) (cdr Line)))
+ |$lineStack|))
+
+
+; 3. Routines for handling lexical scanning
+;
+; Lexical scanning of tokens is performed off of the current line. No
+; token can span more than 1 line. All real I/O is handled in a line-oriented
+; fashion (in a slight paradox) below the character level. All character
+; routines implicitly assume the parameter |$spadLine|. We do not make
+; |$spadLine| an explicit optional parameter for reasons of efficiency.
+
+(defmacro current-line-print () '(Line-Print |$spadLine|))
+
+(defmacro current-line-show ()
+ `(if (|linePastEnd?| |$spadLine|)
+ (format t "~&The current line is empty.~%")
+ (progn (format t "~&The current line is:~%~%")
+ (current-line-print))))
+
+(defmacro current-line-clear () `(|lineClear!| |$spadLine|))
+
+(defun read-a-line (&optional (stream t))
+ (let (cp)
+ (if (and Current-Fragment (> (length Current-Fragment) 0))
+ (let ((line (with-input-from-string
+ (s Current-Fragment :index cp :start 0)
+ (read-line s nil nil))))
+ (setq Current-Fragment (subseq Current-Fragment cp))
+ line)
+ (prog nil
+ (if (stream-eof in-stream)
+ (progn (setq File-Closed t *EOF* t)
+ (|lineNewLine!| (make-string 0) |$spadLine|)
+ (return nil)))
+ (if (setq Current-Fragment (read-line stream))
+ (return (read-a-line stream)))))))
+
+; *** Print New Line
+
+(defparameter Printer-Line-Stack (|makeStack|)
+ "Stack of output listing lines waiting to print. [local to PRINT-NEW-LINE]")
+
+(defparameter Read-Quietly nil
+ "Whether or not to produce an output listing. [local to PRINT-NEW-LINE]")
+
+(defun Print-New-Line (string &optional (strm |$OutputStream|))
+ "Makes output listings."
+ (if Read-Quietly (|stackPush!| (copy-tree string) Printer-Line-Stack)
+ (progn (mapc #'(lambda (x) (format strm "; ~A~%" x) (terpri))
+ (|reverse!| (|stackStore| Printer-Line-Stack)))
+ (|stackClear!| Printer-Line-Stack)
+ (format strm "~&; ~A~%" string))))
+
+; 1C. Token
+(defun Token-Print (token)
+ (format out-stream "(token (symbol ~S) (type ~S))~%"
+ (|tokenSymbol| token) (|tokenType| token)))
+
+(defun reduce-stack-show ()
+ (let ((store (|stackStore| |$reduceStack|))
+ (*print-pretty* t))
+ (if store
+ (progn (format t "~%Reduction stack contains:~%")
+ (mapcar #'(lambda (x)
+ (if (eq (type-of x) 'token)
+ (describe x)
+ (print x)))
+ (|stackStore| |$reduceStack|)))
+ (format t "~%There is nothing on the reduction stack.~%"))))
+
+(defun token-stack-show ()
+ (if (= |$validTokens| 0) (format t "~%There are no valid tokens.~%")
+ (format t "~%The number of valid tokens is ~S.~%" |$validTokens|))
+ (if (> |$validTokens| 0)
+ (progn (format t "The current token is~%")
+ (describe |$currentToken|)))
+ (if (> |$validTokens| 1)
+ (progn (format t "The next token is~%")
+ (describe |$nextToken|)))
+ (if (|tokenType| |$priorToken|)
+ (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))
+
+(defun get-number-token (token)
+ "Take a number off the input stream."
+ (prog ((buf (make-adjustable-string 0)))
+ nu1
+ (suffix (|currentChar|) buf) ; Integer part
+ (let ((next-chr (|nextChar|)))
+ (cond ((digitp next-chr)
+ (|advanceChar!|)
+ (go nu1))))
+ (|advanceChar!|)
+ (return (|tokenInstall| (read-from-string buf)
+ 'number token
+ (size buf) ;used to keep track of digit count
+ ))))
+
+; *** 5. META Error Handling
+
+(defparameter $num_of_meta_errors 0)
+
+(defparameter Meta_Errors_Occurred nil "Did any errors occur")
+
(defun IOStreams-Show ()
(format t "~&Input is coming from ~A, and output is going to ~A.~%"
(or (streamp in-stream) "the keyboard")
diff --git a/src/interp/spad-parser.boot b/src/interp/spad-parser.boot
index 719f7258..3ab5c41a 100644
--- a/src/interp/spad-parser.boot
+++ b/src/interp/spad-parser.boot
@@ -42,10 +42,33 @@
-- -- gdr/2007-11-02
--
-import metalex
+import parsing
import parse
namespace BOOT
+--%
+
+parseToken tt ==
+ tok := matchCurrentToken tt =>
+ pushReduction(makeSymbol strconc(symbolName tt,'"Token"),tokenSymbol tok)
+ advanceToken()
+ true
+ false
+
+parseString() ==
+ parseToken 'SPADSTRING
+
+parseInteger() ==
+ parseToken 'NUMBER
+
+parseName() ==
+ parseToken 'IDENTIFIER and pushReduction('parseName,popStack1())
+
+parseFormalParameter() ==
+ parseToken 'ARGUMENT_-DESIGNATOR
+
+--%
+
++ Given a pathname to a source file containing Spad code, returns
++ a list of (old) AST objects representing the toplevel expressions
++ in that file.