parse.diff

--- parse-old.lisp	2012-08-23 16:27:07.000000000 +0300
+++ parse.lisp	2012-09-09 09:37:23.454006352 +0300
@@ -1,3 +1,38 @@
+
+;; Copyright (c) Marijn Haverbeke, marijnh@gmail.com
+
+;; This software is provided 'as-is', without any express or implied
+;; warranty. In no event will the authors be held liable for any
+;; damages arising from the use of this software.
+
+;; Permission is granted to anyone to use this software for any
+;; purpose, including commercial applications, and to alter it and
+;; redistribute it freely, subject to the following restrictions:
+
+;; 1. The origin of this software must not be misrepresented; you must
+;;    not claim that you wrote the original software. If you use this
+;;    software in a product, an acknowledgment in the product
+;;    documentation would be appreciated but is not required.
+
+;; 2. Altered source versions must be plainly marked as such, and must
+;;    not be misrepresented as being the original software.
+
+;; 3. This notice may not be removed or altered from any source
+;;    distribution.
+
+;; ## Important Note
+
+;; Cheat-JS includes a modified version of
+;; [`parse-js`](http://marijnhaverbeke.nl/parse-js/), written by Marijn
+;; Haverbeke. This is necessary because I (Miron Brezuleanu) needed to
+;; modify `parse-js` a little. The license of `parse-js` is in the
+;; `LICENSE-parse-js.txt` file. The modified files from `parse-js`
+;; included in Cheat-JS are `parse.lisp`, `tokenize.lisp` and
+;; `util.lisp`. The modifications were permitted by the `parse-js`
+;; license. This is not an official copy of `parse-js` and is not
+;; supported by Marijn Haverbeke. If the modified parsing code in
+;; Cheat-JS breaks, it's exclusively my fault - I messed up the code.
+
 (in-package #:parse-js)
 
 (defparameter *unary-prefix* '(:typeof :void :delete :-- :++ :! :~ :- :+))
@@ -33,6 +68,8 @@
         (with-input-from-string (in input) (parse-js* in strict-semicolons))
         (parse-js* input strict-semicolons))))
 
+(defvar *macro-hook* nil)
+
 (defun/defs parse-js* (stream &optional strict-semicolons)
   (def input (if (functionp stream) stream (lex-js stream)))
   (def token (funcall input))
@@ -253,6 +290,71 @@
           (next) (setf args (expr-list #\))))
         (subscripts (as :new newexp args) t))))
 
+  (def macro-body ()
+    (let ((*in-function* t))
+      (let ((body (loop
+                     until (and (eq :punc (token-type token))
+                                (char= #\) (token-value token)))
+                     collect (statement))))
+        (unless (and (eq :punc (token-type token))
+                     (char= #\) (token-value token)))
+          (token-error token "Expected ')', but read token '~a'."
+                       (token-id token)))
+        (next) ;; The close paren.
+        body)))
+
+  (def macro-vars (closing-char)
+    (let ((args (loop
+                   until (and (eq :punc (token-type token))
+                              (char= closing-char (token-value token)))
+                   collect (expression nil)
+                   when (and (eq :punc (token-type token))
+                             (char= #\, (token-value token)))
+                   do (next))))
+      (unless (and (eq :punc (token-type token))
+                   (char= closing-char (token-value token)))
+        (token-error token "Expected '~a', but read token '~a'."
+                     closing-char
+                     (token-id token)))
+      (next) ;; The semicolon between args and body (or the closing
+             ;; paren).
+      args))
+
+  (def macro-custom-parse ()
+    (when (and (eq (token-type token) :name)
+               *macro-hook*)
+      (ecase (funcall *macro-hook* (token-value token))
+        ((:not-a-macro))
+        ((:body)
+         (let ((name-token token))
+           (next) ;; The name.
+           (next) ;; The open paren.
+           (let ((body (macro-body)))
+             (list :macro-call
+                   (list (token-type name-token)
+                         (token-value name-token))
+                   (list* :body body)))))
+        ((:args-and-body)
+         (let ((name-token token))
+           (next) ;; The name.
+           (next) ;; The open paren.
+           (let ((vars (macro-vars #\;))
+                 (body (macro-body)))
+             (list :macro-call
+                   (list (token-type name-token)
+                         (token-value name-token))
+                   (list (list* :args vars)
+                         (list* :body body))))))
+        ((:args)
+         (let ((name-token token))
+           (next) ;; The name.
+           (next) ;; The open paren.
+           (let ((vars (macro-vars #\))))
+             (list :macro-call
+                   (list (token-type name-token)
+                         (token-value name-token))
+                   (list* :args vars))))))))
+
   (def expr-atom (allow-calls)
     (cond ((tokenp token :operator :new) (next) (new*))
           ((token-type-p token :punc)
@@ -265,10 +367,11 @@
            (next)
            (subscripts (function* nil) allow-calls))
           ((member (token-type token) '(:atom :num :string :regexp :name))
+           (or (macro-custom-parse)
            (let ((atom (if (eq (token-type token) :regexp)
                            (as :regexp (car (token-value token)) (cdr (token-value token)))
                            (as (token-type token) (token-value token)))))
-             (subscripts (prog1 atom (next)) allow-calls)))
+                 (subscripts (prog1 atom (next)) allow-calls))))
           (t (unexpected token))))
 
   (def expr-list (closing &optional allow-trailing-comma allow-empty)