diff options
Diffstat (limited to 'third_party/lisp/npg/src/define.lisp')
| -rw-r--r-- | third_party/lisp/npg/src/define.lisp | 366 |
1 files changed, 183 insertions, 183 deletions
diff --git a/third_party/lisp/npg/src/define.lisp b/third_party/lisp/npg/src/define.lisp index f52f0381a2de..783f071fc5d9 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)) |