diff options
author | dos-reis <gdr@axiomatics.org> | 2007-09-19 15:30:04 +0000 |
---|---|---|
committer | dos-reis <gdr@axiomatics.org> | 2007-09-19 15:30:04 +0000 |
commit | 1d71a43cca77e1576cc1568298d5886a60c9b884 (patch) | |
tree | 270a5e091dc621fd0023f2261938cea235b0cbe9 /src/interp/parsing.lisp | |
parent | 1ee7a0030053e2447302d8157b9d3356a54e9b3a (diff) | |
download | open-axiom-1d71a43cca77e1576cc1568298d5886a60c9b884.tar.gz |
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.
Diffstat (limited to 'src/interp/parsing.lisp')
-rw-r--r-- | src/interp/parsing.lisp | 523 |
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) |