diff options
| -rw-r--r-- | src/ChangeLog | 11 | ||||
| -rw-r--r-- | src/interp/Makefile.in | 9 | ||||
| -rw-r--r-- | src/interp/fnewmeta.lisp | 58 | ||||
| -rw-r--r-- | src/interp/metalex.lisp | 279 | ||||
| -rw-r--r-- | src/interp/parsing.lisp | 178 | ||||
| -rw-r--r-- | src/interp/spad-parser.boot | 25 |
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. |