...
 
Commits (1)
  • Daniel Gackle's avatar
    An initial implementation of source mappings. · 053e9d45
    Daniel Gackle authored
    When consuming source code from a stream, the compiler now optionally
    collects the start and end position of each list the reader reads
    (atoms aren't tracked - see below), threads this information all the
    way through to the printer, and associates it with the start and end
    positions of the corresponding JS being generated.
    
    Note that this is an expression-based way of doing source maps as
    opposed to the line-based approach of the Google/Mozilla source map
    spec. This is a much richer and Lispier way to do it. But converting
    to the line-based format will require tracking lines in the printer.
    That work is not part of this commit.
    
    Text extents of forms are tracked in a big EQ-hash-table of which the
    forms themselves are the keys. This has the disadvantage that atomic
    tokens such as variable names don't get their source mappings tracked
    (though see note [1] below). It has the much greater advantage of
    making the source mapping implementation not be too invasive. I tried
    the alternative implementation of consing the text extents as metadata
    onto the heads of each cons to be compiled. This worked, but had the
    consequence that any compiler code that needs to pick apart the forms
    it is given must be aware of this optional (because source mappings
    may be turned off) metadata at the head - and, Lisp being what it is,
    "compiler code" here includes any PS macros that anybody writes. That
    is far too heavy a burden to place on macros even if the PS compiler
    itself could stand it. Storing the metadata on the side avoids this;
    now only those portions of the compiler that care about preserving the
    source mappings of the forms they are given need worry about them, and
    for any forms they are passing on untransformed they can just ignore
    this extra information. Similarly, macros that wish to propagate
    source mappings have the option of doing so, but also have the option
    of remaining blissfully ignorant.
    
    [1] Tricks could be applied to work around this. For example, atoms
    that appear inside conses could be uniquely identified using the cons
    plus an integer index. But this would be a lot more work, both to
    develop and more importantly at runtime, and it's not clear whether
    the more precise mappings would be worth it.
    053e9d45
...@@ -15,6 +15,7 @@ ...@@ -15,6 +15,7 @@
(:file "js-ir-package") (:file "js-ir-package")
(:file "utils") (:file "utils")
(:file "namespace") (:file "namespace")
(:file "source-mappings")
(:file "compiler") (:file "compiler")
(:file "printer") (:file "printer")
(:file "compilation-interface") (:file "compilation-interface")
......
...@@ -9,5 +9,6 @@ ...@@ -9,5 +9,6 @@
(:file "test") (:file "test")
(:file "output-tests") (:file "output-tests")
(:file "package-system-tests") (:file "package-system-tests")
(:file "eval-tests")))) (:file "eval-tests")
(:file "srcmap-tests"))))
:depends-on (:parenscript :eos :cl-js)) :depends-on (:parenscript :eos :cl-js))
...@@ -35,7 +35,7 @@ which writes the resulting code to stream." ...@@ -35,7 +35,7 @@ which writes the resulting code to stream."
bound, writes the output to *parenscript-stream*, otherwise returns a bound, writes the output to *parenscript-stream*, otherwise returns a
string." string."
(let ((*psw-stream* (or *parenscript-stream* (make-string-output-stream)))) (let ((*psw-stream* (or *parenscript-stream* (make-string-output-stream))))
(parenscript-print (compile-statement `(progn ,@body)) t) (parenscript-print (compile-statement (make-progn body)) t)
(unless *parenscript-stream* (unless *parenscript-stream*
(get-output-stream-string *psw-stream*)))) (get-output-stream-string *psw-stream*))))
...@@ -68,21 +68,27 @@ string." ...@@ -68,21 +68,27 @@ string."
(defvar *ps-read-function* #'read) (defvar *ps-read-function* #'read)
(defun ps-compile-stream (stream) (defun ps-compile-stream (stream &optional source-mapping?)
"Reads (using the value of *ps-read-function*, #'read by default, as "Reads (using the value of *ps-read-function*, #'read by default, as
the read function) Parenscript forms from stream and compiles them as the read function) Parenscript forms from stream and compiles them as
if by ps*. If *parenscript-stream* is bound, writes the output to if by ps*. If *parenscript-stream* is bound, writes the output to
*parenscript-stream*, otherwise and returns a string." *parenscript-stream*, otherwise and returns a string."
(let ((output-stream (or *parenscript-stream* (make-string-output-stream)))) (let ((output-stream (or *parenscript-stream* (make-string-output-stream)))
(*source-maps* nil))
(let ((*compilation-level* :toplevel) (let ((*compilation-level* :toplevel)
(*readtable* *readtable*) (*text-extents* (when source-mapping? (make-hash-table :test 'eq)))
(*readtable* (if source-mapping?
(make-extent-preserving-readtable *readtable*)
*readtable*))
(*package* *package*) (*package* *package*)
(*parenscript-stream* output-stream) (*parenscript-stream* output-stream)
(eof '#:eof)) (eof '#:eof))
(loop for form = (funcall *ps-read-function* stream nil eof) (loop for form = (funcall *ps-read-function* stream nil eof)
until (eq form eof) do (ps* form) (fresh-line *parenscript-stream*))) until (eq form eof) do (ps* form) (fresh-line *parenscript-stream*)))
(unless *parenscript-stream* (values
(get-output-stream-string output-stream)))) (unless *parenscript-stream*
(get-output-stream-string output-stream))
*source-maps*)))
(defun ps-compile-file (source-file &key (element-type 'character) (external-format :default)) (defun ps-compile-file (source-file &key (element-type 'character) (external-format :default))
"Opens file as input stream and calls ps-compile-stream on it." "Opens file as input stream and calls ps-compile-stream on it."
......
...@@ -204,7 +204,7 @@ CL environment)." ...@@ -204,7 +204,7 @@ CL environment)."
(lookup-macro-def form *symbol-macro-env*)) (lookup-macro-def form *symbol-macro-env*))
(gethash form *symbol-macro-toplevel*))) ;; hack (gethash form *symbol-macro-toplevel*))) ;; hack
(and (consp form) (lookup-macro-def (car form) *macro-env*))) (and (consp form) (lookup-macro-def (car form) *macro-env*)))
(values (ps-macroexpand (funcall it form)) t) (values (ps-macroexpand (extentify (xtent form) (funcall it form))) t)
form)) form))
(defun ps-macroexpand (form) (defun ps-macroexpand (form)
...@@ -255,24 +255,26 @@ form, FORM, returns the new value for *compilation-level*." ...@@ -255,24 +255,26 @@ form, FORM, returns the new value for *compilation-level*."
(if expanded? (if expanded?
(ps-compile expansion) (ps-compile expansion)
,@body)))) ,@body))))
(typecase form (extentify
((or null number string character) (xtent form)
form) (typecase form
(vector ((or null number string character)
(ps-compile `(quote ,(coerce form 'list)))) form)
(symbol (vector
(try-expanding form form)) (ps-compile `(quote ,(coerce form 'list))))
(cons (symbol
(try-expanding form (try-expanding form form))
(let ((*compilation-level* (cons
(adjust-compilation-level form *compilation-level*))) (try-expanding form
(if (special-form? form) (let ((*compilation-level*
(compile-special-form form) (adjust-compilation-level form *compilation-level*)))
`(ps-js:funcall (if (special-form? form)
,(if (symbolp (car form)) (compile-special-form form)
(maybe-rename-local-function (car form)) `(ps-js:funcall
(compile-expression (car form))) ,(if (symbolp (car form))
,@(mapcar #'compile-expression (cdr form)))))))))) (maybe-rename-local-function (car form))
(compile-expression (car form)))
,@(mapcar #'compile-expression (cdr form)))))))))))
(defun compile-statement (form) (defun compile-statement (form)
(let ((compile-expression? nil)) (let ((compile-expression? nil))
......
...@@ -58,10 +58,15 @@ Syntax of key spec: ...@@ -58,10 +58,15 @@ Syntax of key spec:
`(progn `(progn
(var ,suppl (not (eql ,name undefined))) (var ,suppl (not (eql ,name undefined)))
,@(when value ,@(when value
`((when (not ,suppl) (setf ,name ,value)))))) (list
(extentify
(xtent opt-spec)
`(when (not ,suppl) (setf ,name ,value)))))))
(value (value
`(when (eql ,name undefined) (extentify
(setf ,name ,value)))))) (xtent opt-spec)
`(when (eql ,name undefined)
(setf ,name ,value)))))))
optionals)) optionals))
(key-forms (key-forms
(when keys? (when keys?
...@@ -71,7 +76,11 @@ Syntax of key spec: ...@@ -71,7 +76,11 @@ Syntax of key spec:
(lambda (k) (lambda (k)
(multiple-value-bind (var init-form keyword-str suppl) (multiple-value-bind (var init-form keyword-str suppl)
(parse-key-spec k) (parse-key-spec k)
(push `(var ,var ,@(when init-form `((if (undefined ,var) ,init-form ,var)))) defaults) (push (extentify
(xtent k)
`(var ,var ,@(when init-form
`((if (undefined ,var) ,init-form ,var)))))
defaults)
(when suppl (push `(var ,suppl) defaults)) (when suppl (push `(var ,suppl) defaults))
(push `(,keyword-str (push `(,keyword-str
(setf ,var (aref arguments (1+ ,n)) (setf ,var (aref arguments (1+ ,n))
...@@ -97,7 +106,9 @@ Syntax of key spec: ...@@ -97,7 +106,9 @@ Syntax of key spec:
key-forms key-forms
(awhen rest-form (list it)) (awhen rest-form (list it))
(if docstring (rest body) body)))) (if docstring (rest body) body))))
(values effective-args effective-body docstring)))) (values (extentify (xtent lambda-list) effective-args)
effective-body
docstring))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; common ;;; common
...@@ -203,13 +214,16 @@ Syntax of key spec: ...@@ -203,13 +214,16 @@ Syntax of key spec:
(ps-compile (with-lambda-scope `(,',special-op ,fn-defs ,@body))))) (ps-compile (with-lambda-scope `(,',special-op ,fn-defs ,@body)))))
(defun compile-local-function-defs (fn-defs renames) (defun compile-local-function-defs (fn-defs renames)
(loop for (fn-name . (args . body)) in fn-defs collect (loop for fn-def in fn-defs collect
(progn (when compile-expression? (destructuring-bind (fn-name . (args . body)) fn-def
(push (getf renames fn-name) (progn (when compile-expression?
*vars-needing-to-be-declared*)) (push (getf renames fn-name)
(list (if compile-expression? 'ps-js:= 'ps-js:var) *vars-needing-to-be-declared*))
(getf renames fn-name) (extentify
(compile-named-local-function fn-name args body))))) (xtent fn-def)
(list (if compile-expression? 'ps-js:= 'ps-js:var)
(getf renames fn-name)
(compile-named-local-function fn-name args body)))))))
(define-expression-operator flet (fn-defs &rest body) (define-expression-operator flet (fn-defs &rest body)
(local-functions flet (local-functions flet
......
This diff is collapsed.
...@@ -27,18 +27,21 @@ ...@@ -27,18 +27,21 @@
(define-statement-operator switch (test-expr &rest clauses) (define-statement-operator switch (test-expr &rest clauses)
`(ps-js:switch ,(compile-expression test-expr) `(ps-js:switch ,(compile-expression test-expr)
,@(loop for (val . body) in clauses collect ,@(loop :for clause :in clauses :collect
(destructuring-bind (val . body) clause
(extentify
(xtent clause)
(cons (if (eq val 'default) (cons (if (eq val 'default)
'ps-js:default 'ps-js:default
(let ((in-case? t)) (let ((in-case? t))
(compile-expression val))) (compile-expression val)))
(mapcan (lambda (x) (mapcan (lambda (x)
(let* ((in-case? t) (let* ((in-case? t)
(exp (compile-statement x))) (exp (compile-statement x)))
(if (and (listp exp) (eq 'ps-js:block (car exp))) (if (and (listp exp) (eq 'ps-js:block (car exp)))
(cdr exp) (cdr exp)
(list exp)))) (list exp))))
body))))) body)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; objects ;;; objects
...@@ -46,20 +49,22 @@ ...@@ -46,20 +49,22 @@
(define-expression-operator create (&rest arrows) (define-expression-operator create (&rest arrows)
`(ps-js:object `(ps-js:object
,@(loop for (key val-expr) on arrows by #'cddr collecting ,@(loop for (key val-expr) on arrows by #'cddr collecting
(cons (cond ((and (symbolp key) (reserved-symbol-p key)) (cons (extentify
(reserved-symbol-p key)) (xtent key)
((or (stringp key) (numberp key) (symbolp key)) (cond ((and (symbolp key) (reserved-symbol-p key))
key) (reserved-symbol-p key))
((and (consp key) ((or (stringp key) (numberp key) (symbolp key))
(eq 'quote (first key)) key)
(symbolp (second key)) ((and (consp key)
(null (third key))) (eq 'quote (first key))
(symbol-to-js-string (second key))) (symbolp (second key))
(t (null (third key)))
(error (symbol-to-js-string (second key)))
"Slot key ~s is not one of symbol, string or number." (t
key))) (error
(compile-expression val-expr))))) "Slot key ~s is not one of symbol, string or number."
key))))
(compile-expression val-expr)))))
(define-expression-operator %js-getprop (obj slot) (define-expression-operator %js-getprop (obj slot)
(let ((expanded-slot (ps-macroexpand slot)) (let ((expanded-slot (ps-macroexpand slot))
...@@ -68,8 +73,8 @@ ...@@ -68,8 +73,8 @@
(eq 'quote (car expanded-slot))) (eq 'quote (car expanded-slot)))
(aif (or (reserved-symbol-p (second expanded-slot)) (aif (or (reserved-symbol-p (second expanded-slot))
(and (keywordp (second expanded-slot)) (second expanded-slot))) (and (keywordp (second expanded-slot)) (second expanded-slot)))
`(ps-js:aref ,obj ,it) `(ps-js:aref ,obj ,(extentify (xtent expanded-slot) it))
`(ps-js:getprop ,obj ,(second expanded-slot))) `(ps-js:getprop ,obj ,(extentify (xtent expanded-slot) (second expanded-slot))))
`(ps-js:aref ,obj ,(compile-expression slot))))) `(ps-js:aref ,obj ,(compile-expression slot)))))
(defpsmacro getprop (obj &rest slots) (defpsmacro getprop (obj &rest slots)
...@@ -106,7 +111,7 @@ ...@@ -106,7 +111,7 @@
(let ((value (ps-macroexpand value))) (let ((value (ps-macroexpand value)))
(if (and (listp value) (eq 'progn (car value))) (if (and (listp value) (eq 'progn (car value)))
(ps-compile `(progn ,@(butlast (cdr value)) (ps-compile `(progn ,@(butlast (cdr value))
(var ,name ,(car (last value))))) ,`(var ,name ,(car (last value)))))
`(ps-js:var ,(ps-macroexpand name) `(ps-js:var ,(ps-macroexpand name)
,@(when value? (list (compile-expression value) docstr)))))) ,@(when value? (list (compile-expression value) docstr))))))
...@@ -118,14 +123,16 @@ ...@@ -118,14 +123,16 @@
(define-statement-operator for (init-forms cond-forms step-forms &body body) (define-statement-operator for (init-forms cond-forms step-forms &body body)
(let ((init-forms (make-for-vars/inits init-forms))) (let ((init-forms (make-for-vars/inits init-forms)))
`(ps-js:for ,init-forms `(ps-js:for ,init-forms
,(mapcar #'compile-expression cond-forms) ,(extentify (xtent cond-forms) (mapcar #'compile-expression cond-forms))
,(mapcar #'compile-expression step-forms) ,(extentify (xtent step-forms) (mapcar #'compile-expression step-forms))
,(compile-loop-body (mapcar #'car init-forms) body)))) ,(compile-loop-body (mapcar #'car init-forms) body))))
(define-statement-operator for-in ((var object) &rest body) (define-statement-operator for-in (pair &rest body)
`(ps-js:for-in ,(compile-expression var) (destructuring-bind (var object) pair
,(compile-expression object) `(ps-js:for-in ,(extentify (xtent pair)
,(compile-loop-body (list var) body))) (list (compile-expression var)
(compile-expression object)))
,(compile-loop-body (list var) body))))
(define-statement-operator while (test &rest body) (define-statement-operator while (test &rest body)
`(ps-js:while ,(compile-expression test) `(ps-js:while ,(compile-expression test)
...@@ -137,19 +144,24 @@ ...@@ -137,19 +144,24 @@
;;; misc ;;; misc
(define-statement-operator try (form &rest clauses) (define-statement-operator try (form &rest clauses)
(let ((catch (cdr (assoc :catch clauses))) (let* ((tagged-catch (assoc :catch clauses))
(finally (cdr (assoc :finally clauses)))) (catch (cdr tagged-catch))
(assert (not (cdar catch)) () (tagged-finally (assoc :finally clauses))
"Sorry, currently only simple catch forms are supported.") (finally (cdr tagged-finally)))
(assert (or catch finally) () (assert (or catch finally) ()
"Try form should have either a catch or a finally clause or both.") "Try form should have either a catch or a finally clause or both.")
`(ps-js:try (let ((err-form (car catch)))
,(compile-statement `(progn ,form)) (assert (not (cdr err-form)) ()
:catch ,(when catch "Sorry, currently only simple catch forms are supported.")
(list (caar catch) `(ps-js:try
(compile-statement `(progn ,@(cdr catch))))) ,(compile-statement `(progn ,form))
:finally ,(when finally ,(when catch
(compile-statement `(progn ,@finally)))))) (extentify (xtent tagged-catch)
(list (extentify (xtent err-form) (car err-form))
(compile-statement `(progn ,@(cdr catch))))))
,(when finally
(extentify (xtent tagged-finally)
(compile-statement `(progn ,@finally))))))))
(define-expression-operator regex (regex) (define-expression-operator regex (regex)
`(ps-js:regex ,(string regex))) `(ps-js:regex ,(string regex)))
...@@ -179,7 +191,7 @@ ...@@ -179,7 +191,7 @@
(defpsmacro [] (&rest args) (defpsmacro [] (&rest args)
`(array ,@(mapcar (lambda (arg) `(array ,@(mapcar (lambda (arg)
(if (and (consp arg) (not (equal '[] (car arg)))) (if (and (consp arg) (not (equal '[] (car arg))))
(cons '[] arg) (extentify (xtent arg) (cons '[] arg))
arg)) arg))
args))) args)))
......
...@@ -29,8 +29,11 @@ vice-versa.") ...@@ -29,8 +29,11 @@ vice-versa.")
(declare (special %psw-accumulator)) (declare (special %psw-accumulator))
(with-standard-io-syntax (with-standard-io-syntax
(if (and (listp form) (eq 'ps-js:block (car form))) ; ignore top-level block (if (and (listp form) (eq 'ps-js:block (car form))) ; ignore top-level block
(loop for (statement . remaining) on (cdr form) do (do-source-map (xtent form)
(ps-print statement) (psw #\;) (when remaining (psw #\Newline))) (loop for (statement . remaining) on (cdr form) do
(ps-print statement)
(psw #\;)
(when remaining (psw #\Newline))))
(ps-print form))) (ps-print form)))
(unless immediate? (unless immediate?
(reverse (cons (get-output-stream-string *psw-stream*) (reverse (cons (get-output-stream-string *psw-stream*)
...@@ -96,7 +99,8 @@ vice-versa.") ...@@ -96,7 +99,8 @@ vice-versa.")
(psw (symbol-to-js-string s)))) (psw (symbol-to-js-string s))))
(defmethod ps-print ((compiled-form cons)) (defmethod ps-print ((compiled-form cons))
(ps-print% (car compiled-form) (cdr compiled-form))) (do-source-map (xtent compiled-form)
(ps-print% (car compiled-form) (cdr compiled-form))))
(defun newline-and-indent (&optional indent-spaces) (defun newline-and-indent (&optional indent-spaces)
(if *ps-print-pretty* (if *ps-print-pretty*
...@@ -257,10 +261,16 @@ vice-versa.") ...@@ -257,10 +261,16 @@ vice-versa.")
(print-fun-def name args body-block)) (print-fun-def name args body-block))
(defun print-fun-def (name args body) (defun print-fun-def (name args body)
(format *psw-stream* "function ~:[~;~A~](" name (symbol-to-js-string name)) (format *psw-stream* "function ")
(loop for (arg . remaining) on args do (when name
(psw (symbol-to-js-string arg)) (when remaining (psw ", "))) (do-source-map (xtent name)
(psw ") ") (format *psw-stream* "~A" (symbol-to-js-string name))))
(do-source-map (xtent args)
(psw "(")
(loop for (arg . remaining) on args do
(psw (symbol-to-js-string arg)) (when remaining (psw ", ")))
(psw ")"))
(psw " ")
(ps-print body)) (ps-print body))
(defprinter ps-js:object (&rest slot-defs) (defprinter ps-js:object (&rest slot-defs)
...@@ -285,7 +295,9 @@ vice-versa.") ...@@ -285,7 +295,9 @@ vice-versa.")
(psw "}")))) (psw "}"))))
(defprinter ps-js:getprop (obj slot) (defprinter ps-js:getprop (obj slot)
(print-op-argument op obj)"."(psw (symbol-to-js-string slot))) (print-op-argument op obj) "."
(do-source-map (xtent slot)
(psw (symbol-to-js-string slot))))
(defprinter ps-js:if (test consequent &rest clauses) (defprinter ps-js:if (test consequent &rest clauses)
"if (" (ps-print test) ") " "if (" (ps-print test) ") "
...@@ -319,21 +331,33 @@ vice-versa.") ...@@ -319,21 +331,33 @@ vice-versa.")
;;; iteration ;;; iteration
(defprinter ps-js:for (vars tests steps body-block) (defprinter ps-js:for (vars tests steps body-block)
"for (" "for ("
(loop for ((var-name . var-init) . remaining) on vars (do-source-map (xtent vars)
for decl = "var " then "" do (loop for (var . remaining) on vars
(psw decl (symbol-to-js-string var-name) " = ") (ps-print var-init) for decl = "var " then "" do
(when remaining (psw ", "))) (destructuring-bind (name . init) var
(do-source-map (xtent var)
(psw decl (symbol-to-js-string name) " = ")
(ps-print init)))
(when remaining (psw ", "))))
"; " "; "
(loop for (test . remaining) on tests do (do-source-map (xtent tests)
(ps-print test) (when remaining (psw ", "))) (loop for (test . remaining) on tests do
(ps-print test)
(when remaining (psw ", "))))
"; " "; "
(loop for (step . remaining) on steps do (do-source-map (xtent steps)
(ps-print step) (when remaining (psw ", "))) (loop for (step . remaining) on steps do
(ps-print step)
(when remaining (psw ", "))))
") " ") "
(ps-print body-block)) (ps-print body-block))
(defprinter ps-js:for-in (var object body-block) (defprinter ps-js:for-in (pair body-block)
"for (var "(ps-print var)" in "(ps-print object)") " "for "
(destructuring-bind (var object) pair
(do-source-map (xtent pair)
(psw "(var ") (ps-print var) (psw " in ") (ps-print object) (psw ")")))
" "
(ps-print body-block)) (ps-print body-block))
(defprinter (ps-js:with ps-js:while) (expression body-block) (defprinter (ps-js:with ps-js:while) (expression body-block)
...@@ -349,23 +373,28 @@ vice-versa.") ...@@ -349,23 +373,28 @@ vice-versa.")
(ps-print statement) (ps-print statement)
(psw #\;)) (psw #\;))
(decf *indent-level*))) (decf *indent-level*)))
(loop for (val . statements) in clauses do (loop for clause in clauses do
(newline-and-indent) (destructuring-bind (val . statements) clause
(if (eq val 'ps-js:default) (newline-and-indent)
(progn (psw "default:") (do-source-map (xtent clause)
(print-body statements)) (if (eq val 'ps-js:default)
(progn (psw "case ") (ps-print val) (psw #\:) (progn (psw "default:")
(print-body statements))))) (print-body statements))
(progn (psw "case ") (ps-print val) (psw #\:)
(print-body statements)))))))
(newline-and-indent) (newline-and-indent)
"}") "}")
(defprinter ps-js:try (body-block &key catch finally) (defprinter ps-js:try (body-block catch finally)
"try "(ps-print body-block) "try "(ps-print body-block)
(when catch (when catch
(psw " catch ("(symbol-to-js-string (first catch))") ") (do-source-map (xtent catch)
(ps-print (second catch))) (psw " catch ("(symbol-to-js-string (first catch))") ")
(ps-print (second catch))))
(when finally (when finally
(psw " finally ") (ps-print finally))) (do-source-map (xtent finally)
(psw " finally ")
(ps-print finally))))
(defprinter ps-js:regex (regex) (defprinter ps-js:regex (regex)
(let ((slash (unless (and (> (length regex) 0) (char= (char regex 0) #\/)) "/"))) (let ((slash (unless (and (> (length regex) 0) (char= (char regex 0) #\/)) "/")))
......
(in-package #:parenscript)
(in-readtable :parenscript)
(defparameter *text-extents* nil
"EQ hash table mapping conses read by the reader to the integer
interval of positions from the stream they were read in from.")
(defun extentify (xt form)
(when (and *text-extents* xt)
(unless (or (symbolp form) (numberp form))
(setf (gethash form *text-extents*) xt)))
form)
(defun xtent (form)
"The text extent, if there is one, for FORM."
(when *text-extents*
(gethash form *text-extents*)))
(defun make-extent-preserving-readtable (prior-readtable)
(let ((readtable (copy-readtable prior-readtable)))
(flet ((wrap (char)
(let ((curfn (get-macro-character char prior-readtable)))
(flet ((newfn (stream char)
(cond ((and (eq char #\#) (not (eq (peek-char nil stream) #\()))
;; we override # for vectors only
(funcall curfn stream char))
(t (let ((n (1- (file-position stream)))
(form (funcall curfn stream char))
(n+ (file-position stream)))
(extentify (list n n+) form))))))
(set-macro-character char #'newfn nil readtable)))))
(mapc #'wrap (list #\( #\' #\#))
readtable)))
(defun extent-union (forms)
(let (pos1 pos2)
(loop :for (n n+) :in (mapcar #'xtent forms)
:when n :do (setf pos1 (min n (or pos1 n)))
:when n+ :do (setf pos2 (max n+ (or pos2 n+))))
(when (and pos1 pos2)
(list pos1 pos2))))
(defun make-progn (body)
"Make a PROGN node for the forms in BODY with a source mapping
encompassing those forms."
(extentify (extent-union body) `(progn ,@body)))
(defun make-return-from (tag form)
"Make a return statement with the same source mapping as the form it returns."
(extentify (xtent form) `(return-from ,tag ,form)))
(defparameter *source-maps* nil
"A list associating text extents (intervals of stream positions) of
PS source code with text extents of corresponding JS code. These intervals
are form-based, not line-based; that is, they map s-exprs in the PS
source to the range of JS text emitted for that s-expr.")
(defun report-source-map (xt js1 js2)
(destructuring-bind (ps1 ps2) xt
(when (member (list ps1 ps2 js1 js2) *source-maps* :test #'equal)
(error "Duplicate source map reported: ~a." (list ps1 ps2 js1 js2)))
(push (list ps1 ps2 js1 js2) *source-maps*)))
(defmacro do-source-map (xt &body body)
(let ((pos (gensym "pos")))
`(let ((,pos (when ,xt (file-position *psw-stream*))))
,@body
(when ,xt
(report-source-map ,xt ,pos (file-position *psw-stream*))))))
This diff is collapsed.
...@@ -19,7 +19,7 @@ ...@@ -19,7 +19,7 @@
3; 3;
};") };")
(test-ps-js symbol-conversion-1 (test-ps-js (symbol-conversion-1 :suppress-source-maps? t) ; because # scares the reader
!?#@% !?#@%
"bangwhathashatpercent;") "bangwhathashatpercent;")
......
This diff is collapsed.
...@@ -35,13 +35,79 @@ ...@@ -35,13 +35,79 @@
(same-space-between-statements (same-space-between-statements
(normalize-whitespace str)))))) (normalize-whitespace str))))))
(defmacro test-ps-js (testname parenscript javascript (defmacro test-ps-js (testspec parenscript javascript
&key (js-target-version *js-target-version*)) &key (js-target-version *js-target-version*))
`(test ,testname () (let ((testname (if (consp testspec) (first testspec) testspec))
(is (string= (normalize-js-code ,javascript) (srcmaps? (destructuring-bind (&key suppress-source-maps?)
(normalize-js-code (when (consp testspec) (cdr testspec))
(let ((*js-target-version* ,js-target-version)) (not suppress-source-maps?))))
(ps-doc* ',parenscript))))))) `(progn
(test ,testname ()
(is (string= (normalize-js-code ,javascript)
(normalize-js-code
(let ((*js-target-version* ,js-target-version))
(ps-doc* ',parenscript))))))
,(when srcmaps?
;; upcase because our readtable inverts it
`(test ,(intern (string-upcase (format nil "~a--~a" testname 'srcmap))) ()
(is (string= (normalize-js-code ,javascript)
(normalize-js-code
(let ((*js-target-version* ,js-target-version))
(streamify-and-compile-with-source-maps ',parenscript))))))))))
(defun streamify-and-compile-with-source-maps (form)
(let ((s (make-string-output-stream)))
(write form :stream s)
(let ((parenscript (get-output-stream-string s)))
(ps::with-blank-compilation-environment
(with-input-from-string (s parenscript)
(ps::ps-compile-stream s t))))))
(defun sort-by-js-then-ps-scope (source-maps)
(sort source-maps
(lambda (a b)
(destructuring-bind (aps1 aps2 ajs1 ajs2) a
(destructuring-bind (bps1 bps2 bjs1 bjs2) b
(cond ((< ajs1 bjs1) t)
((< bjs1 ajs1) nil)
((< bjs2 ajs2) t) ;; prioritize the one that extends further
((< aps1 bps1) t)
((< bps1 aps1) nil)
((< bps2 aps2) t) ;; ditto
))))))
(defun ps-and-corresponding-js (parenscript)
(ps::with-blank-compilation-environment
(with-input-from-string (s parenscript)
(multiple-value-bind (javascript source-maps) (ps::ps-compile-stream s t)
(loop :for (ps1 ps2 js1 js2) :in (sort-by-js-then-ps-scope source-maps)
:collect (list (subseq parenscript ps1 ps2) (subseq javascript js1 js2)))))))
(defun ps-and-js-with-topmost-removed (parenscript)
(let ((pairs (ps-and-corresponding-js parenscript)))
(cond ((not (cdr pairs)) pairs)
(t
;; Remove duplicate case where the first ps-js pair is
;; identical to the second except for a trailing semicolon
(destructuring-bind (ps1 js1) (first pairs)
(destructuring-bind (ps2 js2) (second pairs)
(if (and (equal ps1 ps2)
(= (length js1) (1+ (length js2)))
(equal js1 (concatenate 'string js2 ";")))
(cdr pairs)
pairs)))))))
(defmacro test-source-maps (testspec &body ps-and-js-pairs)
(let ((testname (if (consp testspec) (first testspec) testspec))
(parenscript (if (consp testspec) (second testspec) (caar ps-and-js-pairs))))
`(test ,testname
(let ((actual (ps-and-js-with-topmost-removed ,parenscript)))
(is (= (length actual) ,(length ps-and-js-pairs))
"Expected ~a source mappings, got ~a" ,(length ps-and-js-pairs) (length actual))
(loop :for (actual-ps actual-js) :in actual
:for (exp-ps exp-js) :in ',ps-and-js-pairs :for i :from 0 :do
(is (equal actual-ps exp-ps) "Mapping ~a: expected ps ~s, got ~s" i exp-ps actual-ps)
(is (equal actual-js exp-js) "Mapping ~a: expected js ~s, got ~s" i exp-js actual-js))))))
(defun jsarray (contents) (defun jsarray (contents)
(cl-js:js-array (cl-js:js-array
...@@ -74,6 +140,7 @@ ...@@ -74,6 +140,7 @@
(def-suite output-tests :in parenscript-tests) (def-suite output-tests :in parenscript-tests)
(def-suite package-system-tests :in parenscript-tests) (def-suite package-system-tests :in parenscript-tests)
(def-suite eval-tests :in parenscript-tests) (def-suite eval-tests :in parenscript-tests)
(def-suite sourcemap-tests :in parenscript-tests)
(defun run-tests() (defun run-tests()
(format t "Running output tests:~&") (format t "Running output tests:~&")
...@@ -81,4 +148,6 @@ ...@@ -81,4 +148,6 @@
(format t "Running package system tests:~&") (format t "Running package system tests:~&")
(run! 'package-system-tests) (run! 'package-system-tests)
(format t "Running CL-JavaScript eval tests:~&") (format t "Running CL-JavaScript eval tests:~&")
(run! 'eval-tests)) (run! 'eval-tests)
(format t "Running source map tests:~&")
(run! 'sourcemap-tests))