2007-09-19 Gabriel Dos Reis <gdr@cs.tamu.edu>

	* Makefile.pamphlet (all-interpsys): Now depend on all-depsys.

src/interp/
2007-09-19  Gabriel Dos Reis  <gdr@cs.tamu.edu>

	* util.lisp.pamphlet ($directory-list): Move to sys-globals.boot.
	($library-directory-list): Likewise.
	* spad.lisp.pamphlet: Import "bootlex".
	* preparse.lisp.pamphlet: Import "fnewmeta".
	* postprop.lisp: Import "macros".
	* postpar.boot.pamphlet: Import "postprop".
	* nlib.lisp.pamphlet (rdefiostream): Define unconditionally.
	(get-io-index-stream): Likewise.
	(makedir): Likewise.
	(get-directory-list): Don't use $current-diretory.
	($filetype-table): Move to sys-constants.boot.
	* patches.lisp.pamphlet ($current-directory): Remove.
	(|cd|): Simplify implementation.
	* newaux.lisp.pamphlet: Import "macros".
	(|PARSE-NewKEY|): Define.
	* metalex.lisp: Move various file, line, stack, character
	utilities to here.
	* macros.lisp.pamphlet (NREVERSE0): Move to sys-macros.lisp.  Tidy.
	* fnewmeta.lisp.pamphlet: Import "parsing".
	* comp.lisp: Import "macros".
	* def.lisp: Likewise.
	(B-MDEF): Fix thinko.
	* bootlex.lisp: Import "preparse", "def", and "nlib".
	(BOOT-LINE-STACK): Move to metalex.lisp.
	(NEXT-LINES-CLEAR): Likewise.
	(NEXT-LINES-SHOW): Likewise.
	(XCAPE): Likewise.
	(KEYWORDS): Likewise.
	* Makefile.pamphlet (${DEPSYS}): Now have all Lisp in compiled
	form and load them.  
	* bookvol5.pamphlet ($current-directory): Remove.

1 files changed, 541 insertions, 3 deletions

diff --git a/src/interp/metalex.lisp b/src/interp/metalex.lisp
index f718ba1d..aa5be9ba 100644
--- a/src/interp/metalex.lisp
+++ b/src/interp/metalex.lisp
@@ -39,8 +39,409 @@
 ;               3. META Token Handling
 ;               4. META Token Parsing Actions
 ;               5. META Error Handling
- 
+
+(IMPORT-MODULE "macros") 
 (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.")
+
+
+; 1. Data structure declarations (defstructs) for parsing objects
+;
+;               A. Line Buffer
+;               B. Stack
+;               C. Token
+;               D. Reduction
+
+; 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))
+
+
+; 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)))
+
+; *** 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))
+
+
+(defparameter Boot-Line-Stack nil       "List of lines returned from PREPARSE.")
+
+(defun Next-Lines-Clear () (setq Boot-Line-Stack nil))
+
+(defun Next-Lines-Show ()
+  (and Boot-Line-Stack (format t "Currently preparsed lines are:~%~%"))
+  (mapcar #'(lambda (line)
+              (format t "~&~5D> ~A~%" (car line) (cdr Line)))
+          Boot-Line-Stack))
+
+
+; 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))
+
+(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)))))))
+
+; *** 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))))
+
+
+; 3A (2) Character handling.
+
+; FUNCTIONS DEFINED IN THIS SECTION:
+;
+;       Current-Char, Next-Char, Advance-Char
+
+; *** Current Char, Next Char, Advance Char
+
+(defparameter xcape #\_ "Escape character for Boot code.")
+
+(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)))))
+
+; 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)
+
+; *** 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 Token-Print (token)
+  (format out-stream "(token (symbol ~S) (type ~S))~%"
+          (Token-Symbol token) (Token-Type token)))
+
+(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))
+
+
+
+; 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))))
+
  
 ; *** 2. META Line Handling
  
@@ -95,12 +496,142 @@ empty (if File-Closed (return nil))
 ; BSTRING: "[" ... "]*"
 ; ID: letters, _ and then numbers
 ; NUMBER: digits, ., digits, e, +-, digits
+
+; 3A (1) Token Handling.
+
+; Tokens are acquired from a stream of characters.  Lexical analysis is performed
+; by the functiond Get Token.  One-token lookahead is maintained in variables
+; 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))
+
+
+(defconstant Keywords 
+  '(|or| |and| |isnt| |is| |otherwise| |when| |where|
+    |has| |with| |add| |case| |in| |by| |pretend| |mod|
+    |exquo| |div| |quo| |else| |rem| |then| |suchthat|
+    |if| |yield| |iterate| |from| |exit| |leave| |return|
+    |not| |unless| |repeat| |until| |while| |for| |import|)
+
+"Alphabetic literal strings occurring in the New Meta code constitute
+keywords.   These are recognized specifically by the AnyId production,
+GET-BOOT-IDENTIFIER will recognize keywords but flag them
+as keywords.")
+
+
+
+(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?"))))
  
 (defun-parse-token STRING)
 (defun-parse-token BSTRING)
 (defun-parse-token IDENTIFIER)
 (defun-parse-token NUMBER)
  
+; Parsing of operator tokens depends on tables initialized by BOTTOMUP.LISP
+
+(defun-parse-token SPADSTRING)
+(defun-parse-token KEYWORD)
+(defun-parse-token ARGUMENT-DESIGNATOR)
+
 ; Meta tokens fall into the following categories:
 ;
 ;               Number
@@ -232,6 +763,8 @@ special character be the atom whose print name is the character itself."
  
 ; *** 4. META Auxiliary Parsing Actions
  
+(defparameter Meta_Prefix nil)
+ 
 (defun make-defun (nametok vars body)
   (let ((name (INTERN (STRCONC |META_PREFIX| nametok))))
     (if vars
@@ -246,8 +779,6 @@ special character be the atom whose print name is the character itself."
 (defun print-package (package)
   (format out-stream "~&~%(IN-PACKAGE ~S )~%~%" package))
  
-(defparameter Meta_Prefix nil)
- 
 (defun set-prefix (prefix)  (setq META_PREFIX prefix))
  
 (defun print-rule (x)  (print x out-stream) (format out-stream "~%~%"))
@@ -255,6 +786,13 @@ special character be the atom whose print name is the character itself."
 ; *** 5. META Error Handling
 
 (defparameter $num_of_meta_errors 0)
+
+(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))
  
 (defun meta-meta-error-handler (&optional (wanted nil) (parsing nil))
   "Print syntax error indication, underline character, scrub line."