diff --git a/changelog b/changelog index 6d86d66..12f813e 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,5 @@ +20101001 tpd src/axiom-website/patches.html 20101001.01.tpd.patch +20101001 tpd src/interp/parsing.lisp cleanup and reformat 20100930 tpd src/axiom-website/patches.html 20100930.02.tpd.patch 20100930 tpd books/bookvol9 document compiler 20100930 tpd books/bookvol5 document compiler related routines diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index a6a02f0..7c2e4ed 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3172,5 +3172,7 @@ books/bookvol9 document compiler
books/bookvolbib add Jenks [Jen69]
20100930.02.tpd.patch books/bookvol9.pamphlet treeshake compiler
+20101001.01.tpd.patch +src/interp/parsing.lisp cleanup and reformat
diff --git a/src/interp/parsing.lisp.pamphlet b/src/interp/parsing.lisp.pamphlet index f9b3238..687d322 100644 --- a/src/interp/parsing.lisp.pamphlet +++ b/src/interp/parsing.lisp.pamphlet @@ -9,58 +9,29 @@ \eject \tableofcontents \eject -\section{License} -<<*>>= - -; 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. -; - -; 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 +<<*>>= (in-package "BOOT") -; 0. Current I/O Stream definition - +@ +\chapter{META/LISP Parser Generator and Lexical Analysis Utilities (Parsing)} +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. + +\section{Current I/O Stream definition} +<<*>>= (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)) + (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-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)) @@ -68,31 +39,21 @@ (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 - +@ +\section{Data structure declarations (defstructs) for parsing objects} +<<*>>= +@ +\subsection{Line Buffer} +The philosophy of lines is that +\begin{itemize} +\item NEXT LINE will always get you a non-blank line or fail. +\item Every line is terminated by a blank character. +\end{itemize} +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. +<<*>>= (defstruct Line "Line of input file to parse." (Buffer (make-string 0) :type string) (Current-Char #\Return :type character) @@ -106,26 +67,28 @@ (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))) + (setf (Line-Buffer l) (make-string 0)) + (setf (Line-Current-Char l) #\Return) + (setf (Line-Current-Index l) 1) + (setf (Line-Last-Index l) 0) + (setf (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)))) + (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))))) + (setf (Line-Last-Index line) (1- (length string))) + (setf (Line-Current-Index line) 0) + (setf (Line-Current-Char line) + (or (and (> (length string) 0) (elt string 0)) #\Return)) + (setf (Line-Buffer line) string) + (setf (Line-Number line) (or linenum (1+ (Line-Number line))))) (defun Line-Advance-Char (line) (setf (Line-Current-Char line) @@ -142,13 +105,9 @@ "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 - +@ +\subsection{Stack} +<<*>>= (defstruct Stack "A stack" (Store nil) ; contents of the stack (Size 0) ; number of elements in Store @@ -159,96 +118,93 @@ ) (defun stack-load (list stack) - (setf (stack-store stack) list - (stack-size stack) (length list) - (stack-top stack) (car list))) + (setf (stack-store stack) list) + (setf (stack-size stack) (length list)) + (setf (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)) + (setf (stack-store stack) nil) + (setf (stack-size stack) 0) + (setf (stack-top stack) nil) + (setf (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) + (setf (stack-top stack) x) + (setf (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)))) + (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 - +@ +\subsection{Token} +<<*>>= (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." + 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)") + +(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) + (setf (token-symbol token) symbol) + (setf (token-type token) type) + (setf (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 -; - +@ +\subsection{Reduction} +<<*>>= (defstruct (Reduction (:type list)) -"A reduction of a rule is any S-Expression the rule chooses to stack." + "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 - +@ +\section{Recursive descent parsing support routines} +<<*>>= +@ +\subsection{Stacking and retrieving reductions of rules.} +<<*>>= (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.~%")))) + (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) + (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)) @@ -280,137 +236,106 @@ NonBlank is true if the token is not preceded by a blank." (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 +@ +\subsection{Applying metagrammatical elements of a production (e.g., Star).} +\begin{itemize} +\item {\bf Must} means that if it is not present in the token stream, +it is a syntax error. +\item {\bf 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). +\item {\bf 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. +\item {\bf 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. +\end{itemize} +<<*>>= (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." - + "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)))) + (if (not ,prod) (return nil)) +loop + (if (not ,prod) + (let* ((newstacksize (stack-size reduce-stack)) + (number-of-new-reductions (- newstacksize oldstacksize))) + (if (> number-of-new-reductions 0) + (return (do ((i 0 (1+ i)) (accum nil)) + ((= i number-of-new-reductions) + (Push-Reduction ',lab 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))))) + "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) + (let* ((prodvalue ,prod) (updated (stack-updated reduce-stack))) + (unless updated (push-reduction ',lab nil)) + 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. + `(and ,(pop subrules) . + ,(append (mapcar #'(lambda (x) (list 'must x)) subrules) + (if actions `((progn . ,(append actions '(t)))))))) +@ +\section{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)))) + (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 - +@ +\subsection{Manipulating the token stack and reading tokens} +This section is broken up into 3 levels: +\begin{itemize} +\item String grabbing: Match String, Match Advance String +\item Token handling: Current Token, Next Token, Advance Token +\item Character handling: Current Char, Next Char, Advance Char +\item Line handling: Next Line, Print Next Line +\item Random Stuff +\end{itemize} +\subsubsection{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). +<<*>>= (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 + (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))))) + (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." @@ -418,137 +343,138 @@ the stack, then stack a NIL. Return the value of prod." (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)))) + (when y + (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. - +@ +\subsubsection{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 ,(intern (concatenate 'string "PARSE-" (string token))) () + (let* ((tok (match-current-token ',token)) + (symbol (if tok (token-symbol tok)))) + (when tok + (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) - ))) + (if (= Valid-Tokens 0) + (format t "~%There are no valid tokens.~%") + (format t "~%The number of valid tokens is ~S.~%" Valid-Tokens)) + (when (> Valid-Tokens 0) + (format t "The current token is~%") + (describe current-token)) + (when (> Valid-Tokens 1) + (format t "The next token is~%") + (describe next-token)) + (when (token-type prior-token) + (format t "The prior token was~%") + (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))) + `(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 +@ +{\bf Unget-Tokens} +<<*>>= (defun quote-if-string (token) - (if token ;only use token-type on non-null tokens + (when 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)) + (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 (string= pack "BOOT") + (escape-keywords (underscore id) (token-symbol token)) + (concatenate 'string + (underscore pack) "'" (underscore id))) + id))) + (t (token-symbol token))))) (defun escape-keywords (pname id) (if (member id keywords) - (concatenate 'string "_" pname) - pname)) + (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 'string-char - :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))) + (if (every #'alpha-char-p string) + string + (let* ((size (length string)) + (out-string (make-array (* 2 size) + :element-type 'string-char + :fill-pointer 0)) + next-char) + (dotimes (i size) + (setq next-char (char string i)) + (unless (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 " ")))) + (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?")))) + (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 +@ +{\bf 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))) + (when (and token (eq (token-type token) type)) + (if symbol + (when (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." @@ -558,36 +484,41 @@ the stack, then stack a NIL. Return the value of prod." "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 +@ +{\bf Current Token, Next Token, Advance Token} +<<*>>= (defun try-get-token (token) - (let ((tok (get-token token))) - (if tok (progn (incf Valid-Tokens) token)))) + (let ((tok (get-token token))) + (when tok + (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)))) + (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))) + (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))) + (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." + (current-token) ;don't know why this is needed (case Valid-Tokens (0 (try-get-token (Current-Token))) (1 (decf Valid-Tokens) @@ -599,57 +530,59 @@ the stack, then stack a NIL. Return the value of prod." (defparameter XTokenReader 'get-meta-token "Name of tokenizing function") -; *** Get Token +@ +{\bf 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 - +@ +\subsubsection{Character handling} +<<*>>= (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))) + "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))) + 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 + (loop + (cond + ((not (Line-At-End-P Current-Line)) + (return (Line-Advance-Char Current-Line))) + ((next-line in-stream) + (return (current-char))) + ((return nil))))) +@ +\subsubsection{Line handling} +<<*>>= -(defun next-line (&optional (in-stream t)) (funcall Line-Handler in-stream)) +(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 'string-char - :adjustable t :initial-contents s)))) + (if (adjustable-array-p s) + s + (make-array (array-dimensions s) :element-type 'string-char + :adjustable t :initial-contents s))) (defun get-a-line (stream) - (if (IS-CONSOLE stream) (princ (MKPROMPT))) + (when (is-console stream) (princ (mkprompt))) (let ((ll (read-a-line stream))) - (if (stringp ll) (make-string-adjustable ll) ll))) + (if (stringp ll) + (make-string-adjustable ll) + ll))) (defparameter Current-Fragment nil "A string containing remaining chars from readline; needed because @@ -657,23 +590,21 @@ 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))))))) -; *** Print New Line + (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 + (when (stream-eof in-stream) + (setq File-Closed t *EOF* t) + (Line-New-Line (make-string 0) Current-Line) + (return nil)) + (when (setq Current-Fragment (read-line stream)) + (return (read-a-line stream))))))) (defparameter Printer-Line-Stack (make-stack) "Stack of output listing lines waiting to print. [local to PRINT-NEW-LINE]") @@ -683,44 +614,54 @@ Symbolics read-line returns embedded newlines in a c-m-Y.") (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)))) + (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 +@ +\subsection{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)))))) + (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 "") +(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?" + (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"))) +(defun compfin () + (or (match-string ")fin") (match-string ".FIN"))) (defparameter Meta_Errors_Occurred nil "Did any errors occur") @@ -729,203 +670,247 @@ Symbolics read-line returns embedded newlines in a c-m-Y.") (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 +@ +\subsection{Constructing parsing procedures} +<<*>>= +; (MAKEPROP 'PROGN 'NARY T) ; Setting for Make-Parse-Function +(eval-when (eval load) + (setf (get 'progn 'nary) t)) (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)) + (when (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))))) + (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))))))) + (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 "??") - -(defparameter /gensymlist nil "List of rule local variables generated by getgensym.") + (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 "??") + +(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)))))) + "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 +@ +\subsection{Managing rule sets} +<<*>>= +(defparameter bac nil) -(defparameter bac nil "") -(defparameter keyfn nil "") -(defparameter /metaoption "") -(defparameter tline nil "") -(defparameter rs 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)))) + (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 + (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)))) +@ +\section{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))) + (format t "~&") + (cond + ((eq y t) (|sayBrightly| `(|%b| ,rule |%d| " reduced"))) + (y (|sayBrightlyNT| `(|%b| ,rule |%d|)) (format t " reduced ~A~%" y))) + y) (defparameter /depth 0 "Used in Debug.lisp.") (defun /embed-1 (x y) - (princ (strconc (pname x) " embedded")) - (terpri) - (/embed-q 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)) + (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|)))) + (if (atom (embedded)) + '(|none| |embedded|) + (append (embedded) (list '|embedded|)))) (defun numofargs (fn) (numberofargs (car (/mdef (cons fn '(x)))))) -(defparameter mdeftrace nil "") +(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))))) + (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. +@ +\section{Routines for inspecting and resetting total I/O system state} +The package largely assumes that: +\begin{itemize} +\item One I/O stream pair is in effect at any moment. +\item There is a Current Line +\item There is a Current Token and a Next Token +\item There is a Reduction Stack +\end{itemize} +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) @@ -944,6 +929,19 @@ Symbolics read-line returns embedded newlines in a c-m-Y.") (if (or $BOOT $SPAD) (next-lines-clear)) nil) +@ +\subsection{Meta file handling, auxiliary parsing actions and tokenizing} +<<*>>= +@ +\subsection{Boot file handling, auxiliary parsing actions and tokenizing} +<<*>>= +@ +\subsection{Boot parsing} +<<*>>= +@ + +<<*>>= + ;; auxiliary functions needed by the parser (defun char-eq (x y) (char= (character x) (character y))) @@ -972,8 +970,8 @@ bootlex (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)) + (format t "~&~5D> ~A~%" (car line) (cdr Line))) + Boot-Line-Stack)) ; *** 1. BOOT file handling @@ -988,29 +986,29 @@ bootlex (defun print-defun (name body) (let* ((sp (assoc 'vmlisp::compiler-output-stream vmlisp::optionlist)) - (st (if sp (cdr sp) *standard-output*))) + (st (if sp (cdr sp) *standard-output*))) (if (and (is-console st) (symbolp name) (fboundp name) - (not (compiled-function-p (symbol-function name)))) - (compile name)) + (not (compiled-function-p (symbol-function name)))) + (compile name)) (when (or |$PrettyPrint| (not (is-console st))) - (print-full body st) (force-output st)))) + (print-full body st) (force-output st)))) (defun boot-parse-1 (in-stream - &aux - (Echo-Meta nil) - (current-fragment nil) - ($INDEX 0) - ($LineList nil) - ($EchoLineStack nil) - ($preparse-last-line nil) - ($BOOT T) - (*EOF* NIL) - (OPTIONLIST NIL)) + &aux + (Echo-Meta nil) + (current-fragment nil) + ($INDEX 0) + ($LineList nil) + ($EchoLineStack nil) + ($preparse-last-line nil) + ($BOOT T) + (*EOF* NIL) + (OPTIONLIST NIL)) (declare (special echo-meta *comp370-apply* *EOF* File-Closed - $index $linelist $echolinestack $preparse-last-line)) + $index $linelist $echolinestack $preparse-last-line)) (init-boot/spad-reader) (let* ((Boot-Line-Stack (PREPARSE in-stream)) - (parseout (prog2 (|PARSE-Expression|) (pop-stack-1)) ) ) + (parseout (prog2 (|PARSE-Expression|) (pop-stack-1)) ) ) ;(setq parseout (|new2OldLisp| parseout)) ; (setq parseout (DEF-RENAME parseout)) ; (DEF-PROCESS parseout) @@ -1018,48 +1016,48 @@ bootlex ;; note that this is no longer called or used. Boot has been removed. (defun boot (&optional - (*boot-input-file* nil) - (*boot-output-file* nil) - &aux - (Echo-Meta t) - ($BOOT T) - (|$InteractiveMode| NIL) - (XCape #\_) - (File-Closed NIL) - (*EOF* NIL) - (OPTIONLIST NIL) - (*fileactq-apply* (function print-defun)) - (*comp370-apply* (function print-defun))) + (*boot-input-file* nil) + (*boot-output-file* nil) + &aux + (Echo-Meta t) + ($BOOT T) + (|$InteractiveMode| NIL) + (XCape #\_) + (File-Closed NIL) + (*EOF* NIL) + (OPTIONLIST NIL) + (*fileactq-apply* (function print-defun)) + (*comp370-apply* (function print-defun))) (declare (special echo-meta *comp370-apply* *EOF* File-Closed XCape)) (init-boot/spad-reader) (with-open-stream (in-stream (if *boot-input-file* (open *boot-input-file* :direction :input) - *standard-input*)) + *standard-input*)) (initialize-preparse in-stream) (with-open-stream (out-stream (if *boot-output-file* - (open *boot-output-file* :direction :output) - #-:cmulisp (make-broadcast-stream *standard-output*) - #+:cmulisp *standard-output* - )) + (open *boot-output-file* :direction :output) + #-:cmulisp (make-broadcast-stream *standard-output*) + #+:cmulisp *standard-output* + )) (when *boot-output-file* - (format out-stream "~&;;; -*- Mode:Lisp; Package:Boot -*-~%~%") - (print-package "BOOT")) + (format out-stream "~&;;; -*- Mode:Lisp; Package:Boot -*-~%~%") + (print-package "BOOT")) (loop (if (and (not File-Closed) - (setq Boot-Line-Stack (PREPARSE in-stream))) - (progn - (|PARSE-Expression|) - (let ((parseout (pop-stack-1)) ) - (setq parseout (|new2OldLisp| parseout)) - (setq parseout (DEF-RENAME parseout)) - (let ((*standard-output* out-stream)) - (DEF-PROCESS parseout)) - (format out-stream "~&") - (if (null parseout) (ioclear)) )) - (return nil))) + (setq Boot-Line-Stack (PREPARSE in-stream))) + (progn + (|PARSE-Expression|) + (let ((parseout (pop-stack-1)) ) + (setq parseout (|new2OldLisp| parseout)) + (setq parseout (DEF-RENAME parseout)) + (let ((*standard-output* out-stream)) + (DEF-PROCESS parseout)) + (format out-stream "~&") + (if (null parseout) (ioclear)) )) + (return nil))) (if *boot-input-file* - (format out-stream ";;;Boot translation finished for ~a~%" - (namestring *boot-input-file*))) + (format out-stream ";;;Boot translation finished for ~a~%" + (namestring *boot-input-file*))) (IOClear in-stream out-stream))) T) @@ -1078,9 +1076,9 @@ bootlex (close SPADERRORSTREAM) (SETQ IN-STREAM STRM) (OR (EQUAL #(0 0 0) $SPAD_ERRORS) - (|sayBrightly| (LIST '|%b| (ELT $SPAD_ERRORS 0) '|%d| '|syntax errors| - '|%l| '|%b| (ELT $SPAD_ERRORS 1) '|%d| '|precompilation errors| - '|%l| '|%b| (ELT $SPAD_ERRORS 2) '|%d| '|semantic errors| '|%l|))) + (|sayBrightly| (LIST '|%b| (ELT $SPAD_ERRORS 0) '|%d| '|syntax errors| + '|%l| '|%b| (ELT $SPAD_ERRORS 1) '|%d| '|precompilation errors| + '|%l| '|%b| (ELT $SPAD_ERRORS 2) '|%d| '|semantic errors| '|%l|))) (+ (ELT $SPAD_ERRORS 0) (ELT $SPAD_ERRORS 1) (ELT $SPAD_ERRORS 2)))) (defun READBOOT () @@ -1102,16 +1100,16 @@ bootlex "Get next line, trimming trailing blanks and trailing comments. One trailing blank is added to a non-blank line to ease between-line -processing for Next Token (i.e., blank takes place of return). Returns T +processing for Next Token (i.e., blank takes place of return). Returns T if it gets a non-blank line, and NIL at end of stream." (if Boot-Line-Stack (let ((Line-Number (caar Boot-Line-Stack)) - (Line-Buffer (suffix #\Space (cdar Boot-Line-Stack)))) - (pop Boot-Line-Stack) - (Line-New-Line Line-Buffer Current-Line Line-Number) - (setq |$currentLine| (setq LINE Line-Buffer)) - Line-Buffer))) + (Line-Buffer (suffix #\Space (cdar Boot-Line-Stack)))) + (pop Boot-Line-Stack) + (Line-New-Line Line-Buffer Current-Line Line-Number) + (setq |$currentLine| (setq LINE Line-Buffer)) + Line-Buffer))) ; *** 3. BOOT Token Handling *** @@ -1126,53 +1124,53 @@ Otherwise, get a .. identifier." (if (not (boot-skip-blanks)) nil (let ((token-type (boot-token-lookahead-type (current-char)))) - (case token-type - (eof (token-install nil '*eof token nonblank)) - (escape (advance-char) - (get-boot-identifier-token token t)) - (argument-designator (get-argument-designator-token token)) - (id (get-boot-identifier-token token)) - (num (get-number-token token)) - (string (get-SPADSTRING-token token)) - (special-char (get-special-token token)) - (t (get-gliph-token token token-type)))))) + (case token-type + (eof (token-install nil '*eof token nonblank)) + (escape (advance-char) + (get-boot-identifier-token token t)) + (argument-designator (get-argument-designator-token token)) + (id (get-boot-identifier-token token)) + (num (get-number-token token)) + (string (get-SPADSTRING-token token)) + (special-char (get-special-token token)) + (t (get-gliph-token token token-type)))))) (defun boot-skip-blanks () (setq nonblank t) (loop (let ((cc (current-char))) - (if (not cc) (return nil)) - (if (eq (boot-token-lookahead-type cc) 'white) - (progn (setq nonblank nil) (if (not (advance-char)) (return nil))) - (return t))))) + (if (not cc) (return nil)) + (if (eq (boot-token-lookahead-type cc) 'white) + (progn (setq nonblank nil) (if (not (advance-char)) (return nil))) + (return t))))) (defun boot-token-lookahead-type (char) "Predicts the kind of token to follow, based on the given initial character." - (cond ((not char) 'eof) - ((char= char #\_) 'escape) - ((and (char= char #\#) (digitp (next-char))) 'argument-designator) - ((digitp char) 'num) - ((and (char= char #\$) $boot - (alpha-char-p (next-char))) 'id) - ((or (char= char #\%) (char= char #\?) - (char= char #\!) (alpha-char-p char)) 'id) - ((char= char #\") 'string) - ((member char - '(#\Space #\Tab #\Return) - :test #'char=) 'white) - ((get (intern (string char)) 'Gliph)) - (t 'special-char))) + (cond ((not char) 'eof) + ((char= char #\_) 'escape) + ((and (char= char #\#) (digitp (next-char))) 'argument-designator) + ((digitp char) 'num) + ((and (char= char #\$) $boot + (alpha-char-p (next-char))) 'id) + ((or (char= char #\%) (char= char #\?) + (char= char #\!) (alpha-char-p char)) 'id) + ((char= char #\") 'string) + ((member char + '(#\Space #\Tab #\Return) + :test #'char=) 'white) + ((get (intern (string char)) 'Gliph)) + (t 'special-char))) (defun get-argument-designator-token (token) (advance-char) (get-number-token token) (token-install (intern (strconc "#" (format nil "~D" (token-symbol token)))) - 'argument-designator token nonblank)) + 'argument-designator token nonblank)) (defvar 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|) + |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|) @@ -1186,72 +1184,72 @@ as keywords.") or an alphabetic, followed by any number of escaped characters, digits, or the chracters ?, !, ' or %" (prog ((buf (make-adjustable-string 0)) - (default-package NIL)) + (default-package NIL)) (suffix (current-char) buf) (advance-char) id (let ((cur-char (current-char))) - (cond ((char= cur-char XCape) - (if (not (advance-char)) (go bye)) - (suffix (current-char) buf) - (setq escaped? t) - (if (not (advance-char)) (go bye)) - (go id)) - ((and (null default-package) - (char= cur-char #\')) - (setq default-package buf) - (setq buf (make-adjustable-string 0)) - (if (not (advance-char)) (go bye)) - (go id)) - ((or (alpha-char-p cur-char) - (digitp cur-char) - (member cur-char '(#\% #\' #\? #\!) :test #'char=)) - (suffix (current-char) buf) - (if (not (advance-char)) (go bye)) - (go id)))) + (cond ((char= cur-char XCape) + (if (not (advance-char)) (go bye)) + (suffix (current-char) buf) + (setq escaped? t) + (if (not (advance-char)) (go bye)) + (go id)) + ((and (null default-package) + (char= cur-char #\')) + (setq default-package buf) + (setq buf (make-adjustable-string 0)) + (if (not (advance-char)) (go bye)) + (go id)) + ((or (alpha-char-p cur-char) + (digitp cur-char) + (member cur-char '(#\% #\' #\? #\!) :test #'char=)) + (suffix (current-char) buf) + (if (not (advance-char)) (go bye)) + (go id)))) bye (if (and (stringp default-package) - (or (not (find-package default-package)) ;; not a package name - (every #'(lambda (x) (eql x #\')) buf))) ;;token ends with '' - (setq buf (concatenate 'string default-package "'" buf) - default-package nil)) + (or (not (find-package default-package)) ;; not a package name + (every #'(lambda (x) (eql x #\')) buf))) ;;token ends with '' + (setq buf (concatenate 'string default-package "'" buf) + default-package nil)) (setq buf (intern buf (or default-package "BOOT"))) (return (token-install - buf - (if (and (not escaped?) - (member buf Keywords :test #'eq)) - 'keyword 'identifier) - token - nonblank)))) + buf + (if (and (not escaped?) + (member buf Keywords :test #'eq)) + 'keyword 'identifier) + token + nonblank)))) (defun get-gliph-token (token gliph-list) (prog ((buf (make-adjustable-string 0))) - (suffix (current-char) buf) - (advance-char) + (suffix (current-char) buf) + (advance-char) loop (setq gliph-list (assoc (intern (string (current-char))) gliph-list)) - (if gliph-list - (progn (suffix (current-char) buf) - (pop gliph-list) - (advance-char) - (go loop)) - (let ((new-token (intern buf))) - (return (token-install (or (get new-token 'renametok) new-token) - 'gliph token nonblank)))))) + (if gliph-list + (progn (suffix (current-char) buf) + (pop gliph-list) + (advance-char) + (go loop)) + (let ((new-token (intern buf))) + (return (token-install (or (get new-token 'renametok) new-token) + 'gliph token nonblank)))))) (defun get-SPADSTRING-token (token) "With TOK=\" and ABC\" on IN-STREAM, extracts and stacks string ABC" (PROG ((BUF (make-adjustable-string 0))) - (if (char/= (current-char) #\") (RETURN NIL) (advance-char)) - (loop - (if (char= (current-char) #\") (return nil)) - (SUFFIX (if (char= (current-char) XCape) - (advance-char) - (current-char)) - BUF) - (if (null (advance-char)) ;;end of line - (PROGN (|sayBrightly| "Close quote inserted") (RETURN nil))) - ) - (advance-char) - (return (token-install (copy-seq buf) ;should make a simple string - 'spadstring token)))) + (if (char/= (current-char) #\") (RETURN NIL) (advance-char)) + (loop + (if (char= (current-char) #\") (return nil)) + (SUFFIX (if (char= (current-char) XCape) + (advance-char) + (current-char)) + BUF) + (if (null (advance-char)) ;;end of line + (PROGN (|sayBrightly| "Close quote inserted") (RETURN nil))) + ) + (advance-char) + (return (token-install (copy-seq buf) ;should make a simple string + 'spadstring token)))) ; **** 4. BOOT token parsing actions @@ -1279,15 +1277,15 @@ or the chracters ?, !, ' or %" (defun TRANSLABEL1 (X AL) "Transforms X according to AL = ((