Skip to content

Commit 88be1fe

Browse files
TheStalkerDenTheStalkerDen
committed
Improved backend
1 parent 9f3df77 commit 88be1fe

File tree

9 files changed

+427
-206
lines changed

9 files changed

+427
-206
lines changed

‎DiffBackend/src/abstract-sem-tree-generator.lisp

Lines changed: 114 additions & 48 deletions
Original file line numberDiff line numberDiff line change
@@ -15,82 +15,148 @@
1515

1616
(defvar *current-id*)
1717

18-
;;; ast = abstract syntax tree
19-
(defun abstract-sem-tree-gen (ast &key (curr-file 1))
20-
(let ((*current-file-ver* curr-file)
21-
(*current-id* 0))
22-
(top-level-rule ast)))
18+
(defparameter *semanitc-errors-list* nil)
19+
20+
(defclass semantic-error-info ()
21+
((error-text :accessor error-text
22+
:initarg :error-text)
23+
(error-node :accessor error-node
24+
:initarg :error-node)))
25+
26+
(defun abstract-sem-tree-gen (syn-tree &key (curr-file 1))
27+
(let* ((*current-file-ver* curr-file)
28+
(*current-id* 0)
29+
(*semanitc-errors-list*)
30+
(res-ast (match-top syn-tree)))
31+
(values res-ast
32+
*semanitc-errors-list*)))
2333

2434
(defun get-id ()
2535
(prog1 *current-id*
2636
(incf *current-id*)))
2737

28-
(defun top-level-rule (ast)
38+
(defun match-top (root-of-syn-tree)
2939
(destructuring-bind (term-type annotations &rest elements)
30-
ast
40+
root-of-syn-tree
3141
(declare (ignore term-type annotations))
32-
(mapcar (lambda (el)
33-
(match-s-expr el))
42+
(mapcar (lambda (term-el)
43+
(match-s-expr term-el))
3444
elements)))
3545

36-
(defun match-s-expr (el)
37-
(ecase (first el)
38-
((:atom) (make-lexem-wrapper (third el)))
39-
((:list)
40-
(or (match-defun el)
41-
(match-function-call el)))))
46+
(defun match-s-expr (term-el)
47+
(destructuring-bind (term-type annotations first-s-expr &rest others)
48+
term-el
49+
(ecase term-type
50+
((:atom) (make-atom-node term-el))
51+
((:list)
52+
(unless (eq (get-term-type first-s-expr) :atom)
53+
(return-from match-s-expr
54+
(make-ill-node-and-push-to-errors-list
55+
"Illegal function call"
56+
term-el)))
57+
(unless (eq (get-atom-term-type first-s-expr) :symbol)
58+
(return-from match-s-expr
59+
(make-ill-node-and-push-to-errors-list
60+
"Illegal function call"
61+
term-el)))
62+
(let ((normal-symbol-string
63+
(get-symbol-atom-normal-string-form first-s-expr)))
64+
(cond
65+
((string= normal-symbol-string "DEFUN")
66+
(match-defun first-s-expr annotations others))
67+
(t (match-function-call first-s-expr annotations others))))))))
68+
69+
(defun make-ill-node-and-push-to-errors-list (error-text ill-term)
70+
(let ((ill-node (make-illegal-node ill-term :is-top? t))
71+
(coord (ecase (get-term-type ill-term)
72+
((:atom) (get-atom-term-position ill-term))
73+
((:list) (rest (assoc :lparen-coord (second ill-term)))))))
74+
(push (make-instance 'semantic-error-info
75+
:error-text
76+
(format nil "At (~S:~S) ~A"
77+
(first coord)
78+
(second coord)
79+
error-text)
80+
:error-node (id ill-node))
81+
*semanitc-errors-list*)
82+
ill-node))
4283

4384
(defun is-atom-s-expr? (s-expr)
4485
(eq (first s-expr) :atom))
45-
4686
(defun get-form*-vector (form*-list)
4787
(when form*-list
4888
(map 'vector #'match-s-expr form*-list)))
4989

50-
(defun make-lexem-wrapper (lexem)
51-
(make-instance 'lexem-wrapper-node
52-
:lexem-info lexem
90+
(defun get-term-type (term)
91+
(first term))
92+
93+
(defun get-atom-term-type (atom-term)
94+
(lexer:lexem-type (third atom-term)))
95+
96+
(defun get-atom-term-position (atom-term)
97+
(let ((lex-info (third atom-term)))
98+
(list (lexer:lexem-line lex-info)
99+
(lexer:lexem-column lex-info))))
100+
101+
(defun get-symbol-atom-normal-string-form (atom-term)
102+
(string-upcase (lexem-string (third atom-term))))
103+
104+
(defun make-atom-node (atom-term &key (atom-type 'simple-atom-node))
105+
(make-instance atom-type
106+
:lexem-info (third atom-term)
53107
:id (get-id)))
54108

55-
(defun match-defun (list-element)
56-
(let ((thrd (third list-element)))
57-
(when (and (is-atom-s-expr? thrd)
58-
(is-lexem-symbol?= (third thrd) "defun")
59-
(>= (length list-element) 6))
60-
(destructuring-bind (type par-info keyword name parms &rest forms)
61-
list-element
62-
(declare (ignore type))
109+
(defun make-illegal-node (term &key is-top?)
110+
(let ((node-id (get-id)))
111+
(destructuring-bind (term-type annotations &rest others)
112+
term
113+
(ecase term-type
114+
((:atom) (make-atom-node term))
115+
((:list) (make-instance 'illegal-node
116+
:id node-id
117+
:parenthesis-info annotations
118+
:elements (map 'vector
119+
#'make-illegal-node
120+
others)
121+
:is-top? is-top?))))))
122+
123+
(defun match-defun (keyword-term par-info elements)
124+
(handler-case
125+
(destructuring-bind (func-name parms &rest forms)
126+
elements
63127
(let* ((node-id (get-id))
64128
(res-obj
65-
(make-instance
66-
'defun-node
67-
:keyword-lexem (make-lexem-wrapper (third keyword))
68-
:func-name (make-lexem-wrapper (third name))
69-
:parenthesis-info par-info
70-
:parameters-list (gen-list-node parms)
71-
:body-forms (get-form*-vector forms)
72-
:id node-id)))
73-
(add-to-stats (lexem-string (third name))
129+
(make-instance
130+
'defun-node
131+
:keyword-lexem (make-atom-node keyword-term :atom-type 'keyword-atom)
132+
:func-name (make-atom-node func-name :atom-type 'func-name-atom)
133+
:parenthesis-info par-info
134+
:parameters-list (make-list-node parms)
135+
:body-forms (get-form*-vector forms)
136+
:id node-id)))
137+
(add-to-stats (get-symbol-atom-normal-string-form func-name)
74138
res-obj
75139
:stat-name :defuns
76140
:file-ver *current-file-ver*)
77-
res-obj)))))
141+
res-obj))
142+
(error (c)
143+
(declare (ignore c))
144+
(make-ill-node-and-push-to-errors-list
145+
"incorrect defun"
146+
`(:list ,par-info ,keyword-term ,@elements)))))
78147

79-
(defun gen-list-node (list-element)
148+
(defun make-list-node (list-element)
80149
(when (eq (first list-element) :list)
81150
(let ((node-id (get-id)))
82151
(make-instance 'list-node
83152
:parenthesis-info (second list-element)
84153
:elements (get-form*-vector (rest (rest list-element)))
85154
:id node-id))))
86155

87-
(defun match-function-call (list-element)
88-
(destructuring-bind (type par-info func-form &rest args)
89-
list-element
90-
(declare (ignore type))
91-
(let ((node-id (get-id)))
92-
(make-instance 'function-call-node
93-
:func-lexem (match-s-expr func-form)
94-
:parenthesis-info par-info
95-
:func-arg-forms (get-form*-vector args)
96-
:id node-id))))
156+
(defun match-function-call (func-name-term par-info func-args)
157+
(let ((node-id (get-id)))
158+
(make-instance 'function-call-node
159+
:func-lexem (make-atom-node func-name-term :atom-type 'func-name-atom)
160+
:parenthesis-info par-info
161+
:func-arg-forms (get-form*-vector func-args)
162+
:id node-id)))

‎DiffBackend/src/comparator.lisp

Lines changed: 76 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -18,14 +18,32 @@
1818

1919
(defparameter *cmp-memoization-table* nil)
2020

21+
(defclass moved-s-expr-info ()
22+
((s-expr-id1 :accessor s-expr-id1
23+
:initarg :s-expr-id1)
24+
(s-expr-id2 :accessor s-expr-id2
25+
:initarg :s-expr-id2)
26+
(start-coord-of-id1 :accessor start-coord-of-id1
27+
:initarg :start-coord-of-id1)
28+
(start-coord-of-id2 :accessor start-coord-of-id2
29+
:initarg :start-coord-of-id2)
30+
(end-coord-of-id1 :accessor end-coord-of-id1
31+
:initarg :end-coord-of-id1)
32+
(end-coord-of-id2 :accessor end-coord-of-id2
33+
:initarg :end-coord-of-id2)))
34+
35+
(defparameter *moved-s-exprs-list* nil)
36+
2137
(defun compare-results ()
2238
(let ((ver1-stats (get-stats 1))
23-
(ver2-stats (get-stats 2)))
39+
(ver2-stats (get-stats 2))
40+
(*moved-s-exprs-list*))
2441
(loop :for stat-name :being :the :hash-keys :of ver1-stats
2542
:do
2643
(compare-specific-stats-hts
2744
(gethash stat-name ver1-stats)
28-
(gethash stat-name ver2-stats)))))
45+
(gethash stat-name ver2-stats)))
46+
(reverse *moved-s-exprs-list*)))
2947

3048
;;;it tests results after compare!!!
3149
(defun compare-specific-stats-hts (ht1 ht2)
@@ -68,28 +86,43 @@
6886
*was-modified*))
6987

7088
(defun maybe-issue-resolver ()
71-
(dolist (maybe-deleted *maybe-deleted-nodes*)
72-
(dolist (maybe-new *maybe-new-nodes*)
73-
(acond
74-
((gethash (cons (id maybe-deleted)
75-
(id maybe-new))
76-
*cmp-memoization-table*)
77-
(when (first it)
89+
(labels
90+
((%add-to-moved-s-exprs-list (maybe-deleted maybe-new)
91+
(let ((first-and-last-coord1 (get-first-and-last-coord maybe-deleted))
92+
(first-and-last-coord2 (get-first-and-last-coord maybe-new)))
93+
(push (make-instance
94+
'moved-s-expr-info
95+
:s-expr-id1 (id maybe-deleted)
96+
:s-expr-id2 (id maybe-new)
97+
:start-coord-of-id1 (first first-and-last-coord1)
98+
:end-coord-of-id1 (second first-and-last-coord1)
99+
:start-coord-of-id2 (first first-and-last-coord2)
100+
:end-coord-of-id2 (second first-and-last-coord2))
101+
*moved-s-exprs-list*))))
102+
(dolist (maybe-deleted *maybe-deleted-nodes*)
103+
(dolist (maybe-new *maybe-new-nodes*)
104+
(acond
105+
((gethash (cons (id maybe-deleted)
106+
(id maybe-new))
107+
*cmp-memoization-table*)
108+
(when (first it)
109+
(set-diff-status maybe-deleted `(:moved ,(id maybe-new)))
110+
(set-diff-status maybe-new `(:moved ,(id maybe-deleted)))
111+
(remove-from-memoiz-table :first-id (id maybe-deleted)
112+
:second-id (id maybe-new))
113+
(%add-to-moved-s-exprs-list maybe-deleted maybe-new)
114+
(return)))
115+
((compare maybe-deleted maybe-new)
78116
(set-diff-status maybe-deleted `(:moved ,(id maybe-new)))
79117
(set-diff-status maybe-new `(:moved ,(id maybe-deleted)))
80-
(remove-from-memoiz-table :first-id (id maybe-deleted)
81-
:second-id (id maybe-new))
82-
(return)))
83-
((compare maybe-deleted maybe-new)
84-
(set-diff-status maybe-deleted `(:moved ,(id maybe-new)))
85-
(set-diff-status maybe-new `(:moved ,(id maybe-deleted)))
86-
(return))))
87-
(setf *maybe-new-nodes*
88-
(remove-if
89-
(lambda (el)
90-
(when (listp (diff-status el))
91-
(eq (first (diff-status el)) :moved)))
92-
*maybe-new-nodes*)))
118+
(%add-to-moved-s-exprs-list maybe-deleted maybe-new)
119+
(return))))
120+
(setf *maybe-new-nodes*
121+
(remove-if
122+
(lambda (el)
123+
(when (listp (diff-status el))
124+
(eq (first (diff-status el)) :moved)))
125+
*maybe-new-nodes*))))
93126
(setf *maybe-deleted-nodes*
94127
(remove-if
95128
(lambda (el)
@@ -101,9 +134,9 @@
101134
(dolist (new-obj *maybe-new-nodes*)
102135
(set-diff-status new-obj :new)))
103136

137+
104138
(defgeneric compare (obj1 obj2)
105139
(:method (obj1 obj2)
106-
(warn "Unsupported compare for ~S and ~S ~%" obj1 obj2)
107140
(values nil 0 nil nil))
108141
(:documentation "Out1 - fully equal
109142
Out2 - equal leaf-nodes
@@ -114,6 +147,24 @@ Out4 - diff-patch for obj2"))
114147
(:method (obj diff-patch diff-status)
115148
(error "Unsupported apply-diff-patch for ~S" obj)))
116149

150+
(defgeneric get-first-and-last-coord (obj)
151+
(:method (obj)
152+
(warn "No support for get-first-and-last-coord")
153+
`((0 0) (0 0))))
154+
155+
(defmethod get-first-and-last-coord ((obj parenthesis-mixin))
156+
(let ((par-info (parenthesis-info obj)))
157+
`(,(rest (first par-info))
158+
,(rest (second par-info)))))
159+
160+
(defmethod get-first-and-last-coord ((obj atom-node))
161+
(let ((lex-info (lexem-info obj)))
162+
`((,(lexer:lexem-line lex-info)
163+
,(lexer:lexem-column lex-info))
164+
(,(lexer:lexem-line lex-info)
165+
,(+ (lexer:lexem-column lex-info)
166+
(length (lexer:lexem-string lex-info)))))))
167+
117168
(defun remove-from-memoiz-table (&key first-id second-id)
118169
(maphash (lambda (key val)
119170
(declare (ignore val))
@@ -129,7 +180,7 @@ Out4 - diff-patch for obj2"))
129180
(:method (obj1 obj2)
130181
(format t "set-diff-statud default method for object without diff-status-mixin. Something is wrong: ~A ~A~%" obj1 obj2)))
131182

132-
(defmethod set-diff-status ((obj diff-status-mixin) status)
183+
(defmethod set-diff-status ((obj main-fields-mixin) status)
133184
(setf (diff-status obj) status)
134185
(cond ((eq status :maybe-new)
135186
(push obj *maybe-new-nodes*))
@@ -391,7 +442,7 @@ Out4 - diff-patch for obj2"))
391442
(defmethod apply-diff-patch ((obj list-node) diff-patch diff-status)
392443
(apply-diff-patch (elements obj) diff-patch diff-status))
393444

394-
(defmethod compare ((obj1 lexem-wrapper-node) (obj2 lexem-wrapper-node))
445+
(defmethod compare ((obj1 atom-node) (obj2 atom-node))
395446
(let ((lex-info1 (lexem-info obj1))
396447
(lex-info2 (lexem-info obj2)))
397448
(unless (eq (lexer:lexem-type lex-info1) (lexer:lexem-type lex-info2))

0 commit comments

Comments
 (0)