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/metalex.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/metalex.lisp')
-rw-r--r-- | src/interp/metalex.lisp | 544 |
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." |