path: root/src/interp/parsing.lisp

;; 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.


; 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
;
;       BOOTLEX.LISP:  Boot file handling, auxiliary parsing actions and tokenizing
;       NEWMETA.LISP:  Boot parsing

;; This is a horrible hack to work around a horrible bug in GCL
;; as reported here:
;;    http://lists.gnu.org/archive/html/gcl-devel/2007-08/msg00004.html
;; 
#+(and :gcl (not :common-lisp)) (in-package "VMLISP")
#+(and :gcl (not :common-lisp)) (in-package "AxiomCore")

(import-module "boot-pkg")
(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))))