From ab8cc85adde879fb963c94d15675783f2cf4b183 Mon Sep 17 00:00:00 2001
From: dos-reis <gdr@axiomatics.org>
Date: Tue, 14 Aug 2007 05:14:52 +0000
Subject: Initial population.

---
 src/interp/parsing.lisp.pamphlet | 1088 ++++++++++++++++++++++++++++++++++++++
 1 file changed, 1088 insertions(+)
 create mode 100644 src/interp/parsing.lisp.pamphlet

(limited to 'src/interp/parsing.lisp.pamphlet')

diff --git a/src/interp/parsing.lisp.pamphlet b/src/interp/parsing.lisp.pamphlet
new file mode 100644
index 00000000..54c9dbfe
--- /dev/null
+++ b/src/interp/parsing.lisp.pamphlet
@@ -0,0 +1,1088 @@
+%% Oh Emacs, this is a -*- Lisp -*- file, despite appearance.
+\documentclass{article}
+\usepackage{axiom}
+
+\title{\File{src/interp/parsing.lisp} Pamphlet}
+\author{Timothy Daly}
+
+\begin{document}
+\maketitle
+\begin{abstract}
+\end{abstract}
+\eject
+\tableofcontents
+\eject
+
+\section{License}
+
+<<license>>=
+;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+;; 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.
+
+@
+<<*>>=
+<<license>>
+
+; NAME:    META/LISP Parser Generator and Lexical Analysis Utilities (Parsing)
+;
+; PURPOSE: This package provides routines to support the Metalanguage
+;          translator writing system.   Metalanguage is described
+;          in META/LISP, R.D. Jenks, Tech Report, IBM T.J. Watson Research Center,
+;          1969.  Familiarity with this document is assumed.
+;
+;          The parser generator itself is described in either the file
+;          MetaBoot.lisp (hand-coded version) or the file MetaMeta.lisp (machine
+;          generated from self-descriptive Meta code), both of which load themselves
+;          into package Parsing.
+
+; CONTENTS:
+;
+;       0. Current I/O Stream definition
+;
+;       1. Data structure declarations (defstructs) for parsing objects
+;
+;               A. Line Buffer
+;               B. Stack
+;               C. Token
+;               D. Reduction
+;
+;       2. Recursive descent parsing support routines
+;               A. Stacking and retrieving reductions of rules.
+;               B. Applying metagrammatical elements of a production (e.g., Star).
+;
+;       3. Routines for handling lexical scanning
+;
+;               A. Manipulating the token stack and reading tokens
+;               B. Error handling
+;               C. Constructing parsing procedures
+;               D. Managing rule sets
+;
+;       4. Tracing routines
+;
+;       5. Routines for inspecting and resetting total I/O system state
+;
+;       METALEX.LISP:  Meta file handling, auxiliary parsing actions and tokenizing
+;       METAMETA.LISP: Meta parsing
+;
+;       BOOTLEX.LISP:  Boot file handling, auxiliary parsing actions and tokenizing
+;       NEWMETA.LISP:  Boot parsing
+
+(in-package "BOOT")
+
+; 0. Current I/O Stream definition
+
+(defparameter in-stream  t "Current input stream.")
+(defparameter out-stream t "Current output stream.")
+(defparameter File-Closed nil   "Way to stop EOF tests for console input.")
+
+(defun IOStreams-Show ()
+  (format t "~&Input is coming from ~A, and output is going to ~A.~%"
+           (or (streamp in-stream) "the keyboard")
+           (or (streamp out-stream) "the screen"))
+  (format t "~:[~;The current input stream is logically closed.~%~]~%" File-Closed))
+
+(defmacro IOStreams-Set (input output) `(setq in-stream ,input out-stream ,output))
+
+(defmacro IOStreams-Clear (&optional (in t) (out t))
+  `(progn (and (streamp in-stream) (close in-stream))
+          (and (streamp out-stream) (close out-stream))
+          (setq File-Closed nil)
+          (IOStreams-Set ,in ,out)))
+
+; 1. Data structure declarations (defstructs) for parsing objects
+;
+;               A. Line Buffer
+;               B. Stack
+;               C. Token
+;               D. Reduction
+
+; 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-Buffer, Line-Current-Char, Line-Current-Index, Line-Last-Index, Line-Number
+;       Line-New-Line, Line-Advance-Char, Line-Past-End-P, Line-At-End-P
+;       Make-Line
+
+(defstruct Line "Line of input file to parse."
+           (Buffer (make-string 0) :type string)
+           (Current-Char #\Return :type character)
+           (Current-Index 1 :type fixnum)
+           (Last-Index 0 :type fixnum)
+           (Number 0 :type fixnum))
+
+(defun Line-Print (line)
+  (format out-stream "~&~5D> ~A~%" (Line-Number line) (Line-Buffer Line))
+  (format out-stream "~v@T^~%" (+ 7 (Line-Current-Index line))))
+
+(defmacro Line-Clear (line)
+  `(let ((l ,line))
+     (setf (Line-Buffer l) (make-string 0)
+           (Line-Current-Char l) #\Return
+           (Line-Current-Index l) 1
+           (Line-Last-Index l) 0
+           (Line-Number l) 0)))
+
+(defun Line-Current-Segment (line)
+  "Buffer from current index to last index."
+  (if (line-at-end-p line) (make-string 0)
+      (subseq (Line-Buffer line)
+              (Line-Current-Index line)
+              (Line-Last-Index line))))
+
+(defun Line-New-Line (string line &optional (linenum nil))
+  "Sets string to be the next line stored in line."
+  (setf (Line-Last-Index line) (1- (length string))
+        (Line-Current-Index line) 0
+        (Line-Current-Char line) (or (and (> (length string) 0) (elt string 0)) #\Return)
+        (Line-Buffer line) string
+        (Line-Number line) (or linenum (1+ (Line-Number line)))))
+
+(defun Line-Advance-Char (line)
+  (setf (Line-Current-Char line)
+        (elt (Line-Buffer line) (incf (Line-Current-Index line)))))
+
+(defun Line-Next-Char (line)
+  (elt (Line-Buffer line) (1+ (Line-Current-Index line))))
+
+(defun Line-Past-End-P (line)
+  "Tests if line is empty or positioned past the last character."
+  (> (line-current-index line) (line-last-index line)))
+
+(defun Line-At-End-P (line)
+  "Tests if line is empty or positioned past the last character."
+  (>= (line-current-index line) (line-last-index line)))
+
+; 1B. A Stack (of lines, tokens, or whatever)
+
+; FUNCTIONS DEFINED IN THIS SECTION:
+;
+;       Make-Stack, Stack-Store, Stack-Size, Stack-Top, Stack-Load, Stack-Clear,
+;       Stack-/-Empty, Stack-Push, Stack-Pop
+
+(defstruct Stack                "A stack"
+           (Store nil)          ; contents of the stack
+           (Size 0)             ; number of elements in Store
+           (Top nil)            ; first element of Store
+
+           (Updated nil)        ; whether something has been pushed on the stack
+                                ; since this flag was last set to NIL
+)
+
+(defun stack-load (list stack)
+  (setf (stack-store stack) list
+        (stack-size stack) (length list)
+        (stack-top stack) (car list)))
+
+(defun stack-clear (stack)
+  (setf (stack-store stack) nil (stack-size stack) 0 (stack-top stack) nil
+        (stack-updated stack) nil))
+
+(defmacro stack-/-empty (stack) `(> (stack-size ,stack) 0))
+
+(defun stack-push (x stack)
+  (push x (stack-store stack))
+  (setf (stack-top stack) x (stack-updated stack) t)
+  (incf (stack-size stack))
+  x)
+
+(defun stack-pop (stack)
+  (let ((y (pop (stack-store stack))))
+    (decf (stack-size stack))
+    (setf (stack-top stack) (if (stack-/-empty stack) (car (stack-store stack))))
+    y))
+
+; 1C. Token
+
+; FUNCTIONS DEFINED IN THIS SECTION:
+;
+;       Make-Token, Token-Symbol, Token-Type, Token-Install, Token-Print
+
+(defstruct Token
+  "A token is a Symbol with a Type.
+The type is either NUMBER, IDENTIFIER or SPECIAL-CHAR.
+NonBlank is true if the token is not preceded by a blank."
+  (Symbol nil)
+  (Type nil)
+  (NonBlank t))
+
+(defparameter Prior-Token (make-token) "What did I see last")
+(defparameter nonblank t "Is there no blank in front of the current token.")
+(defparameter Current-Token (make-token) "Token at head of input stream.")
+(defparameter Next-Token (make-token)    "Next token in input stream.")
+(defparameter Valid-Tokens 0               "Number of tokens in buffer (0, 1 or 2)")
+
+(defun Token-Install (symbol type token &optional (nonblank t))
+  (setf (token-symbol token) symbol (token-type token) type
+        (token-nonblank token) nonblank)
+  token)
+
+(defun Token-Print (token)
+  (format out-stream "(token (symbol ~S) (type ~S))~%"
+          (Token-Symbol token) (Token-Type token)))
+
+; 1D. A Reduction
+;
+
+(defstruct (Reduction (:type list))
+"A reduction of a rule is any S-Expression the rule chooses to stack."
+  (Rule nil)            ; Name of rule
+  (Value nil))
+
+; 2. Recursive descent parsing support routines (semantically related to MetaLanguage)
+;
+; This section of the code contains:
+;
+;               A. Routines for stacking and retrieving reductions of rules.
+;               B. Routines for applying certain metagrammatical elements
+;                  of a production (e.g., Star).
+;               C. Token-level parsing utilities (keywords, strings, identifiers).
+
+; 2A. Routines for stacking and retrieving reductions of rules.
+
+; FUNCTIONS DEFINED IN THIS SECTION:
+;
+;       Push-Reduction Pop-Reduction
+
+(defparameter Reduce-Stack (make-stack) "Stack of results of reduced productions.")
+
+(defun Push-Reduction (rule redn)
+  (stack-push (make-reduction :rule rule :value redn) Reduce-Stack))
+
+(defun reduce-stack-show ()
+  (let ((store (stack-store reduce-stack))
+        (*print-pretty* t))
+    (if store
+        (progn (format t "~%Reduction stack contains:~%")
+               (mapcar #'(lambda (x) (if (eq (type-of x) 'token)
+                               #+Symbolics (zl:describe-defstruct x)
+                               #-Symbolics (describe x)
+                                         (print x)))
+                       (stack-store reduce-stack)))
+        (format t "~%There is nothing on the reduction stack.~%"))))
+
+(defmacro reduce-stack-clear () `(stack-load nil reduce-stack))
+
+(defun Pop-Reduction () (stack-pop Reduce-Stack))
+
+(defmacro pop-stack-1 () '(reduction-value (Pop-Reduction)))
+
+(defmacro pop-stack-2 ()
+  `(let* ((top (Pop-Reduction)) (next (Pop-Reduction)))
+     (stack-push top Reduce-Stack)
+     (reduction-value next)))
+
+(defmacro pop-stack-3 ()
+  `(let* ((top (Pop-Reduction)) (next (Pop-Reduction)) (nnext (Pop-Reduction)))
+     (stack-push next Reduce-Stack)
+     (stack-push top Reduce-Stack)
+     (reduction-value nnext)))
+
+(defmacro pop-stack-4 ()
+  `(let* ((top (Pop-Reduction))
+          (next (Pop-Reduction))
+          (nnext (Pop-Reduction))
+          (nnnext (Pop-Reduction)))
+     (stack-push nnext Reduce-Stack)
+     (stack-push next Reduce-Stack)
+     (stack-push top Reduce-Stack)
+     (reduction-value nnnext)))
+
+(defmacro nth-stack (x)
+  `(reduction-value (nth (1- ,x) (stack-store Reduce-Stack))))
+
+; 2B. Routines for applying certain metagrammatical elements
+;     of a production (e.g., Star).
+
+; Must means that if it is not present in the token stream, it is a syntax error.
+
+; FUNCTIONS DEFINED IN THIS SECTION:
+;
+;       Star, Bang, Must, Optional, Action, Sequence
+
+(defmacro Star (lab prod)
+
+"Succeeds if there are one or more of PROD, stacking as one unit
+the sub-reductions of PROD and labelling them with LAB.
+E.G., (Star IDs (parse-id)) with A B C will stack (3 IDs (A B C)),
+where (parse-id) would stack (1 ID (A)) when applied once."
+
+  `(prog ((oldstacksize (stack-size reduce-stack)))
+         (if (not ,prod) ;(progn (format t "~&Star failed for ~A.~%" ',lab) (return nil)))
+             (return nil))
+    loop (if (not ,prod)
+             (let* ((newstacksize (stack-size reduce-stack))
+                    (number-of-new-reductions (- newstacksize oldstacksize)))
+;              (format t "~&Starring ~A with ~D new reductions.~%"
+;                      ',lab number-of-new-reductions)
+               (if (> number-of-new-reductions 0)
+                   (return (do ((i 0 (1+ i)) (accum nil))
+                               ((= i number-of-new-reductions)
+                                (Push-Reduction ',lab accum)
+;                               (format t "~&Star accumulated ~D reductions.~%"
+;                                       (length accum))
+                                (return t))
+                             (push (pop-stack-1) accum)))
+                   (return t)))
+             (go loop))))
+
+(defmacro Bang (lab prod)
+
+"If the execution of prod does not result in an increase in the size of
+the stack, then stack a NIL. Return the value of prod."
+
+  `(progn (setf (stack-updated reduce-stack) nil)
+;         (format t "~&Banging ~A~:[~; and I think the stack is updated!~].~%" ',lab
+;                 (stack-updated reduce-stack))
+          (let* ((prodvalue ,prod)
+                 (updated (stack-updated reduce-stack)))
+;           (format t "~&Bang thinks that ~A ~:[didn't do anything~;did something~].~&"
+;                   ',lab prodvalue)
+            (if updated
+                (progn ; (format t "~&Banged ~A and I think the stack is updated!~%" ',lab)
+                       prodvalue)
+                (progn (push-reduction ',lab nil)
+                       ; (format t "~&Banged ~A.~%" ',lab)
+                       prodvalue)))))
+
+(defmacro must (dothis &optional (this-is nil) (in-rule nil))
+  `(or ,dothis (meta-syntax-error ,this-is ,in-rule)))
+
+; Optional means that if it is present in the token stream, that is a good thing,
+; otherwise don't worry (like [ foo ] in BNF notation).
+
+(defun Optional (dothis) (or dothis t))
+
+; Action is something we do as a consequence of successful parsing; it is
+; inserted at the end of the conjunction of requirements for a successful
+; parse, and so should return T.
+
+(defun action (dothis) (or dothis t))
+
+; A sequence consists of a head, which if recognized implies that the
+; tail must follow.   Following tail are actions, which
+; are performed upon recognizing the head and tail.
+
+(defmacro sequence (subrules &optional (actions nil))
+  `(and ,(pop subrules) . ,(append (mapcar #'(lambda (x) (list 'must x)) subrules)
+                         (if actions `((progn . ,(append actions '(t))))))))
+
+; 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 Current-Line.  We do not make
+; Current-Line an explicit optional parameter for reasons of efficiency.
+
+(defparameter Current-Line (make-line)  "Current input line.")
+
+(defmacro current-line-print () '(Line-Print Current-Line))
+
+(defmacro current-line-show ()
+  `(if (line-past-end-p current-line)
+       (format t "~&The current line is empty.~%")
+       (progn (format t "~&The current line is:~%~%")
+              (current-line-print))))
+
+(defmacro current-line-clear () `(Line-Clear Current-Line))
+
+; 3A.  Manipulating the token stack and reading tokens
+
+; This section is broken up into 3 levels:
+;
+;       (0) String grabbing:    Match String, Match Advance String
+;       (1) Token handling:     Current Token, Next Token, Advance Token
+;       (2) Character handling: Current Char, Next Char, Advance Char
+;       (3) Line handling:      Next Line, Print Next Line
+;       (X) Random Stuff
+
+; A good test for lexing is:
+
+(defmacro test-lexing ()
+  '(with-open-file (in-stream "lisp>meta.meta" :direction :input)
+    (with-open-file (out-stream "lisp>foo.pars" :direction :output :if-exists :supersede)
+      (loop (let ((z (advance-token)))
+              (if z (Token-Print z out-stream) (return nil)))))))
+
+; 3A (0). String grabbing
+
+; String grabbing is the art of matching initial segments of the current
+; line, and removing them from the line before the get tokenized if they
+; match (or removing the corresponding current tokens).
+
+; FUNCTIONS DEFINED IN THIS SECTION:
+;
+;       Match-String, Match-Advance-String
+
+(defun Match-String (x)
+  "Returns length of X if X matches initial segment of inputstream."
+  (unget-tokens)                        ; So we don't get out of synch with token stream
+  (skip-blanks)
+  (if (and (not (Line-Past-End-P Current-Line)) (Current-Char) )
+      (initial-substring-p x
+           (subseq (Line-Buffer Current-Line) (Line-Current-Index Current-Line)))))
+
+(defun Match-Advance-String (x)
+  "Same as MATCH-STRING except if successful, advance inputstream past X."
+  (let ((y (if (>= (length (string x))
+                   (length (string (quote-if-string (current-token)))))
+               (Match-String x)
+               nil))) ; must match at least the current token
+    (if y (progn (incf (Line-Current-Index Current-Line) y)
+                 (if (not (Line-Past-End-P Current-Line))
+                     (setf (Line-Current-Char Current-Line)
+                           (elt (Line-Buffer Current-Line)
+                                (Line-Current-Index Current-Line)))
+                     (setf (Line-Current-Char Current-Line) #\Space))
+                 (setq prior-token
+                       (make-token :Symbol (intern (string x))
+                                   :Type 'identifier
+                                   :nonBlank nonblank))
+                 t))))
+
+(defun initial-substring-p (part whole)
+  "Returns length of part if part matches initial segment of whole."
+  (let ((x (string-not-greaterp part whole)))
+    (and x (= x (length part)) x)))
+
+; 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
+; Current-Token and Next-Token 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 (match-current-token ',token))
+            (symbol (if tok (token-symbol tok))))
+       (if tok (progn (Push-Reduction
+                        ',(intern (concatenate 'string (string token)
+                                               "-TOKEN"))
+                        (copy-tree symbol))
+                      (advance-token)
+                      t)))))
+
+(defun token-stack-show ()
+  (if (= Valid-Tokens 0) (format t "~%There are no valid tokens.~%")
+      (format t "~%The number of valid tokens is ~S.~%" Valid-Tokens))
+  (if (> Valid-Tokens 0)
+      (progn (format t "The current token is~%")
+             #+Symbolics (zl:describe-defstruct current-token)
+             #-Symbolics (describe current-token)
+             ))
+  (if (> Valid-Tokens 1)
+      (progn (format t "The next token is~%")
+             #+Symbolics (zl:describe-defstruct next-token)
+             #-Symbolics (describe next-token)
+             ))
+  (if (token-type prior-token)
+      (progn (format t "The prior token was~%")
+             #+Symbolics (zl:describe-defstruct prior-token)
+             #-Symbolics (describe prior-token)
+             )))
+
+(defmacro token-stack-clear ()
+  `(progn (setq valid-tokens 0)
+          (token-install nil nil current-token nil)
+          (token-install nil nil next-token nil)
+          (token-install nil nil prior-token nil)))
+
+; Unget-Tokens
+
+(defun quote-if-string (token)
+  (if token   ;only use token-type on non-null tokens
+  (case (token-type token)
+    (bstring            (strconc "[" (token-symbol token) "]*"))
+    (string             (strconc "'" (token-symbol token) "'"))
+    (spadstring         (strconc "\"" (underscore (token-symbol token)) "\""))
+    (number             (format nil "~v,'0D" (token-nonblank token)
+				(token-symbol token)))
+    (special-char       (string (token-symbol token)))
+    (identifier         (let ((id (symbol-name (token-symbol token)))
+			      (pack (package-name (symbol-package
+						   (token-symbol token)))))
+                          (if (or $BOOT $SPAD)
+			      (if (equal pack "BOOT")
+				  (escape-keywords (underscore id) (token-symbol token))
+				(concatenate 'string
+					     (underscore pack) "'" (underscore id)))
+			    id)))
+    (t                  (token-symbol token)))
+   nil))
+
+(defun escape-keywords (pname id)
+  (if (member id keywords)
+      (concatenate 'string "_" pname)
+    pname))
+
+(defun underscore (string)
+  (if (every #'alpha-char-p string) string
+    (let* ((size (length string))
+	   (out-string (make-array (* 2 size)
+				   :element-type 'character
+				   :fill-pointer 0))
+	   next-char)
+      (dotimes (i size)
+	       (setq next-char (char string i))
+	       (if (not (alpha-char-p next-char))
+		   (vector-push #\_ out-string))
+	       (vector-push next-char out-string))
+      out-string)))
+
+(defun Unget-Tokens ()
+  (case Valid-Tokens
+    (0 t)
+    (1 (let* ((cursym (quote-if-string current-token))
+              (curline (line-current-segment current-line))
+              (revised-line (strconc cursym curline (copy-seq " "))))
+         (line-new-line revised-line current-line (line-number current-line))
+         (setq NonBlank (token-nonblank current-token))
+         (setq Valid-Tokens 0)))
+    (2 (let* ((cursym (quote-if-string current-token))
+              (nextsym (quote-if-string next-token))
+              (curline (line-current-segment current-line))
+              (revised-line
+                (strconc (if (token-nonblank current-token) "" " ")
+                         cursym
+                         (if (token-nonblank next-token) "" " ")
+                         nextsym curline " ")))
+         (setq NonBlank (token-nonblank current-token))
+         (line-new-line revised-line current-line (line-number current-line))
+         (setq Valid-Tokens 0)))
+    (t (error "How many tokens do you think you have?"))))
+
+; *** Match Token
+
+(defun match-token (token type &optional (symbol nil))
+  (if (and token (eq (token-type token) type))
+      (if symbol (if (equal symbol (token-symbol token)) token) token)))
+
+(defun match-current-token (type &optional (symbol nil))
+  "Returns the current token if it has EQ type and (optionally) equal symbol."
+  (match-token (current-token) type symbol))
+
+(defun match-next-token (type &optional (symbol nil))
+  "Returns the next token if it has equal type and (optionally) equal symbol."
+  (match-token (next-token) type symbol))
+
+; *** Current Token, Next Token, Advance Token
+
+(defun try-get-token (token)
+  (let ((tok (get-token token)))
+    (if tok (progn (incf Valid-Tokens) token))))
+
+(defun current-symbol () (make-symbol-of (current-token)))
+
+(defun make-symbol-of (token)
+  (let ((u (and token (token-symbol token))))
+    (cond ((not u) nil)
+          ((characterp u) (intern (string u)))
+          (u))))
+
+(defun current-token ()
+  "Returns the current token getting a new one if necessary."
+  (if (> Valid-Tokens 0)
+      Current-Token
+      (try-get-token Current-Token)))
+
+(defun next-token ()
+  "Returns the token after the current token, or NIL if there is none after."
+  (current-token)
+  (if (> Valid-Tokens 1)
+      Next-Token
+      (try-get-token Next-Token)))
+
+(defun advance-token ()
+  (current-token)			;don't know why this is needed
+  "Makes the next token be the current token."
+  (case Valid-Tokens
+    (0 (try-get-token (Current-Token)))
+    (1 (decf Valid-Tokens)
+       (setq Prior-Token (copy-token Current-Token))
+       (try-get-token Current-Token))
+    (2 (setq Prior-Token (copy-token Current-Token))
+       (setq Current-Token (copy-token Next-Token))
+       (decf Valid-Tokens))))
+
+(defparameter XTokenReader 'get-meta-token "Name of tokenizing function")
+
+; *** Get Token
+
+(defun get-token (token) (funcall XTokenReader token))
+
+; 3A (2) Character handling.
+
+; FUNCTIONS DEFINED IN THIS SECTION:
+;
+;       Current-Char, Next-Char, Advance-Char
+
+; *** Current Char, Next Char, Advance Char
+
+(defun Current-Char ()
+  "Returns the current character of the line, initially blank for an unread line."
+  (if (Line-Past-End-P Current-Line) #\Return (Line-Current-Char Current-Line)))
+
+(defun Next-Char ()
+   "Returns the character after the current character, blank if at end of line.
+The blank-at-end-of-line assumption is allowable because we assume that end-of-line
+is a token separator, which blank is equivalent to."
+
+  (if (Line-At-End-P Current-Line) #\Return (Line-Next-Char Current-Line)))
+
+(defun Advance-Char ()
+  "Advances IN-STREAM, invoking Next Line if necessary."
+  (loop (cond ((not (Line-At-End-P Current-Line))
+               (return (Line-Advance-Char Current-Line)))
+              ((next-line in-stream)
+               (return (current-char)))
+              ((return nil)))))
+
+; 3A 3. Line Handling.
+
+; PARAMETERS DEFINED IN THIS SECTION:
+;
+;       Echo-Meta
+
+; *** Next Line
+
+(defparameter Echo-Meta nil                 "T if you want a listing of what has been read.")
+(defparameter Line-Handler 'next-META-line "Who grabs lines for us.")
+
+(defun next-line (&optional (in-stream t)) (funcall Line-Handler in-stream))
+
+(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 (IS-CONSOLE stream) (princ (MKPROMPT)))
+  (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))
+
+#-:CCL
+(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)
+                         (Line-New-Line (make-string 0) Current-Line)
+                         (return nil)))
+              (if (setq Current-Fragment (read-line stream))
+                  (return (read-a-line stream)))))))
+#+:CCL
+(defun read-a-line (&optional (stream t))
+   (let ((line (read-line stream nil nil)))
+      (if (null line)
+           (progn (setq File-Closed t *EOF* t)
+                  (Line-New-Line (make-string 0) Current-Line)
+                   nil)
+          line)))
+
+; *** Print New Line
+
+(defparameter Printer-Line-Stack (make-stack)
+  "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 *terminal-io*))
+  "Makes output listings."
+  (if Read-Quietly (stack-push (copy-tree string) Printer-Line-Stack)
+      (progn (mapc #'(lambda (x) (format strm "; ~A~%" x) (terpri))
+                   (nreverse (stack-store Printer-Line-Stack)))
+             (stack-clear Printer-Line-Stack)
+             (format strm "~&; ~A~%" string))))
+
+; 3B. Error handling
+
+(defparameter errcol nil)
+(defparameter line nil)
+(defparameter count nil)
+
+(defun conversation (x y)
+  (prog (u)
+     a  (reduce-stack-clear)
+        (setq u (namederrset 'spad_reader (conversation1 x y) ))
+        (cond (*eof* (return nil))
+              ((atom u) (go a))
+              ((return (car u))))))
+
+(defparameter ulcasefg nil              "")
+
+(defun conversation1 (firstfun procfun)
+  (prog nil
+     top(cond ((not (Current-Char)) (return nil))
+              ((and (current-token) (next-token)) (go top))
+              ((compfin) (return 't))
+              ((and (funcall firstfun)
+                    (or (funcall procfun (pop-stack-1))))
+               (go top))
+              ((compfin) (return 't)) )
+        (meta-syntax-error)
+        (go top)))
+
+(defun termchr ()  "Is CHR a terminating character?"
+  (position (current-char) " *,;<>()[]/\\"))
+
+(defun compfin () (or (match-string ")fin") (match-string ".FIN")))
+
+(defparameter Meta_Errors_Occurred nil  "Did any errors occur")
+
+(defparameter Meta_Error_Handler 'meta-meta-error-handler)
+
+(defun meta-syntax-error (&optional (wanted nil) (parsing nil))
+  (funcall Meta_Error_Handler wanted parsing))
+
+; 3 C. Constructing parsing procedures
+
+; FUNCTIONS DEFINED IN THIS SECTION:
+;
+;       Make-Parse-Function, GetGenSym
+
+(MAKEPROP 'PROGN 'NARY T)       ; Setting for Make-Parse-Function
+
+(defun make-parse-function (l op)
+   (if (flagp op 'nary) (setq l (make-parse-func-flatten-1 l op nil)))
+   (make-parse-function1 l op))
+
+(defun make-parse-func-flatten (x op)
+  (cond ((atom x) x)
+        ((eq (car x) op) (cons op (make-parse-func-flatten-1 (cdr x) op nil)))
+        (t (cons (make-parse-func-flatten (car x) op) (make-parse-func-flatten (cdr x) op)))))
+
+(defun make-parse-func-flatten-1 (l op r)
+  (let (x)
+    (if (null l)
+        r
+        (make-parse-func-flatten-1
+            (cdr l) op
+            (append r (if (eqcar (setq x (make-parse-func-flatten (car l) op)) op)
+                          (cdr x)
+                          (list x)))))))
+
+(defun make-parse-function1 (l op)
+  (let (x)
+    (case op
+      (plus (cond ((eq 0 (setq x (length (setq l (s- l '(0 (zero))))))) 0)
+                  ((eq 1 x) (car l))
+                  (t `(+ . ,l))))
+      (times (cond ((s* l '(0 (zero))) 0)
+                   ((eq 0 (setq x (length (setq l (s- l '(1 (one))))))) 1)
+                   ((eq 1 x) (car l))
+                   (t `(times . ,l)) ))
+      (quotient (cond ((> (length l) 2) (fail))
+                      ((eq 0 (car l)) 0)
+                      ((eq (cadr l) 1) (car l))
+                      (t `(quotient . ,l)) ))
+      (minus (cond ((cdr l) (fail))
+                   ((numberp (setq x (car l))) (minus x))
+                   ((eqcar x 'minus) (cadr x))
+                   (t `(minus . ,l))  ))
+      (- (cond ((> (length l) 2) (fail))
+                        ((equal (car l) (cadr l)) '(zero))
+                        ((member (car l) '(0 (zero))) (make-parse-function (cdr l) 'minus))
+                        ((member (cadr l) '(0 (zero))) (car l))
+                        ((eqcar (cadr l) 'minus)
+                         (make-parse-function (list (car l) (cadadr l)) 'plus))
+                        (t `(- . ,l)) ))
+      (expt (cond ((> (length l) 2) (fail))
+                  ((eq 0 (cadr l)) 1)
+                  ((eq 1 (cadr l)) (car l))
+                  ((member (car l) '(0 1 (zero) (one))) (car l))
+                  (t `(expt . ,l)) ))
+      (or (cond ((member 't l) ''t)
+                ((eq 0 (setq x (length (setq l (delete nil l))))) nil)
+                ((eq 1 x) (car l))
+                (t `(or . ,l)) ))
+      (|or| (cond ((member 't l) 't)
+                  ((eq 0 (setq x (length (setq l (delete nil l))))) nil)
+                  ((eq 1 x) (car l))
+                  (t `(|or| . ,l)) ))
+      (null (cond ((cdr l) (fail))
+                  ((eqcar (car l) 'null) (cadar l))
+                  ((eq (car l) 't) nil)
+                  ((null (car l)) ''t)
+                  (t `(null . ,l))))
+      (|and| (cond ((eq 0 (setq x (length (setq l (delete 't (delete 'true l)))))) 't)
+                   ((eq 1 x) (car l))
+                   (t `(|and| . ,l)) ))
+      (and (cond ((eq 0 (setq x (length (setq l (delete 't (delete 'true l)))))) ''t)
+                 ((eq 1 x) (car l))
+                 (t `(and . ,l)) ))
+      (progn (cond ((and (not (atom l)) (null (last l)))
+                    (cond ((cdr l) `(progn . ,l))
+                          (t (car l))))
+                   ((null (setq l (delete nil l))) nil)
+                   ((cdr l) `(progn . ,l))
+                   (t (car l)) ))
+      (seq (cond ((eqcar (car l) 'exit) (cadar l))
+                 ((cdr l) `(seq . ,l))
+                 (t (car l))   ))
+      (list (cond ((null l) nil) (t `(list . ,l))))
+      (cons (cond ((cdr l) `(cons . ,l)) (t (car l)) ))
+      (t (cons op l) ))))
+
+(defparameter /genvarlst nil    "??")
+
+(defun transpgvar (metapgvar) (remove-duplicates metapgvar))
+
+(defparameter /gensymlist nil   "List of rule local variables generated by getgensym.")
+
+(defun getgensym (n)
+  "Used to create unique numerically indexed local variables for the use of rules."
+  (loop
+     (let ((m (length /gensymlist)))
+       (if (< m n)
+           (setq /gensymlist (nconc /gensymlist `(,(intern (format nil "G~D" (1+ m))))))
+           (return (nth (1- n) /gensymlist))))))
+
+; 3 D.  Managing rule sets
+
+(defparameter bac nil                   "")
+(defparameter keyfn nil                 "")
+(defparameter /metaoption               "")
+(defparameter tline nil                 "")
+(defparameter rs nil                    "")
+
+(defun getrulefunlists  (rootfun rs)
+  (let* ((metapfx (or (get rootfun 'metapfx) ""))
+         (mainfun (internl metapfx (pname rootfun)))
+         (mainfunstr (pname mainfun))
+         (flnam (internl mainfunstr "FUN"))
+         (pfx-funlist (union (cons mainfun
+                                   (if (atom (eval flnam)) nil (eval flnam)))
+                             (mapcar #'(lambda (x) (internl metapfx (pname x)))
+                                     (assocleft rs))))
+         n unpfx-funlist)
+    (set flnam pfx-funlist)
+    (if (not (lessp (setq n (length metapfx)) 0))
+        (setq unpfx-funlist
+              (mapcar #'(lambda (x) (intern (subseq (copy-symbol (pname x)) n)))
+                       pfx-funlist)))
+    (if unpfx-funlist (list pfx-funlist unpfx-funlist))))
+
+;  4. Tracing routines
+
+(defparameter debugmode 'yes "Can be either YES or NO")
+
+(defun reduction-print (y rule)
+  (format t "~&")
+  (cond ((eq y t) (|sayBrightly| `(|%b| ,rule |%d| " reduced")))
+        (y (|sayBrightlyNT| `(|%b| ,rule |%d|))
+           (format t " reduced ~A~%" y)))
+  y)
+
+#+Symbolics
+(defmacro rtrace (&rest rules)
+  `(compiler-let () .
+        ,(mapcar #'(lambda (x)
+                    (let ((rule (intern (strconc "PARSE-" x))))
+                      `(zl:advise ,rule :around nil nil
+                               (reduction-print :do-it ',rule))))
+                rules)))
+
+#+Symbolics
+(defmacro runtrace () `(zl:unadvise))
+
+(defmacro tracemeta (&rest l) `(trmeta ',l))
+
+(defparameter /depth 0 "Used in Debug.lisp.")
+
+(defun trmeta (l) (setq /depth 0) (mapc #'trmeta1 l))
+
+(defun trmeta1 (x)
+  (let (y)
+  (if (not (fboundp  x))
+      (if (fboundp (setq y (internl $lastprefix (pname x))))
+          (moan (format nil "********* ~S RENAMED AS ~S" x (setq x y)))
+          (croak (format nil  "********* ~S MUST BE GIVEN PREFIX" x))))
+  (/embed-1 x
+   (sublislis
+     (list (pname x) x (gensym))
+     '(nam* fun* argl*)
+     '(lambda (&rest argl*)
+       (prog (v tok)
+         (terpri)
+         (trblanks (* 2 /depth))          (setq /depth (+ 1 /depth))
+         (princ (stringimage /depth))  (princ "<")
+         (princ nam*)              (trargprint argl*)   (princ "/")
+         (princ "chr= ")           (prin1 (Current-Char))
+         (princ "/tok= ")          (prin1 (setq tok (current-symbol)))
+         (princ "/col= ")          (prin1 (line-current-index current-line))
+ ;;      (princ "/icol= ")         (prin1 initcolumn)
+         (cond ( (not nonblank) (go a1)))     (princ "/nblnk= T")
+     a1  ;;(cond (ok (go b1)))               (princ "/ok= NIL")
+     b1  ;;(cond ( (not stackx) (go c1)))   (princ "/stackx= ")
+         ;;(prin1 stackx)
+     c1  (cond ( (not (identp tok)) (go d1)))
+         (princ "/isid= ")
+        ;; (princ (cond (isid "T") (t "NIL")))
+     d1  (princ "/stack= ")            (prin1 (stack-store reduce-stack))
+         (setq v (apply fun* argl*))           (setq /depth (- /depth 1))
+         (terpri)
+         (trblanks (* 2 /depth))          (princ (stringimage (\1+ /depth)))
+         (princ ">")                       (princ nam*)
+         (princ "/chr= ")                  (prin1 (Current-Char))
+         (princ "/tok= ")                  (prin1 (setq tok (current-symbol)))
+         (princ "/col= ")            (prin1 (line-current-index current-line))
+         (if (not nonblank) (go a2))          (princ "/nblnk= ")
+         (princ (if nonblank "T" "NIL"))
+     a2  ;;(if ok (go b2))                   (princ "/ok= ")          (prin1 ok)
+     b2  ;;(if (not stackx) (go c2))        (princ "/stackx1= ")     (prin1 stackx)
+     c2  (if (not (identp tok)) (go d2))
+         (princ "/isid= ")
+        ;; (princ (if isid "T" "NIL"))
+     d2  (princ "/stack= ")            (prin1 (stack-store reduce-stack))
+         (princ "/value= ")         (prin1 v)
+         (return v)))))))
+
+(defun /embed-1 (x y)
+   (princ (strconc (pname x) " embedded"))
+   (terpri)
+   (/embed-q x y))
+
+(defun /embed-q (x y)
+   (setq /embednames (cons x /embednames))
+   (embed x
+          (cond ((eqcar y 'lambda) y)
+                ((eqcar y 'before)
+		 `(lambda ,(cadr y)
+		    (prog2 ,(caddr y) ,(cons 'funcall (cons x (cadr y))))))
+                ((eqcar y 'after)
+		 `(lambda ,(cadr y)
+		    (prog1 ,(cons 'funcall (cons x (cadr y))) ,(caddr y))))))
+   (/embedreply))
+
+(defun /embedreply ()
+  (if (atom (embedded)) '(|none| |embedded|)
+      (append (embedded) (list '|embedded|))))
+
+(defun numofargs (fn) (numberofargs (car (/mdef (cons fn '(x))))))
+
+(defparameter mdeftrace nil             "")
+
+(defun /mdef (x)
+  (let (u)
+    (cond  ((atom x) x)
+           ((or (null (atom (car x))) (not (mbpip (car x))))
+            (mapcar #'/mdef x))
+           ((equal x (setq u (mdef (car x) x))) x)
+           (mdeftrace (print x) (princ " --> ") (print u) (/mdef u))
+           ((/mdef u)))))
+
+(defun trargprint (l) (mapc #'(lambda (x) (princ " / ") (prin1 x)) l))
+
+(defun trblanks (n) (do ((i 1 (1+ i))) ((> i n)) (princ " ")))
+
+;       5. Routines for inspecting and resetting total I/O system state
+;
+; The package largely assumes that:
+;
+;       A. One I/O stream pair is in effect at any moment.
+;       B. There is a Current Line
+;       C. There is a Current Token and a Next Token
+;       D. There is a Reduction Stack
+;
+; This state may be examined and reset with the procedures IOSTAT and IOCLEAR.
+
+(defun IOStat ()
+  "Tell me what the current state of the parsing world is."
+  ;(IOStreams-show)
+  (current-line-show)
+  (if (or $BOOT $SPAD) (next-lines-show))
+  (token-stack-show)
+  ;(reduce-stack-show)
+  nil)
+
+(defun IOClear (&optional (in t) (out t))
+  ;(IOStreams-clear in out)
+  (input-clear)
+  (current-line-clear)
+  (token-stack-clear)
+  (reduce-stack-clear)
+  (if (or $BOOT $SPAD) (next-lines-clear))
+  nil)
+
+;; auxiliary functions needed by the parser
+
+(defun char-eq (x y) (char= (character x) (character y)))
+
+(defun char-ne (x y) (char/= (character x) (character y)))
+
+(Defun FLOATEXPID (X &aux S)
+  (if (AND (IDENTP X) (char= (char-upcase (ELT (SETQ S (PNAME X)) 0)) #\E)
+           (> (LENGTH S) 1)
+           (SPADREDUCE AND 0 (COLLECT (STEP I 1 1 (MAXINDEX S))
+                                      (DIGITP (ELT S I)))))
+       (READ-FROM-STRING S t nil :start 1)
+    NIL))
+
+(defun |getToken| (x) (if (EQCAR x '|elt|) (third x) x))
+
+(defun |dollarTran| (dom rand)
+       (let ((eltWord (if |$InteractiveMode| '|$elt| '|elt|)))
+         (if (and (not (atom rand)) (cdr rand))
+             (cons (list eltWord dom (car rand)) (cdr rand))
+             (list eltWord dom rand))))
+@
+\eject
+\begin{thebibliography}{99}
+\bibitem{1} nothing
+\end{thebibliography}
+\end{document}
-- 
cgit v1.2.3