src/source-model.lisp

   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