~remexre/nr-langutil

ref: 497866c2df054f404747f8dd4e1484983206bbc5 nr-langutil/parser/parse-clauses.lisp -rw-r--r-- 4.4 KiB
497866c2Nathan Ringo ... 1 year, 3 months ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
(in-package :nr-langutil)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (declaim (ftype (function (list) (values hash-table hash-table &optional)) collect-names))
  (defun collect-names (clauses)
    "Given a list of CLAUSE values as described above, returns a hash table from
     terminals and one from nonterminals to arbitrary indices. These indices are
     assigned for terminals sequentially from zero without gaps; and for nonterminals
     from one greater than the highest terminal index.

     Signals an UNDEFINED-NONTERMINAL-ERROR condition when a nonterminal is used
     that has no productions associated with it."

    (let ((terminals          (make-hash-table :test #'eq))
          (nonterminals-used  (make-hash-table :test #'eq))
          (nonterminals-given (make-hash-table :test #'eq))
          (i 1))
      (setf (gethash :eof terminals) 0)
      (labels ((on-clause (clause)
                 (check-type clause (cons (and symbol (not keyword)) (cons list cons)))
                 (on-nt (first clause))
                 (mapc #'on-arg (second clause)))
               (on-nt (nt)
                 (check-type nt (and symbol (not keyword)))
                 (when (eq nt 'root)
                   (error 'illegal-name :name nt))
                 (setf (gethash nt nonterminals-given) t))
               (on-arg (arg)
                 (cond
                   ((symbolp arg)
                    (on-name arg))
                   (t
                    (check-type arg (cons symbol (cons symbol null)))
                    (on-name (second arg)))))
               (on-name (name)
                 (check-type name symbol)
                 (cond
                   ((eq name :eof)
                    (error 'illegal-name :name :eof))
                   ((keywordp name)
                    (unless (gethash name terminals nil)
                      (setf (gethash name terminals) i)
                      (incf i)))
                   (t
                    (setf (gethash name nonterminals-used) t)))))
        (mapc #'on-clause clauses))
      (iter
        (for (k v) in-hashtable nonterminals-used)
        (declare (ignorable v))
        (unless (gethash k nonterminals-given)
          (error 'undefined-nonterminal-error :nt k)))
      (iter
        (for (k v) in-hashtable nonterminals-given)
        (declare (ignorable v))
        (setf (gethash k nonterminals-used) i)
        (incf i))
      (setf (gethash 'root nonterminals-used) i)
      (values terminals nonterminals-used))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (declaim (ftype (function (fixnum list) (values lr-rule &optional)) to-lr-rule))
  (defun to-lr-rule (index clause)
    (let ((nt (first clause))
          (arg-forms (second clause))
          (len 0)
          args)
      (iter
        (for arg in arg-forms)
          (if (symbolp arg)
              (push arg args)
              (push (second arg) args))
        (incf len)
        (finally
          (setf args (make-array (list len) :element-type 'symbol
                                 :initial-contents (nreverse args)))
          (return (make-lr-rule :nt nt :args args :index index)))))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (declaim (ftype (function (list hash-table hash-table)
                            (values (simple-array (cons fixnum (cons fixnum list)) (*)) &optional))
                  extract-reduce-actions))
  (defun extract-reduce-actions (clauses terminals nonterminals)
    "Takes CLAUSES as they would be supplied to DEF/PARSER, and returns a
     vector of triples. The car is the index of the nonterminal the reduce
     action is for, the cadr is the number of arguments it takes, and the cddr
     is a form that evaluates to a function that implements the reduce action."

    (iter
      (for (nt args . body) in clauses)
      (for arg-list = nil)
      (for bindings = nil)
      (for ignored = nil)
      (iter
        (for arg in args)
        (for name = (gensym (symbol-name (if (consp arg) (first arg) name))))
        (push name arg-list)
        (if (consp arg)
            (push (list (first arg) name) bindings)
            (push name ignored)))
      (collect
        (cons (- (gethash nt nonterminals) (hash-table-count terminals))
              (cons (length args)
                    `(lambda ,(nreverse arg-list)
                       (declare (ignore ,@ignored))
                       (let ,bindings
                         ,@body))))

        result-type vector)) ))