diff options
Diffstat (limited to 'third_party/lisp/npg')
| -rw-r--r-- | third_party/lisp/npg/examples/python.lisp | 6 | ||||
| -rw-r--r-- | third_party/lisp/npg/examples/vs-cobol-ii.lisp | 96 | ||||
| -rw-r--r-- | third_party/lisp/npg/npg.asd | 16 | ||||
| -rw-r--r-- | third_party/lisp/npg/src/define.lisp | 366 | ||||
| -rw-r--r-- | third_party/lisp/npg/src/parser.lisp | 238 |
5 files changed, 361 insertions, 361 deletions
diff --git a/third_party/lisp/npg/examples/python.lisp b/third_party/lisp/npg/examples/python.lisp index 68d794ddec..a45ac614f7 100644 --- a/third_party/lisp/npg/examples/python.lisp +++ b/third_party/lisp/npg/examples/python.lisp @@ -38,7 +38,7 @@ (deflazy define-grammar (let ((*package* #.*package*) - (*compile-print* (and parser::*debug* t))) + (*compile-print* (and parser::*debug* t))) (reset-grammar) (format t "~&creating Python grammar...~%") (populate-grammar) @@ -80,8 +80,8 @@ (defrule statement-list := (+ simple-statement ";") :reduce (if (cdr $1) - (cons :statement-list $1) - (car $1))) + (cons :statement-list $1) + (car $1))) (defrule statement := statement-list eol diff --git a/third_party/lisp/npg/examples/vs-cobol-ii.lisp b/third_party/lisp/npg/examples/vs-cobol-ii.lisp index 2edf1292da..9ebd45a169 100644 --- a/third_party/lisp/npg/examples/vs-cobol-ii.lisp +++ b/third_party/lisp/npg/examples/vs-cobol-ii.lisp @@ -38,7 +38,7 @@ (deflazy define-grammar (let ((*package* #.*package*) - (*compile-print* (and parser::*debug* t))) + (*compile-print* (and parser::*debug* t))) (reset-grammar) (format t "creating Cobol grammar...~%") (populate-grammar) @@ -263,8 +263,8 @@ (defrule file-control-entry := select-clause assign-clause fce-phrase* "." :reduce (append select-clause - assign-clause - (flatten-list fce-phrase))) + assign-clause + (flatten-list fce-phrase))) (defrule organization-is := "ORGANIZATION" "IS"?) @@ -658,7 +658,7 @@ (defrule data-description-entry := level-number alt-data-name-filler? data-description-entry-clause* "." :reduce (append (list level-number alt-data-name-filler) - (flatten-list data-description-entry-clause))) + (flatten-list data-description-entry-clause))) (defrule alt-data-name-filler := data-name @@ -754,8 +754,8 @@ (defrule synchronized-clause := synchronized alt-left-right? :reduce `(:synchronized ,(if alt-left-right - alt-left-right - t))) + alt-left-right + t))) (defrule alt-left-right := "LEFT" @@ -1004,7 +1004,7 @@ (defrule compute-statement := "COMPUTE" cobword-rounded+ equal arithmetic-expression on-size-error-statement-list? not-on-size-error-statement-list? "END-COMPUTE"? :reduce (list 'compute cobword-rounded arithmetic-expression :on-size-error on-size-error-statement-list - :not-on-size-error not-on-size-error-statement-list)) + :not-on-size-error not-on-size-error-statement-list)) (defrule equal := "=" @@ -1100,12 +1100,12 @@ (defrule if-phrase := "IF" condition "THEN"? alt-statement-list-next-sentence "ELSE" alt-statement-list-next-sentence :reduce (list 'if condition - (if (cdr alt-statement-list-next-sentence) - (cons 'progn alt-statement-list-next-sentence) - (car alt-statement-list-next-sentence)) - (if (cdr alt-statement-list-next-sentence2) - (cons 'progn alt-statement-list-next-sentence2) - (car alt-statement-list-next-sentence2))) + (if (cdr alt-statement-list-next-sentence) + (cons 'progn alt-statement-list-next-sentence) + (car alt-statement-list-next-sentence)) + (if (cdr alt-statement-list-next-sentence2) + (cons 'progn alt-statement-list-next-sentence2) + (car alt-statement-list-next-sentence2))) := "IF" condition "THEN"? alt-statement-list-next-sentence :reduce (append (list 'when condition) alt-statement-list-next-sentence)) @@ -1209,11 +1209,11 @@ (defrule multiply-statement := "MULTIPLY" id-or-lit "BY" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-MULTIPLY"? :reduce (list 'multiply id-or-lit cobword-rounded :on-size-error on-size-error-statement-list - :not-on-size-error not-on-size-error-statement-list) + :not-on-size-error not-on-size-error-statement-list) := "MULTIPLY" id-or-lit "BY" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-MULTIPLY"? :reduce (list 'multiply id-or-lit id-or-lit2 :giving cobword-rounded - :on-size-error on-size-error-statement-list - :not-on-size-error not-on-size-error-statement-list)) + :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list)) (defrule open-statement := "OPEN" open-statement-phrase+ @@ -1418,17 +1418,17 @@ (defrule subtract-statement := "SUBTRACT" id-or-lit+ "FROM" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"? :reduce (list 'subtract-giving id-or-lit id-or-lit2 cobword-rounded - :on-size-error on-size-error-statement-list - :not-on-size-error not-on-size-error-statement-list) + :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list) := "SUBTRACT" id-or-lit+ "FROM" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"? :reduce (list 'subtract id-or-lit cobword-rounded - :on-size-error on-size-error-statement-list - :not-on-size-error not-on-size-error-statement-list) + :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list) := "SUBTRACT" corresponding variable-identifier "FROM" variable-identifier "ROUNDED"? on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"? :reduce (list 'subtract-corr variable-identifier variable-identifier - :rounded (and $5 t) - :on-size-error on-size-error-statement-list - :not-on-size-error not-on-size-error-statement-list)) + :rounded (and $5 t) + :on-size-error on-size-error-statement-list + :not-on-size-error not-on-size-error-statement-list)) (defrule cobword-rounded := variable-identifier "ROUNDED"? @@ -1449,11 +1449,11 @@ (defrule unstring-statement := "UNSTRING" variable-identifier delimited-by-all-phrase? "INTO" unstring-statement-dst+ with-pointer-identifier? tallying-in-identifier? on-overflow-statement-list? not-on-overflow-statement-list? "END-UNSTRING"? :reduce (list 'unstring variable-identifier unstring-statement-dst - :delimited-by-all delimited-by-all-phrase - :with-pointer with-pointer-identifier - :tallying tallying-in-identifier - :on-overflow on-overflow-statement-list - :not-on-overflow not-on-overflow-statement-list)) + :delimited-by-all delimited-by-all-phrase + :with-pointer with-pointer-identifier + :tallying tallying-in-identifier + :on-overflow on-overflow-statement-list + :not-on-overflow not-on-overflow-statement-list)) (defrule id-or-lit := literal @@ -1622,8 +1622,8 @@ (defrule combinable-condition := "NOT"? simple-condition :reduce (if $1 - (list 'not simple-condition) - simple-condition)) + (list 'not simple-condition) + simple-condition)) (defrule simple-condition := class-condition @@ -1637,8 +1637,8 @@ (defrule class-condition := variable-identifier "IS"? "NOT"? class-type :reduce (if $3 - (list 'not (list 'type-of variable-identifier (make-keyword class-type))) - (list 'type-of variable-identifier (make-keyword class-type)))) + (list 'not (list 'type-of variable-identifier (make-keyword class-type))) + (list 'type-of variable-identifier (make-keyword class-type)))) (defrule class-type := "NUMERIC" @@ -1651,12 +1651,12 @@ (destructuring-bind (main-operator main-variable other-variable) main-relation (declare (ignore other-variable)) (labels ((unfold (subs) - (if (null subs) - main-relation - (destructuring-bind (connection operator variable) (car subs) - (list connection - (list (or operator main-operator) main-variable variable) - (unfold (cdr subs))))))) + (if (null subs) + main-relation + (destructuring-bind (connection operator variable) (car subs) + (list connection + (list (or operator main-operator) main-variable variable) + (unfold (cdr subs))))))) (unfold subs)))) (defrule relation-condition @@ -1720,8 +1720,8 @@ (defrule sign-condition := arithmetic-expression "IS"? "NOT"? sign-type :reduce (if $3 - `(not (,sign-type ,arithmetic-expression)) - `(,sign-type ,arithmetic-expression))) + `(not (,sign-type ,arithmetic-expression)) + `(,sign-type ,arithmetic-expression))) (defrule sign-type := "POSITIVE" :reduce '> @@ -1743,14 +1743,14 @@ (defrule variable-identifier := qualified-data-name subscript-parentheses* ;; reference-modification? :reduce (if subscript-parentheses - (list :aref qualified-data-name subscript-parentheses) - qualified-data-name)) + (list :aref qualified-data-name subscript-parentheses) + qualified-data-name)) (defrule reference-modification := "(" leftmost-character-position ":" length? ")" :reduce (if length - (list :range leftmost-character-position length) - leftmost-character-position)) + (list :range leftmost-character-position length) + leftmost-character-position)) (defrule condition-name-reference := condition-name in-data-or-file-or-mnemonic-name* subscript-parentheses*) @@ -1777,8 +1777,8 @@ (defrule qualified-data-name := data-name in-data-or-file-name* :reduce (if in-data-or-file-name - (list data-name in-data-or-file-name) ; incomplete -wcp15/7/03. - data-name) + (list data-name in-data-or-file-name) ; incomplete -wcp15/7/03. + data-name) := "ADDRESS" "OF" data-name :reduce (list 'address-of data-name) := "LENGTH" "OF" cobol-identifier @@ -1811,8 +1811,8 @@ := plus-or-minus? basis := plus-or-minus? basis "**" power :reduce (if plus-or-minus - `(plus-or-minus (expt basis basis2)) - `(expt basis basis2))) + `(plus-or-minus (expt basis basis2)) + `(expt basis basis2))) (defrule plus-or-minus := "+" diff --git a/third_party/lisp/npg/npg.asd b/third_party/lisp/npg/npg.asd index addb7c6932..1e35186d6c 100644 --- a/third_party/lisp/npg/npg.asd +++ b/third_party/lisp/npg/npg.asd @@ -44,12 +44,12 @@ left recursive rules." (:doc-file "COPYING") (:doc-file ".project") (:module :examples - :components - ((:sample-file "python") - (:sample-file "vs-cobol-ii"))) + :components + ((:sample-file "python") + (:sample-file "vs-cobol-ii"))) (:module :src - :components - ((:file "package") - (:file "common" :depends-on ("package")) - (:file "define" :depends-on ("package" "common")) - (:file "parser" :depends-on ("package" "common")))))) + :components + ((:file "package") + (:file "common" :depends-on ("package")) + (:file "define" :depends-on ("package" "common")) + (:file "parser" :depends-on ("package" "common")))))) diff --git a/third_party/lisp/npg/src/define.lisp b/third_party/lisp/npg/src/define.lisp index f52f0381a2..783f071fc5 100644 --- a/third_party/lisp/npg/src/define.lisp +++ b/third_party/lisp/npg/src/define.lisp @@ -37,13 +37,13 @@ those that are not declared as strings in the grammar.") the list of variables for the function reducing this production, those that are non static and their unambiguous user-friendly names." (flet ((unique (sym list) - (if (not (assoc sym list)) - sym - (loop - for i of-type fixnum from 2 - for x = (intern (format nil "~:@(~A~)~A" sym i)) - while (assoc x list) - finally (return x))))) + (if (not (assoc sym list)) + sym + (loop + for i of-type fixnum from 2 + for x = (intern (format nil "~:@(~A~)~A" sym i)) + while (assoc x list) + finally (return x))))) (loop for tok in tokens for i of-type fixnum from 1 @@ -54,8 +54,8 @@ that are non static and their unambiguous user-friendly names." and when (symbolp tok) collect (list (unique tok named-vars) arg) into named-vars when (and (listp tok) - (symbolp (cadr tok))) - collect (list (unique (cadr tok) named-vars) arg) into named-vars + (symbolp (cadr tok))) + collect (list (unique (cadr tok) named-vars) arg) into named-vars finally (return (values args vars named-vars))))) @@ -63,56 +63,56 @@ that are non static and their unambiguous user-friendly names." "Create a function with name NAME, arguments derived from TOKENS and body ACTION. Return it's definition." (let ((function - (multiple-value-bind (args vars named-vars) - (make-action-arguments tokens) - `(lambda ,args - (declare (ignorable ,@args)) - (let (($vars (list ,@vars)) - ($all (list ,@args)) - ,@named-vars - ($alist (list ,@(mapcar #'(lambda (v) - `(cons ',(intern (symbol-name (car v))) - ,(cadr v))) - named-vars)))) - (declare (ignorable $vars $all $alist ,@(mapcar #'car named-vars))) - (flet ((make-object (&optional type args) - (apply #'make-instance (or type ',name) - (append args $alist)))) - ,action)))))) + (multiple-value-bind (args vars named-vars) + (make-action-arguments tokens) + `(lambda ,args + (declare (ignorable ,@args)) + (let (($vars (list ,@vars)) + ($all (list ,@args)) + ,@named-vars + ($alist (list ,@(mapcar #'(lambda (v) + `(cons ',(intern (symbol-name (car v))) + ,(cadr v))) + named-vars)))) + (declare (ignorable $vars $all $alist ,@(mapcar #'car named-vars))) + (flet ((make-object (&optional type args) + (apply #'make-instance (or type ',name) + (append args $alist)))) + ,action)))))) (when *compile-print* (if *compile-verbose* - (format t "; Compiling ~S:~% ~S~%" name function) - (format t "; Compiling ~S~%" name))) + (format t "; Compiling ~S:~% ~S~%" name function) + (format t "; Compiling ~S~%" name))) (compile name function))) (defun define-rule (name productions) "Accept a rule in EBNF-like syntax, translate it into a sexp and a call to INSERT-RULE-IN-CURRENT-GRAMMAR." (flet ((transform (productions) - (loop - for tok in productions - with prod = nil - with action = nil - with phase = nil - with new-prods = nil - while tok - do (cond ((eq tok :=) - (push (list (nreverse prod) action) new-prods) - (setf prod nil - action nil - phase :prod)) - ((eq tok :reduce) - (setf phase :action)) - ((eq tok :tag) - (setf phase :tag)) - ((eq phase :tag) - (setf action `(cons ,tok $vars))) - ((eq phase :action) - (setf action tok)) - ((eq phase :prod) - (push tok prod))) - finally - (return (cdr (nreverse (cons (list (nreverse prod) action) new-prods))))))) + (loop + for tok in productions + with prod = nil + with action = nil + with phase = nil + with new-prods = nil + while tok + do (cond ((eq tok :=) + (push (list (nreverse prod) action) new-prods) + (setf prod nil + action nil + phase :prod)) + ((eq tok :reduce) + (setf phase :action)) + ((eq tok :tag) + (setf phase :tag)) + ((eq phase :tag) + (setf action `(cons ,tok $vars))) + ((eq phase :action) + (setf action tok)) + ((eq phase :prod) + (push tok prod))) + finally + (return (cdr (nreverse (cons (list (nreverse prod) action) new-prods))))))) (insert-rule-in-current-grammar name (transform productions)))) (defmacro defrule (name &rest productions) @@ -124,9 +124,9 @@ call to INSERT-RULE-IN-CURRENT-GRAMMAR." return it." (insert-rule-in-current-grammar (gensym (concatenate 'string "OPT-" - (if (rule-p token) - (symbol-name (rule-name token)) - (string-upcase token)))) + (if (rule-p token) + (symbol-name (rule-name token)) + (string-upcase token)))) `(((,token)) (())))) (defun make-alternative-rule (tokens) @@ -134,24 +134,24 @@ return it." (insert-rule-in-current-grammar (gensym "ALT") (mapcar #'(lambda (alternative) - `((,alternative))) - tokens))) + `((,alternative))) + tokens))) (defun make-nonempty-list-rule (token &optional separator) "Make a rule for a non-empty list (+ syntax) and return it." (let ((rule-name (gensym (concatenate 'string "NELST-" - (if (rule-p token) - (symbol-name (rule-name token)) - (string-upcase token)))))) + (if (rule-p token) + (symbol-name (rule-name token)) + (string-upcase token)))))) (insert-rule-in-current-grammar rule-name (if separator - `(((,token ,separator ,rule-name) - (cons $1 $3)) - ((,token) ,#'list)) - `(((,token ,rule-name) - (cons $1 $2)) - ((,token) ,#'list)))))) + `(((,token ,separator ,rule-name) + (cons $1 $3)) + ((,token) ,#'list)) + `(((,token ,rule-name) + (cons $1 $2)) + ((,token) ,#'list)))))) (defun make-list-rule (token &optional separator) "Make a rule for a possibly empty list (* syntax) return it." @@ -166,14 +166,14 @@ return it." or (* NAME) or (+ NAME). This is used by the DEFRULE macro." (if (symbolp tok) (let* ((name (symbol-name tok)) - (last (char name (1- (length name)))) - ;; this looks silly but we need to make sure that we - ;; return symbols interned in this package, no one else - (op (cadr (assoc last '((#\? ?) (#\+ +) (#\* *)))))) - (if (and (> (length name) 1) op) - (list op - (intern (subseq name 0 (1- (length name))))) - tok)) + (last (char name (1- (length name)))) + ;; this looks silly but we need to make sure that we + ;; return symbols interned in this package, no one else + (op (cadr (assoc last '((#\? ?) (#\+ +) (#\* *)))))) + (if (and (> (length name) 1) op) + (list op + (intern (subseq name 0 (1- (length name))))) + tok)) tok)) (defun EBNF-to-SEBNF (tokens) @@ -184,10 +184,10 @@ EBNF syntax into a sexp-based EBNF syntax or SEBNF." for token = (expand-production-token tok) with new-tokens = '() do (cond ((member token '(* + ?)) - (setf (car new-tokens) - (list token (car new-tokens)))) - (t - (push token new-tokens))) + (setf (car new-tokens) + (list token (car new-tokens)))) + (t + (push token new-tokens))) finally (return (nreverse new-tokens)))) (defun SEBNF-to-BNF (tokens) @@ -195,21 +195,21 @@ EBNF syntax into a sexp-based EBNF syntax or SEBNF." it into BNF. The production is simplified but the current grammar is populated with additional rules." (flet ((make-complex-token-rule (tok) - (ecase (car tok) - (* (apply #'make-list-rule (cdr tok))) - (+ (apply #'make-nonempty-list-rule (cdr tok))) - (? (make-optional-rule (cadr tok))) - (or (make-alternative-rule (cdr tok)))))) + (ecase (car tok) + (* (apply #'make-list-rule (cdr tok))) + (+ (apply #'make-nonempty-list-rule (cdr tok))) + (? (make-optional-rule (cadr tok))) + (or (make-alternative-rule (cdr tok)))))) (loop for token in tokens with new-tokens = '() with keywords = '() do (cond ((listp token) - (push (make-complex-token-rule token) new-tokens)) - (t - (push token new-tokens) - (when (const-terminal-p token) - (push token keywords)))) + (push (make-complex-token-rule token) new-tokens)) + (t + (push token new-tokens) + (when (const-terminal-p token) + (push token keywords)))) finally (return (values (nreverse new-tokens) keywords))))) (defun make-default-action-function (name tokens) @@ -220,28 +220,28 @@ list and in case only a variable token is available that one is returned (not included in a list). If all the tokens are constant, then all of them are returned in a list." (cond ((null tokens) - ;; if the production matched the empty list (no tokens) we - ;; return always nil, that is the function LIST applied to no - ;; arguments - #'list) - ((null (cdr tokens)) - ;; if the production matches just one token we simply return - ;; that - #'identity) - (*smart-default-reduction* - ;; If we are required to be "smart" then create a function - ;; that simply returns the non static tokens of the - ;; production. If the production doesn't have nonterminal, - ;; then return all the tokens. If the production has only - ;; one argument then return that one only. - (make-action-function name tokens '(cond - ((null $vars) $all) - ((null (cdr $vars)) (car $vars)) - (t $vars)))) - (t - ;; in all the other cases we return all the token matching - ;; the production - #'list))) + ;; if the production matched the empty list (no tokens) we + ;; return always nil, that is the function LIST applied to no + ;; arguments + #'list) + ((null (cdr tokens)) + ;; if the production matches just one token we simply return + ;; that + #'identity) + (*smart-default-reduction* + ;; If we are required to be "smart" then create a function + ;; that simply returns the non static tokens of the + ;; production. If the production doesn't have nonterminal, + ;; then return all the tokens. If the production has only + ;; one argument then return that one only. + (make-action-function name tokens '(cond + ((null $vars) $all) + ((null (cdr $vars)) (car $vars)) + (t $vars)))) + (t + ;; in all the other cases we return all the token matching + ;; the production + #'list))) (defun make-production-from-descr (name production-description) "Take a production NAME and its description in the form of a sexp @@ -250,28 +250,28 @@ keywords." (destructuring-bind (tokens &optional action) production-description (let ((expanded-tokens (EBNF-to-SEBNF tokens))) (multiple-value-bind (production-tokens keywords) - (sebnf-to-bnf expanded-tokens) + (sebnf-to-bnf expanded-tokens) (let ((funct - (cond ((not action) - (make-default-action-function name expanded-tokens)) - ((or (listp action) - ;; the case when the action is simply to - ;; return a token (ie $2) or a constant value - (symbolp action)) - (make-action-function name expanded-tokens action)) - ((functionp action) - action) - (t ; action is a constant - #'(lambda (&rest args) - (declare (ignore args)) - action))))) - (values - ;; Make a promise instead of actually resolving the - ;; nonterminals. This avoids endless recursion. - (make-production :tokens production-tokens - :tokens-length (length production-tokens) - :action funct) - keywords)))))) + (cond ((not action) + (make-default-action-function name expanded-tokens)) + ((or (listp action) + ;; the case when the action is simply to + ;; return a token (ie $2) or a constant value + (symbolp action)) + (make-action-function name expanded-tokens action)) + ((functionp action) + action) + (t ; action is a constant + #'(lambda (&rest args) + (declare (ignore args)) + action))))) + (values + ;; Make a promise instead of actually resolving the + ;; nonterminals. This avoids endless recursion. + (make-production :tokens production-tokens + :tokens-length (length production-tokens) + :action funct) + keywords)))))) (defun remove-immediate-left-recursivity (rule) "Turn left recursive rules of the type @@ -281,7 +281,7 @@ into A2 -> x A2 | E where E is the empty production." (let ((name (rule-name rule)) - (productions (rule-productions rule))) + (productions (rule-productions rule))) (loop for prod in productions for tokens = (prod-tokens prod) @@ -291,40 +291,40 @@ where E is the empty production." else collect prod into non-left-recursive finally - ;; found any left recursive production? - (when left-recursive - (warn "rule ~S is left recursive" name) - (let ((new-rule (make-rule :name (gensym "REWRITE")))) - ;; A -> y A2 - (setf (rule-productions rule) - (mapcar #'(lambda (p) - (let ((tokens (prod-tokens p)) - (action (prod-action p))) - (make-production :tokens (append tokens (list new-rule)) - :tokens-length (1+ (prod-tokens-length p)) - :action #'(lambda (&rest args) - (let ((f-A2 (car (last args))) - (head (butlast args))) - (funcall f-A2 (apply action head))))))) - non-left-recursive)) - ;; A2 -> x A2 | E - (setf (rule-productions new-rule) - (append - (mapcar #'(lambda (p) - (let ((tokens (prod-tokens p)) - (action (prod-action p))) - (make-production :tokens (append (cdr tokens) (list new-rule)) - :tokens-length (prod-tokens-length p) - :action #'(lambda (&rest args) - (let ((f-A2 (car (last args))) - (head (butlast args))) - #'(lambda (x) - (funcall f-A2 (apply action x head)))))))) - left-recursive) - (list - (make-production :tokens nil - :tokens-length 0 - :action #'(lambda () #'(lambda (arg) arg))))))))))) + ;; found any left recursive production? + (when left-recursive + (warn "rule ~S is left recursive" name) + (let ((new-rule (make-rule :name (gensym "REWRITE")))) + ;; A -> y A2 + (setf (rule-productions rule) + (mapcar #'(lambda (p) + (let ((tokens (prod-tokens p)) + (action (prod-action p))) + (make-production :tokens (append tokens (list new-rule)) + :tokens-length (1+ (prod-tokens-length p)) + :action #'(lambda (&rest args) + (let ((f-A2 (car (last args))) + (head (butlast args))) + (funcall f-A2 (apply action head))))))) + non-left-recursive)) + ;; A2 -> x A2 | E + (setf (rule-productions new-rule) + (append + (mapcar #'(lambda (p) + (let ((tokens (prod-tokens p)) + (action (prod-action p))) + (make-production :tokens (append (cdr tokens) (list new-rule)) + :tokens-length (prod-tokens-length p) + :action #'(lambda (&rest args) + (let ((f-A2 (car (last args))) + (head (butlast args))) + #'(lambda (x) + (funcall f-A2 (apply action x head)))))))) + left-recursive) + (list + (make-production :tokens nil + :tokens-length 0 + :action #'(lambda () #'(lambda (arg) arg))))))))))) (defun remove-left-recursivity-from-rules (rules) (loop @@ -338,9 +338,9 @@ where E is the empty production." (loop for rule being each hash-value in rules do (loop - for production in (rule-productions rule) - do (setf (prod-tokens production) - (resolve-nonterminals (prod-tokens production) rules))))) + for production in (rule-productions rule) + do (setf (prod-tokens production) + (resolve-nonterminals (prod-tokens production) rules))))) (defun make-rule-productions (rule-name production-descriptions) "Return a production object that belongs to RULE-NAME made according @@ -352,12 +352,12 @@ to PRODUCTION-DESCRIPTIONS. See also MAKE-PRODUCTION-FROM-DESCR." with productions = '() with keywords = '() do (progn - (multiple-value-bind (production keyws) - (make-production-from-descr prod-name descr) - (push production productions) - (setf keywords (append keyws keywords)))) + (multiple-value-bind (production keyws) + (make-production-from-descr prod-name descr) + (push production productions) + (setf keywords (append keyws keywords)))) finally (return - (values (nreverse productions) keywords)))) + (values (nreverse productions) keywords)))) (defun create-rule (name production-descriptions) "Return a new rule object together with a list of keywords making up @@ -365,7 +365,7 @@ the production definitions." (multiple-value-bind (productions keywords) (make-rule-productions name production-descriptions) (values (make-rule :name name :productions productions) - keywords))) + keywords))) (defun insert-rule-in-current-grammar (name productions) "Add rule to the current grammar and its keywords to the keywords @@ -384,18 +384,18 @@ instead." "Given a list of production tokens, try to expand the nonterminal ones with their respective rule from the the RULES pool." (flet ((resolve-symbol (sym) - (or (find-rule sym rules) - sym))) + (or (find-rule sym rules) + sym))) (mapcar #'(lambda (tok) - (if (symbolp tok) - (resolve-symbol tok) - tok)) - tokens))) + (if (symbolp tok) + (resolve-symbol tok) + tok)) + tokens))) (defun reset-grammar () "Empty the current grammar from any existing rule." (setf *rules* (make-rules-table) - *keywords* (make-keywords-table))) + *keywords* (make-keywords-table))) (defun generate-grammar (&optional (equal-p #'string-equal)) "Return a GRAMMAR structure suitable for the PARSE function, using @@ -404,5 +404,5 @@ match the input tokens; it defaults to STRING-EQUAL." (resolve-all-nonterminals *rules*) (remove-left-recursivity-from-rules *rules*) (make-grammar :rules *rules* - :keywords *keywords* - :equal-p equal-p)) + :keywords *keywords* + :equal-p equal-p)) diff --git a/third_party/lisp/npg/src/parser.lisp b/third_party/lisp/npg/src/parser.lisp index 328be1dcf3..c15d26fe39 100644 --- a/third_party/lisp/npg/src/parser.lisp +++ b/third_party/lisp/npg/src/parser.lisp @@ -43,9 +43,9 @@ Tune this if your grammar is unusually complex.") (when *debug* (format *debug* "reducing ~S on ~S~%" production arguments)) (flet ((safe-token-value (token) - (if (token-p token) - (token-value token) - token))) + (if (token-p token) + (token-value token) + token))) (apply (prod-action production) (mapcar #'safe-token-value arguments)))) (defgeneric later-position (pos1 pos2) @@ -75,120 +75,120 @@ supposed to specialise this method.")) Return the reduced values according to the nonterminal actions. Raise an error on failure." (declare (type grammar grammar) - (type symbol start)) + (type symbol start)) (labels ((match-token (expected token) - (when *debug* - (format *debug* "match-token ~S ~S -> " expected token)) - (let ((res (cond ((symbolp expected) - ;; non-costant terminal (like identifiers) - (eq expected (token-type token))) - ((and (stringp expected) - (stringp (token-value token))) - ;; string costant terminal - (funcall (the function (grammar-equal-p grammar)) expected (token-value token))) - ((functionp expected) - ;; custom equality predicate (must be able - ;; to deal with token objects) - (funcall expected token)) - ;; all the rest - (t (equal expected (token-value token)))))) - (when *debug* - (format *debug* "~Amatched~%" (if res "" "not "))) - res)) + (when *debug* + (format *debug* "match-token ~S ~S -> " expected token)) + (let ((res (cond ((symbolp expected) + ;; non-costant terminal (like identifiers) + (eq expected (token-type token))) + ((and (stringp expected) + (stringp (token-value token))) + ;; string costant terminal + (funcall (the function (grammar-equal-p grammar)) expected (token-value token))) + ((functionp expected) + ;; custom equality predicate (must be able + ;; to deal with token objects) + (funcall expected token)) + ;; all the rest + (t (equal expected (token-value token)))))) + (when *debug* + (format *debug* "~Amatched~%" (if res "" "not "))) + res)) (match (expected matched #+debug depth) - (declare (list expected matched) - #+debug (fixnum depth)) - (let ((first-expected (car expected))) - (cond #+debug ((> depth *maximum-recursion-depth*) - (error "endless recursion on ~A ~A at ~A expecting ~S" - (token-type (car matched)) (token-value (car matched)) - (token-position (car matched)) expected)) - ((eq first-expected :any) - (match (cdr expected) (cdr matched) #+debug depth)) - ;; This is a trick to obtain partial parses. When we - ;; reach this expected token we assume we succeeded - ;; the parsing and return the remaining tokens as - ;; part of the match. - ((eq first-expected :rest) - ;; we could be at the end of input so we check this - (unless (cdr matched) - (setf (cdr matched) (list :rest))) - (list nil nil)) - ((rule-p first-expected) - ;; If it's a rule, then we try to match all its - ;; productions. We return the first that succeeds. - (loop - for production in (rule-productions first-expected) - for production-tokens of-type list = (prod-tokens production) - with last-error-position = nil - with last-error = nil - for (error-position error-descr) = - (progn - (when *debug* - (format *debug* "trying to match ~A: ~S~%" - (rule-name first-expected) production-tokens)) - (match (append production-tokens (cdr expected)) matched #+debug (1+ depth))) - do (cond ((not error-position) - (return (let ((args-count (prod-tokens-length production))) - (setf (cdr matched) - (cons (reduce-production - production - (subseq (the list (cdr matched)) 0 args-count)) - (nthcdr (1+ args-count) matched))) - (list nil nil)))) - ((or (not last-error) - (later-position error-position last-error-position)) - (setf last-error-position error-position - last-error error-descr))) - ;; if everything fails return the "best" error - finally (return (list last-error-position - (if *debug* - #'(lambda () - (format nil "~A, trying to match ~A" - (funcall (the function last-error)) - (rule-name first-expected))) - last-error))))) - (t - ;; if necessary load the next tokens - (when (null (cdr matched)) - (setf (cdr matched) (read-next-tokens tokenizer))) - (cond ((and (or (null expected) (eq first-expected :eof)) - (null (cdr matched))) - ;; This point is reached only once for each complete - ;; parsing. The expected tokens and the input - ;; tokens have been exhausted at the same time. - ;; Hence we succeeded the parsing. - (setf (cdr matched) (list :eof)) - (list nil nil)) - ((null expected) - ;; Garbage at end of parsing. This may mean that we - ;; have considered a production completed too soon. - (list (token-position (car matched)) - #'(lambda () - "garbage at end of parsing"))) - ((null (cdr matched)) - ;; EOF error - (list :eof - #'(lambda () - (format nil "end of input expecting ~S" expected)))) - (t ;; normal token - (let ((first-token (cadr matched))) - (if (match-token first-expected first-token) - (match (cdr expected) (cdr matched) #+debug depth) - ;; failed: we return the error - (list (token-position first-token) - #'(lambda () - (format nil "expected ~S but got ~S ~S" - first-expected (token-type first-token) - (token-value first-token))))))))))))) + (declare (list expected matched) + #+debug (fixnum depth)) + (let ((first-expected (car expected))) + (cond #+debug ((> depth *maximum-recursion-depth*) + (error "endless recursion on ~A ~A at ~A expecting ~S" + (token-type (car matched)) (token-value (car matched)) + (token-position (car matched)) expected)) + ((eq first-expected :any) + (match (cdr expected) (cdr matched) #+debug depth)) + ;; This is a trick to obtain partial parses. When we + ;; reach this expected token we assume we succeeded + ;; the parsing and return the remaining tokens as + ;; part of the match. + ((eq first-expected :rest) + ;; we could be at the end of input so we check this + (unless (cdr matched) + (setf (cdr matched) (list :rest))) + (list nil nil)) + ((rule-p first-expected) + ;; If it's a rule, then we try to match all its + ;; productions. We return the first that succeeds. + (loop + for production in (rule-productions first-expected) + for production-tokens of-type list = (prod-tokens production) + with last-error-position = nil + with last-error = nil + for (error-position error-descr) = + (progn + (when *debug* + (format *debug* "trying to match ~A: ~S~%" + (rule-name first-expected) production-tokens)) + (match (append production-tokens (cdr expected)) matched #+debug (1+ depth))) + do (cond ((not error-position) + (return (let ((args-count (prod-tokens-length production))) + (setf (cdr matched) + (cons (reduce-production + production + (subseq (the list (cdr matched)) 0 args-count)) + (nthcdr (1+ args-count) matched))) + (list nil nil)))) + ((or (not last-error) + (later-position error-position last-error-position)) + (setf last-error-position error-position + last-error error-descr))) + ;; if everything fails return the "best" error + finally (return (list last-error-position + (if *debug* + #'(lambda () + (format nil "~A, trying to match ~A" + (funcall (the function last-error)) + (rule-name first-expected))) + last-error))))) + (t + ;; if necessary load the next tokens + (when (null (cdr matched)) + (setf (cdr matched) (read-next-tokens tokenizer))) + (cond ((and (or (null expected) (eq first-expected :eof)) + (null (cdr matched))) + ;; This point is reached only once for each complete + ;; parsing. The expected tokens and the input + ;; tokens have been exhausted at the same time. + ;; Hence we succeeded the parsing. + (setf (cdr matched) (list :eof)) + (list nil nil)) + ((null expected) + ;; Garbage at end of parsing. This may mean that we + ;; have considered a production completed too soon. + (list (token-position (car matched)) + #'(lambda () + "garbage at end of parsing"))) + ((null (cdr matched)) + ;; EOF error + (list :eof + #'(lambda () + (format nil "end of input expecting ~S" expected)))) + (t ;; normal token + (let ((first-token (cadr matched))) + (if (match-token first-expected first-token) + (match (cdr expected) (cdr matched) #+debug depth) + ;; failed: we return the error + (list (token-position first-token) + #'(lambda () + (format nil "expected ~S but got ~S ~S" + first-expected (token-type first-token) + (token-value first-token))))))))))))) (declare (inline match-token)) (let ((result (list :head))) (destructuring-bind (error-position error) - (match (list (find-rule start (grammar-rules grammar))) result #+debug 0) - (when error-position - (error "~A at ~A~%" (funcall (the function error)) error-position)) - (cadr result))))) + (match (list (find-rule start (grammar-rules grammar))) result #+debug 0) + (when error-position + (error "~A at ~A~%" (funcall (the function error)) error-position)) + (cadr result))))) (defgeneric terminals-in-grammar (grammar-or-hashtable) (:documentation @@ -199,11 +199,11 @@ an error on failure." for rule being each hash-value of grammar with terminals = '() do (loop - for prod in (rule-productions rule) - do (loop - for tok in (prod-tokens prod) - when (symbolp tok) - do (pushnew tok terminals))) + for prod in (rule-productions rule) + do (loop + for tok in (prod-tokens prod) + when (symbolp tok) + do (pushnew tok terminals))) finally (return terminals))) (defmethod terminals-in-grammar ((grammar grammar)) @@ -211,9 +211,9 @@ an error on failure." (defun print-grammar-figures (grammar &optional (stream *standard-output*)) (format stream "rules: ~A~%constant terminals: ~A~%variable terminals: ~S~%" - (hash-table-count (grammar-rules grammar)) - (hash-table-count (grammar-keywords grammar)) - (terminals-in-grammar (grammar-rules grammar)))) + (hash-table-count (grammar-rules grammar)) + (hash-table-count (grammar-keywords grammar)) + (terminals-in-grammar (grammar-rules grammar)))) (defun grammar-keyword-p (keyword grammar) |