about summary refs log tree commit diff
path: root/third_party/lisp/npg/src/define.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'third_party/lisp/npg/src/define.lisp')
-rw-r--r--third_party/lisp/npg/src/define.lisp366
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))