...
 
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 @@
(:file "js-ir-package")
(:file "utils")
(:file "namespace")
(:file "source-mappings")
(:file "compiler")
(:file "printer")
(:file "compilation-interface")
......
......@@ -9,5 +9,6 @@
(:file "test")
(:file "output-tests")
(:file "package-system-tests")
(:file "eval-tests"))))
(:file "eval-tests")
(:file "srcmap-tests"))))
:depends-on (:parenscript :eos :cl-js))
......@@ -35,7 +35,7 @@ which writes the resulting code to stream."
bound, writes the output to *parenscript-stream*, otherwise returns a
string."
(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*
(get-output-stream-string *psw-stream*))))
......@@ -68,21 +68,27 @@ string."
(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
the read function) Parenscript forms from stream and compiles them as
if by ps*. If *parenscript-stream* is bound, writes the output to
*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)
(*readtable* *readtable*)
(*text-extents* (when source-mapping? (make-hash-table :test 'eq)))
(*readtable* (if source-mapping?
(make-extent-preserving-readtable *readtable*)
*readtable*))
(*package* *package*)
(*parenscript-stream* output-stream)
(eof '#:eof))
(loop for form = (funcall *ps-read-function* stream nil eof)
until (eq form eof) do (ps* form) (fresh-line *parenscript-stream*)))
(values
(unless *parenscript-stream*
(get-output-stream-string output-stream))))
(get-output-stream-string output-stream))
*source-maps*)))
(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."
......
......@@ -204,7 +204,7 @@ CL environment)."
(lookup-macro-def form *symbol-macro-env*))
(gethash form *symbol-macro-toplevel*))) ;; hack
(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))
(defun ps-macroexpand (form)
......@@ -255,6 +255,8 @@ form, FORM, returns the new value for *compilation-level*."
(if expanded?
(ps-compile expansion)
,@body))))
(extentify
(xtent form)
(typecase form
((or null number string character)
form)
......@@ -272,7 +274,7 @@ form, FORM, returns the new value for *compilation-level*."
,(if (symbolp (car form))
(maybe-rename-local-function (car form))
(compile-expression (car form)))
,@(mapcar #'compile-expression (cdr form))))))))))
,@(mapcar #'compile-expression (cdr form)))))))))))
(defun compile-statement (form)
(let ((compile-expression? nil))
......
......@@ -58,10 +58,15 @@ Syntax of key spec:
`(progn
(var ,suppl (not (eql ,name undefined)))
,@(when value
`((when (not ,suppl) (setf ,name ,value))))))
(list
(extentify
(xtent opt-spec)
`(when (not ,suppl) (setf ,name ,value)))))))
(value
(extentify
(xtent opt-spec)
`(when (eql ,name undefined)
(setf ,name ,value))))))
(setf ,name ,value)))))))
optionals))
(key-forms
(when keys?
......@@ -71,7 +76,11 @@ Syntax of key spec:
(lambda (k)
(multiple-value-bind (var init-form keyword-str suppl)
(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))
(push `(,keyword-str
(setf ,var (aref arguments (1+ ,n))
......@@ -97,7 +106,9 @@ Syntax of key spec:
key-forms
(awhen rest-form (list it))
(if docstring (rest body) body))))
(values effective-args effective-body docstring))))
(values (extentify (xtent lambda-list) effective-args)
effective-body
docstring))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; common
......@@ -203,13 +214,16 @@ Syntax of key spec:
(ps-compile (with-lambda-scope `(,',special-op ,fn-defs ,@body)))))
(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
(destructuring-bind (fn-name . (args . body)) fn-def
(progn (when compile-expression?
(push (getf renames fn-name)
*vars-needing-to-be-declared*))
(extentify
(xtent fn-def)
(list (if compile-expression? 'ps-js:= 'ps-js:var)
(getf renames fn-name)
(compile-named-local-function fn-name args body)))))
(compile-named-local-function fn-name args body)))))))
(define-expression-operator flet (fn-defs &rest body)
(local-functions flet
......
......@@ -157,23 +157,26 @@
'(with label let flet labels macrolet symbol-macrolet progn)))
(pop form))))
(if progn-form
(extentify
(xtent form)
`(,progn-form
,@(butlast form)
(multiple-value-bind ,vars
,@(last form)
,@body))
,@body)))
;; assume function call
(with-ps-gensyms (prev-mv)
(let* ((fun-exp (car form))
(funobj (if (symbolp fun-exp)
fun-exp
(ps-gensym "funobj"))))
(ps-gensym "funobj")))
(callable (extentify (xtent form) `(,funobj ,@(cdr form)))))
`(let (,@(unless (symbolp fun-exp) `((,funobj ,fun-exp)))
(,prev-mv (if (undefined __PS_MV_REG)
(setf __PS_MV_REG undefined)
__PS_MV_REG)))
(try
(let ((,(car vars) (,funobj ,@(cdr form))))
(let ((,(car vars) ,callable))
(destructuring-bind (&optional ,@(cdr vars))
(if (eql ,funobj (@ __PS_MV_REG :tag))
(@ __PS_MV_REG :values)
......@@ -185,32 +188,34 @@
(defpsmacro case (value &rest clauses)
(let ((allowed-symbols '(t otherwise false %true)))
(labels ((make-switch-clause (val body more)
(labels ((make-switch-clause (clause more?)
(destructuring-bind (val . body) clause
(cond ((listp val)
(append (mapcar #'list (butlast val))
(make-switch-clause
(if (eq t (car (last val))) ;; literal 'true'
(let ((val+ (if (eq t (car (last val))) ;; literal 'true'
'%true
(car (last val)))
body
more)))
(car (last val)))))
(make-switch-clause
(extentify
(xtent clause)
(cons (extentify (xtent val) val+) body)) more?))))
((and (symbolp val)
(symbolp (ps-macroexpand-1 val))
(not (keywordp val))
(not (member val allowed-symbols)))
(error "Parenscript only supports keywords, numbers, and string literals as keys in case clauses. ~S is a symbol in clauses ~S"
val clauses))
(t
`((,(case val
(t (let ((val+ (case val
((t otherwise) 'default)
(%true t)
(t (ps-macroexpand-1 val)))
(t (ps-macroexpand-1 val)))))
(list (extentify
(xtent clause)
`(,(extentify (xtent val) val+)
,@body
,@(when more '(break))))))))
`(switch ,value ,@(mapcon (lambda (clause)
(make-switch-clause (car (first clause))
(cdr (first clause))
(rest clause)))
,@(when more? '(break)))))))))))
`(switch ,value ,@(mapcon (lambda (rest)
(make-switch-clause (car rest) (not (null (cdr rest)))))
clauses)))))
(defpsmacro when (test &rest body)
......@@ -234,7 +239,7 @@ lambda-list::=
`(defun% ,name ,lambda-list ,@body))
(progn (assert (and (listp name) (= (length name) 2) (eq 'setf (car name))) ()
"(defun ~s ~s ...) needs to have a symbol or (setf symbol) for a name." name lambda-list)
`(defun-setf ,(second name) ,lambda-list ,@body))))
`(defun-setf ,(extentify (xtent name) (second name)) ,lambda-list ,@body))))
;;; defining setf expanders
......@@ -247,7 +252,7 @@ lambda-list::=
(setf (gethash name *setf-expanders*)
(lambda (access-args store-form)
`(,mangled-function-name ,store-form ,@access-args)))
`(defun ,mangled-function-name ,lambda-list ,@body)))
`(defun ,(extentify (xtent name) mangled-function-name) ,lambda-list ,@body)))
;;; slightly broken WRT lambda lists
(defpsmacro defsetf-long (access-fn lambda-list (store-var) form)
......@@ -284,13 +289,15 @@ lambda-list::=
;;; setf
(defpsmacro setf (&rest args)
(defpsmacro setf (&whole whole &rest args)
(assert (evenp (length args)) ()
"~s does not have an even number of arguments." `(setf ,args))
`(progn ,@(loop for (place value) on args by #'cddr collect
(extentify
(or (xtent whole) (extent-union (list place value)))
(aif (and (listp place) (gethash (car place) *setf-expanders*))
(funcall it (cdr place) value)
`(ps-assign ,place ,value)))))
`(ps-assign ,place ,value ,(xtent whole)))))))
(defpsmacro psetf (&rest args)
(let ((places (loop for x in args by #'cddr collect x))
......@@ -316,31 +323,41 @@ lambda-list::=
;;; iteration
(defun do-make-iteration-bindings (decls)
(extentify
(xtent decls)
(mapcar (lambda (x)
(cond ((atom x) x)
((endp (cdr x)) (list (car x)))
(t (subseq x 0 2))))
((endp (cdr x)) x)
(t (extentify (xtent x) (subseq x 0 2)))))
decls)))
(defun do-make-end-tests (end-test)
(list (extentify (xtent end-test) `(not ,end-test))))
(defun stepping-decls (decls)
(remove-if (lambda (x)
(or (atom x) (< (length x) 3)))
decls))
(defun do-make-for-steps (decls)
(extentify
(xtent decls)
(mapcar (lambda (x)
`(setf ,(first x) ,(third x)))
(remove-if (lambda (x)
(or (atom x) (< (length x) 3)))
decls)))
(extentify (xtent x) `(setf ,(first x) ,(third x))))
(stepping-decls decls))))
(defun do-make-iter-psteps (decls)
(extentify
(xtent decls)
`(psetq
,@(mapcan (lambda (x)
(list (first x) (third x)))
(remove-if (lambda (x)
(or (atom x) (< (length x) 3)))
decls))))
(stepping-decls decls)))))
(defpsmacro do* (decls (end-test &optional (result nil result?)) &body body)
`(block nil
(for ,(do-make-iteration-bindings decls)
((not ,end-test))
,(do-make-end-tests end-test)
,(do-make-for-steps decls)
,@body)
,@(when result? (list result))))
......@@ -348,7 +365,9 @@ lambda-list::=
(defpsmacro do (decls (end-test &optional (result nil result?)) &body body)
`(block nil
(let ,(do-make-iteration-bindings decls)
(for () ((not ,end-test)) ()
(for ()
,(do-make-end-tests end-test)
()
,@body
,(do-make-iter-psteps decls))
,@(when result? (list result)))))
......@@ -408,9 +427,10 @@ lambda-list::=
(t `(,'destructuring-bind ,var (aref ,arr ,n) ,inner-body)))))))
(defpsmacro destructuring-bind (bindings expr &body body)
(setf bindings (dot->rest bindings))
(let* ((arr (if (hoist-expr? bindings expr) (ps-gensym "_DB") expr))
(bound (destructuring-wrap arr 0 bindings (cons 'progn body))))
(let* ((bindings (dot->rest bindings))
(arr (if (hoist-expr? bindings expr) (ps-gensym "_DB") expr))
(bound (extentify (xtent bindings)
(destructuring-wrap arr 0 bindings (cons 'progn body)))))
(cond ((eq arr expr) bound)
(t `(let ((,arr ,expr)) ,bound)))))
......
......@@ -27,7 +27,10 @@
(define-statement-operator switch (test-expr &rest clauses)
`(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)
'ps-js:default
(let ((in-case? t))
......@@ -38,7 +41,7 @@
(if (and (listp exp) (eq 'ps-js:block (car exp)))
(cdr exp)
(list exp))))
body)))))
body)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; objects
......@@ -46,7 +49,9 @@
(define-expression-operator create (&rest arrows)
`(ps-js:object
,@(loop for (key val-expr) on arrows by #'cddr collecting
(cons (cond ((and (symbolp key) (reserved-symbol-p key))
(cons (extentify
(xtent key)
(cond ((and (symbolp key) (reserved-symbol-p key))
(reserved-symbol-p key))
((or (stringp key) (numberp key) (symbolp key))
key)
......@@ -58,7 +63,7 @@
(t
(error
"Slot key ~s is not one of symbol, string or number."
key)))
key))))
(compile-expression val-expr)))))
(define-expression-operator %js-getprop (obj slot)
......@@ -68,8 +73,8 @@
(eq 'quote (car expanded-slot)))
(aif (or (reserved-symbol-p (second expanded-slot))
(and (keywordp (second expanded-slot)) (second expanded-slot)))
`(ps-js:aref ,obj ,it)
`(ps-js:getprop ,obj ,(second expanded-slot)))
`(ps-js:aref ,obj ,(extentify (xtent expanded-slot) it))
`(ps-js:getprop ,obj ,(extentify (xtent expanded-slot) (second expanded-slot))))
`(ps-js:aref ,obj ,(compile-expression slot)))))
(defpsmacro getprop (obj &rest slots)
......@@ -106,7 +111,7 @@
(let ((value (ps-macroexpand value)))
(if (and (listp value) (eq 'progn (car value)))
(ps-compile `(progn ,@(butlast (cdr value))
(var ,name ,(car (last value)))))
,`(var ,name ,(car (last value)))))
`(ps-js:var ,(ps-macroexpand name)
,@(when value? (list (compile-expression value) docstr))))))
......@@ -118,14 +123,16 @@
(define-statement-operator for (init-forms cond-forms step-forms &body body)
(let ((init-forms (make-for-vars/inits init-forms)))
`(ps-js:for ,init-forms
,(mapcar #'compile-expression cond-forms)
,(mapcar #'compile-expression step-forms)
,(extentify (xtent cond-forms) (mapcar #'compile-expression cond-forms))
,(extentify (xtent step-forms) (mapcar #'compile-expression step-forms))
,(compile-loop-body (mapcar #'car init-forms) body))))
(define-statement-operator for-in ((var object) &rest body)
`(ps-js:for-in ,(compile-expression var)
,(compile-expression object)
,(compile-loop-body (list var) body)))
(define-statement-operator for-in (pair &rest body)
(destructuring-bind (var object) pair
`(ps-js:for-in ,(extentify (xtent pair)
(list (compile-expression var)
(compile-expression object)))
,(compile-loop-body (list var) body))))
(define-statement-operator while (test &rest body)
`(ps-js:while ,(compile-expression test)
......@@ -137,19 +144,24 @@
;;; misc
(define-statement-operator try (form &rest clauses)
(let ((catch (cdr (assoc :catch clauses)))
(finally (cdr (assoc :finally clauses))))
(assert (not (cdar catch)) ()
"Sorry, currently only simple catch forms are supported.")
(let* ((tagged-catch (assoc :catch clauses))
(catch (cdr tagged-catch))
(tagged-finally (assoc :finally clauses))
(finally (cdr tagged-finally)))
(assert (or catch finally) ()
"Try form should have either a catch or a finally clause or both.")
(let ((err-form (car catch)))
(assert (not (cdr err-form)) ()
"Sorry, currently only simple catch forms are supported.")
`(ps-js:try
,(compile-statement `(progn ,form))
:catch ,(when catch
(list (caar catch)
(compile-statement `(progn ,@(cdr catch)))))
:finally ,(when finally
(compile-statement `(progn ,@finally))))))
,(when catch
(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)
`(ps-js:regex ,(string regex)))
......@@ -179,7 +191,7 @@
(defpsmacro [] (&rest args)
`(array ,@(mapcar (lambda (arg)
(if (and (consp arg) (not (equal '[] (car arg))))
(cons '[] arg)
(extentify (xtent arg) (cons '[] arg))
arg))
args)))
......
......@@ -29,8 +29,11 @@ vice-versa.")
(declare (special %psw-accumulator))
(with-standard-io-syntax
(if (and (listp form) (eq 'ps-js:block (car form))) ; ignore top-level block
(do-source-map (xtent form)
(loop for (statement . remaining) on (cdr form) do
(ps-print statement) (psw #\;) (when remaining (psw #\Newline)))
(ps-print statement)
(psw #\;)
(when remaining (psw #\Newline))))
(ps-print form)))
(unless immediate?
(reverse (cons (get-output-stream-string *psw-stream*)
......@@ -96,7 +99,8 @@ vice-versa.")
(psw (symbol-to-js-string s))))
(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)
(if *ps-print-pretty*
......@@ -257,10 +261,16 @@ vice-versa.")
(print-fun-def name args body-block))
(defun print-fun-def (name args body)
(format *psw-stream* "function ~:[~;~A~](" name (symbol-to-js-string name))
(format *psw-stream* "function ")
(when name
(do-source-map (xtent name)
(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 ")"))
(psw " ")
(ps-print body))
(defprinter ps-js:object (&rest slot-defs)
......@@ -285,7 +295,9 @@ vice-versa.")
(psw "}"))))
(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)
"if (" (ps-print test) ") "
......@@ -319,21 +331,33 @@ vice-versa.")
;;; iteration
(defprinter ps-js:for (vars tests steps body-block)
"for ("
(loop for ((var-name . var-init) . remaining) on vars
(do-source-map (xtent vars)
(loop for (var . remaining) on vars
for decl = "var " then "" do
(psw decl (symbol-to-js-string var-name) " = ") (ps-print var-init)
(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 ", "))))
"; "
(do-source-map (xtent tests)
(loop for (test . remaining) on tests do
(ps-print test) (when remaining (psw ", ")))
(ps-print test)
(when remaining (psw ", "))))
"; "
(do-source-map (xtent steps)
(loop for (step . remaining) on steps do
(ps-print step) (when remaining (psw ", ")))
(ps-print step)
(when remaining (psw ", "))))
") "
(ps-print body-block))
(defprinter ps-js:for-in (var object body-block)
"for (var "(ps-print var)" in "(ps-print object)") "
(defprinter ps-js:for-in (pair body-block)
"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))
(defprinter (ps-js:with ps-js:while) (expression body-block)
......@@ -349,23 +373,28 @@ vice-versa.")
(ps-print statement)
(psw #\;))
(decf *indent-level*)))
(loop for (val . statements) in clauses do
(loop for clause in clauses do
(destructuring-bind (val . statements) clause
(newline-and-indent)
(do-source-map (xtent clause)
(if (eq val 'ps-js:default)
(progn (psw "default:")
(print-body statements))
(progn (psw "case ") (ps-print val) (psw #\:)
(print-body statements)))))
(print-body statements)))))))
(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)
(when catch
(do-source-map (xtent catch)
(psw " catch ("(symbol-to-js-string (first catch))") ")
(ps-print (second catch)))
(ps-print (second catch))))
(when finally
(psw " finally ") (ps-print finally)))
(do-source-map (xtent finally)
(psw " finally ")
(ps-print finally))))
(defprinter ps-js:regex (regex)
(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 @@
3;
};")
(test-ps-js symbol-conversion-1
(test-ps-js (symbol-conversion-1 :suppress-source-maps? t) ; because # scares the reader
!?#@%
"bangwhathashatpercent;")
......
This diff is collapsed.
......@@ -35,13 +35,79 @@
(same-space-between-statements
(normalize-whitespace str))))))
(defmacro test-ps-js (testname parenscript javascript
(defmacro test-ps-js (testspec parenscript javascript
&key (js-target-version *js-target-version*))
`(test ,testname ()
(let ((testname (if (consp testspec) (first testspec) testspec))
(srcmaps? (destructuring-bind (&key suppress-source-maps?)
(when (consp testspec) (cdr testspec))
(not suppress-source-maps?))))
`(progn
(test ,testname ()
(is (string= (normalize-js-code ,javascript)
(normalize-js-code
(let ((*js-target-version* ,js-target-version))
(ps-doc* ',parenscript)))))))
(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)
(cl-js:js-array
......@@ -74,6 +140,7 @@
(def-suite output-tests :in parenscript-tests)
(def-suite package-system-tests :in parenscript-tests)
(def-suite eval-tests :in parenscript-tests)
(def-suite sourcemap-tests :in parenscript-tests)
(defun run-tests()
(format t "Running output tests:~&")
......@@ -81,4 +148,6 @@
(format t "Running package system tests:~&")
(run! 'package-system-tests)
(format t "Running CL-JavaScript eval tests:~&")
(run! 'eval-tests))
(run! 'eval-tests)
(format t "Running source map tests:~&")
(run! 'sourcemap-tests))