1 files changed, 7 insertions, 516 deletions
diff --git a/src/interp/parsing.lisp b/src/interp/parsing.lisp
index d607ce93..54ee8efd 100644
--- a/src/interp/parsing.lisp
+++ b/src/interp/parsing.lisp
@@ -74,15 +74,9 @@
 ;       NEWMETA.LISP:  Boot parsing
 
 
-(import-module "vmlisp")
+(import-module "metalex")
 (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")
@@ -97,218 +91,6 @@
           (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).
 
@@ -316,7 +98,7 @@ NonBlank is true if the token is not preceded by a blank."
 
 ; FUNCTIONS DEFINED IN THIS SECTION:
 ;
-;       Star, Bang, Must, Optional, Action, Sequence
+;       Star, Bang, Must, Optional, Action
 
 (defmacro Star (lab prod)
 
@@ -377,34 +159,6 @@ the stack, then stack a NIL. Return the value of prod."
 
 (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:
@@ -464,200 +218,7 @@ the stack, then stack a NIL. Return the value of prod."
   (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.
 
@@ -665,75 +226,10 @@ is a token separator, which blank is equivalent to."
 ;
 ;       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)
@@ -762,13 +258,6 @@ Symbolics read-line returns embedded newlines in a c-m-Y.")
 
 (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:
@@ -893,7 +382,9 @@ Symbolics read-line returns embedded newlines in a c-m-Y.")
     (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)))
+              (mapcar #'(lambda (x) 
+			  (intern (subseq 
+				   (symbol-name (copy-symbol (pname x))) n)))
                        pfx-funlist)))
     (if unpfx-funlist (list pfx-funlist unpfx-funlist))))
 
@@ -977,6 +468,8 @@ Symbolics read-line returns embedded newlines in a c-m-Y.")
    (terpri)
    (/embed-q x y))
 
+(defvar /embednames)
+
 (defun /embed-q (x y)
    (setq /embednames (cons x /embednames))
    (embed x
@@ -993,8 +486,6 @@ Symbolics read-line returns embedded newlines in a c-m-Y.")
   (if (atom (embedded)) '(|none| |embedded|)
       (append (embedded) (list '|embedded|))))
 
-(defun numofargs (fn) (numberofargs (car (/mdef (cons fn '(x))))))
-
 (defparameter mdeftrace nil             "")
 
 (defun /mdef (x)