Commit | Line | Data |
---|---|---|
cc4f1551 RD |
1 | (in-package :parenscript) |
2 | ||
3 | ;;; AST node equality | |
4 | (defmethod js-equal ((obj1 list) (obj2 list)) | |
5 | (and (= (length obj1) (length obj2)) | |
6 | (every #'js-equal obj1 obj2))) | |
7 | ||
8 | (defmethod js-equal ((obj1 t) (obj2 t)) | |
9 | (equal obj1 obj2)) | |
10 | ||
11 | (defmacro defjsclass (name superclasses slots &rest class-options) | |
12 | (let ((slot-names (mapcar #'(lambda (slot) (if (atom slot) slot (first slot))) slots))) | |
13 | `(progn | |
14 | (defclass ,name ,superclasses | |
15 | ,slots ,@class-options) | |
16 | (defmethod js-equal ((obj1 ,name) (obj2 ,name)) | |
17 | (every #'(lambda (slot) | |
18 | (js-equal (slot-value obj1 slot) | |
19 | (slot-value obj2 slot))) | |
20 | ',slot-names))))) | |
21 | ||
22 | ;;; js language types | |
23 | (defclass statement () | |
24 | ((value :initarg :value :accessor value :initform nil)) | |
25 | (:documentation "A Javascript entity without a value.")) | |
26 | ||
27 | (defclass expression (statement) | |
28 | () | |
29 | (:documentation "A Javascript entity with a value.")) | |
30 | ||
31 | ;;; array literals | |
32 | (defjsclass array-literal (expression) | |
33 | ((values :initarg :values :accessor array-values))) | |
34 | ||
35 | (defjsclass js-aref (expression) | |
36 | ((array :initarg :array | |
37 | :accessor aref-array) | |
38 | (index :initarg :index | |
39 | :accessor aref-index))) | |
40 | ||
41 | ;;; object literals (maps and hash-tables) | |
42 | (defjsclass object-literal (expression) | |
43 | ((values :initarg :values :accessor object-values))) | |
44 | ||
45 | ;;; string literals | |
46 | (defjsclass string-literal (expression) | |
47 | (value)) | |
48 | ||
49 | ||
50 | ;;; number literals | |
51 | (defjsclass number-literal (expression) | |
52 | (value)) | |
53 | ||
54 | ;;; variables | |
55 | (defjsclass js-variable (expression) | |
56 | (value)) | |
57 | ||
58 | ;;; quote | |
59 | (defjsclass js-quote (expression) | |
60 | ()) | |
61 | ||
62 | ;;; operators | |
63 | (defjsclass op-form (expression) | |
64 | ((operator :initarg :operator :accessor operator) | |
65 | (args :initarg :args :accessor op-args))) | |
66 | ||
67 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
68 | ||
69 | (defparameter *op-precedence-hash* (make-hash-table :test #'equal)) | |
70 | ||
71 | ;;; generate the operator precedences from *OP-PRECEDENCES* | |
72 | (let ((precedence 1)) | |
73 | (dolist (ops '((aref) | |
74 | (slot-value) | |
75 | (! not ~) | |
76 | (* / %) | |
77 | (+ -) | |
78 | (<< >>) | |
79 | (>>>) | |
80 | (< > <= >=) | |
81 | (in if) | |
82 | (eql == != =) | |
83 | (=== !==) | |
84 | (&) | |
85 | (^) | |
86 | (\|) | |
87 | (\&\& and) | |
88 | (\|\| or) | |
89 | (setf *= /= %= += -= <<= >>= >>>= \&= ^= \|=) | |
90 | (comma))) | |
91 | (dolist (op ops) | |
92 | (let ((op-name (symbol-name op))) | |
93 | (setf (gethash op-name *op-precedence-hash*) precedence))) | |
94 | (incf precedence))) | |
95 | ||
96 | (defun op-precedence (op) | |
97 | (gethash (if (symbolp op) | |
98 | (symbol-name op) | |
99 | op) | |
100 | *op-precedence-hash*))) | |
101 | ||
102 | (defjsclass one-op (expression) | |
103 | ((pre-p :initarg :pre-p | |
104 | :initform nil | |
105 | :accessor one-op-pre-p) | |
106 | (op :initarg :op | |
107 | :accessor one-op))) | |
108 | ||
109 | ;;; function calls | |
110 | (defjsclass function-call (expression) | |
111 | ((function :initarg :function :accessor f-function) | |
112 | (args :initarg :args :accessor f-args))) | |
113 | ||
114 | (defjsclass method-call (expression) | |
115 | ((method :initarg :method :accessor m-method) | |
116 | (object :initarg :object :accessor m-object) | |
117 | (args :initarg :args :accessor m-args))) | |
118 | ||
119 | ;;; body forms | |
120 | (defjsclass js-body (expression) | |
121 | ((stmts :initarg :stmts :accessor b-stmts) | |
122 | (indent :initarg :indent :initform "" :accessor b-indent))) | |
123 | ||
124 | (defmethod initialize-instance :after ((body js-body) &rest initargs) | |
125 | (declare (ignore initargs)) | |
126 | (let* ((stmts (b-stmts body)) | |
127 | (last (last stmts)) | |
128 | (last-stmt (car last))) | |
129 | (when (typep last-stmt 'js-body) | |
130 | (setf (b-stmts body) | |
131 | (nconc (butlast stmts) | |
132 | (b-stmts last-stmt)))))) | |
133 | ||
134 | (defjsclass js-sub-body (js-body) | |
135 | (stmts indent)) | |
136 | ||
137 | ;;; function definition | |
138 | (defjsclass js-lambda (expression) | |
139 | ((args :initarg :args :accessor lambda-args) | |
140 | (body :initarg :body :accessor lambda-body))) | |
141 | ||
142 | (defjsclass js-defun (js-lambda) | |
143 | ((name :initarg :name :accessor defun-name))) | |
144 | ||
145 | ;;; object creation | |
146 | (defjsclass js-object (expression) | |
147 | ((slots :initarg :slots | |
148 | :accessor o-slots))) | |
149 | ||
150 | (defjsclass js-slot-value (expression) | |
151 | ((object :initarg :object | |
152 | :accessor sv-object) | |
153 | (slot :initarg :slot | |
154 | :accessor sv-slot))) | |
155 | ||
156 | ;;; cond | |
157 | (defjsclass js-cond (expression) | |
158 | ((tests :initarg :tests | |
159 | :accessor cond-tests) | |
160 | (bodies :initarg :bodies | |
161 | :accessor cond-bodies))) | |
162 | ||
163 | (defjsclass js-if (expression) | |
164 | ((test :initarg :test | |
165 | :accessor if-test) | |
166 | (then :initarg :then | |
167 | :accessor if-then) | |
168 | (else :initarg :else | |
169 | :accessor if-else))) | |
170 | ||
171 | (defmethod initialize-instance :after ((if js-if) &rest initargs) | |
172 | (declare (ignore initargs)) | |
173 | (when (and (if-then if) | |
174 | (typep (if-then if) 'js-sub-body)) | |
175 | (change-class (if-then if) 'js-body)) | |
176 | (when (and (if-else if) | |
177 | (typep (if-else if) 'js-sub-body)) | |
178 | (change-class (if-else if) 'js-body))) | |
179 | ||
180 | ;;; switch | |
181 | (defjsclass js-switch (statement) | |
182 | ((value :initarg :value :accessor case-value) | |
183 | (clauses :initarg :clauses :accessor case-clauses))) | |
184 | ||
185 | ;;; assignment | |
186 | ||
187 | (defjsclass js-setf (expression) | |
188 | ((lhs :initarg :lhs :accessor setf-lhs) | |
189 | (rhsides :initarg :rhsides :accessor setf-rhsides))) | |
190 | ||
191 | ;;; defvar | |
192 | (defjsclass js-defvar (statement) | |
193 | ((names :initarg :names :accessor var-names) | |
194 | (value :initarg :value :accessor var-value))) | |
195 | ||
196 | ;;; iteration | |
197 | (defjsclass js-for (statement) | |
198 | ((vars :initarg :vars :accessor for-vars) | |
199 | (steps :initarg :steps :accessor for-steps) | |
200 | (check :initarg :check :accessor for-check) | |
201 | (body :initarg :body :accessor for-body))) | |
202 | ||
203 | (defjsclass for-each (statement) | |
204 | ((name :initarg :name :accessor fe-name) | |
205 | (value :initarg :value :accessor fe-value) | |
206 | (body :initarg :body :accessor fe-body))) | |
207 | ||
208 | (defjsclass js-while (statement) | |
209 | ((check :initarg :check :accessor while-check) | |
210 | (body :initarg :body :accessor while-body))) | |
211 | ||
212 | ;;; with | |
213 | (defjsclass js-with (statement) | |
214 | ((obj :initarg :obj :accessor with-obj) | |
215 | (body :initarg :body :accessor with-body))) | |
216 | ||
217 | ;;; try-catch | |
218 | (defjsclass js-try (statement) | |
219 | ((body :initarg :body :accessor try-body) | |
220 | (catch :initarg :catch :accessor try-catch) | |
221 | (finally :initarg :finally :accessor try-finally))) | |
222 | ||
223 | ;;; regular expressions | |
224 | (defjsclass regex (expression) | |
225 | (value)) | |
226 | ||
227 | ;;; conditional compilation | |
228 | (defjsclass cc-if () | |
229 | ((test :initarg :test :accessor cc-if-test) | |
230 | (body :initarg :body :accessor cc-if-body))) | |
231 | ||
232 | ;; TODO this may not be the best integrated implementation of | |
233 | ;; instanceof into the rest of the code | |
234 | (defjsclass js-instanceof (expression) | |
235 | ((value) | |
236 | (type :initarg :type))) | |
237 | ||
238 | (defmacro define-js-single-op (name &optional (superclass 'expression)) | |
239 | (let ((js-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*))) | |
240 | `(progn | |
241 | (defjsclass ,js-name (,superclass) | |
242 | (value))))) | |
243 | ||
244 | (define-js-single-op return statement) | |
245 | (define-js-single-op throw statement) | |
246 | (define-js-single-op delete) | |
247 | (define-js-single-op void) | |
248 | (define-js-single-op typeof) | |
249 | (define-js-single-op new) | |
250 |