...
 
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*)))
(unless *parenscript-stream*
(get-output-stream-string output-stream))))
(values
(unless *parenscript-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,24 +255,26 @@ form, FORM, returns the new value for *compilation-level*."
(if expanded?
(ps-compile expansion)
,@body))))
(typecase form
((or null number string character)
form)
(vector
(ps-compile `(quote ,(coerce form 'list))))
(symbol
(try-expanding form form))
(cons
(try-expanding form
(let ((*compilation-level*
(adjust-compilation-level form *compilation-level*)))
(if (special-form? form)
(compile-special-form form)
`(ps-js:funcall
,(if (symbolp (car form))
(maybe-rename-local-function (car form))
(compile-expression (car form)))
,@(mapcar #'compile-expression (cdr form))))))))))
(extentify
(xtent form)
(typecase form
((or null number string character)
form)
(vector
(ps-compile `(quote ,(coerce form 'list))))
(symbol
(try-expanding form form))
(cons
(try-expanding form
(let ((*compilation-level*
(adjust-compilation-level form *compilation-level*)))
(if (special-form? form)
(compile-special-form form)
`(ps-js:funcall
,(if (symbolp (car form))
(maybe-rename-local-function (car form))
(compile-expression (car 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
`(when (eql ,name undefined)
(setf ,name ,value))))))
(extentify
(xtent opt-spec)
`(when (eql ,name undefined)
(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
(progn (when compile-expression?
(push (getf renames fn-name)
*vars-needing-to-be-declared*))
(list (if compile-expression? 'ps-js:= 'ps-js:var)
(getf renames fn-name)
(compile-named-local-function fn-name args body)))))
(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)))))))
(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
`(,progn-form
,@(butlast form)
(multiple-value-bind ,vars
,@(last form)
,@body))
(extentify
(xtent form)
`(,progn-form
,@(butlast form)
(multiple-value-bind ,vars
,@(last form)
,@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)
(cond ((listp val)
(append (mapcar #'list (butlast val))
(make-switch-clause
(if (eq t (car (last val))) ;; literal 'true'
'%true
(car (last 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 otherwise) 'default)
(%true t)
(t (ps-macroexpand-1 val)))
,@body
,@(when more '(break))))))))
`(switch ,value ,@(mapcon (lambda (clause)
(make-switch-clause (car (first clause))
(cdr (first clause))
(rest clause)))
(labels ((make-switch-clause (clause more?)
(destructuring-bind (val . body) clause
(cond ((listp val)
(append (mapcar #'list (butlast val))
(let ((val+ (if (eq t (car (last val))) ;; literal 'true'
'%true
(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 (let ((val+ (case val
((t otherwise) 'default)
(%true t)
(t (ps-macroexpand-1 val)))))
(list (extentify
(xtent clause)
`(,(extentify (xtent val) val+)
,@body
,@(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)
......@@ -261,7 +266,7 @@ lambda-list::=
access-fn-args
(let* ((,store-var (ps-gensym))
(gensymed-names (loop repeat ,(length var-bindings)
collecting (ps-gensym)))
collecting (ps-gensym)))
(gensymed-arg-bindings (mapcar #'list
gensymed-names
(list ,@var-bindings))))
......@@ -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
(aif (and (listp place) (gethash (car place) *setf-expanders*))
(funcall it (cdr place) value)
`(ps-assign ,place ,value)))))
(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 ,(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)
(mapcar (lambda (x)
(cond ((atom x) x)
((endp (cdr x)) (list (car x)))
(t (subseq x 0 2))))
decls))
(extentify
(xtent decls)
(mapcar (lambda (x)
(cond ((atom x) x)
((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)
(mapcar (lambda (x)
`(setf ,(first x) ,(third x)))
(remove-if (lambda (x)
(or (atom x) (< (length x) 3)))
decls)))
(extentify
(xtent decls)
(mapcar (lambda (x)
(extentify (xtent x) `(setf ,(first x) ,(third x))))
(stepping-decls decls))))
(defun do-make-iter-psteps (decls)
`(psetq
,@(mapcan (lambda (x)
(list (first x) (third x)))
(remove-if (lambda (x)
(or (atom x) (< (length x) 3)))
decls))))
(extentify
(xtent decls)
`(psetq
,@(mapcan (lambda (x)
(list (first x) (third x)))
(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)))))
......@@ -368,8 +387,8 @@ lambda-list::=
,@(when introduce-array-var?
(list (list arrvar array)))
(,idx 0 (1+ ,idx)))
((>= ,idx (getprop ,arrvar 'length))
,@(when result? (list result)))
((>= ,idx (getprop ,arrvar 'length))
,@(when result? (list result)))
(setq ,var (aref ,arrvar ,idx))
,@body)))
......@@ -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,18 +27,21 @@
(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))
(compile-expression val)))
(mapcan (lambda (x)
(let* ((in-case? t)
(exp (compile-statement x)))
(exp (compile-statement x)))
(if (and (listp exp) (eq 'ps-js:block (car exp)))
(cdr exp)
(list exp))))
body)))))
body)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; objects
......@@ -46,20 +49,22 @@
(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))
(reserved-symbol-p key))
((or (stringp key) (numberp key) (symbolp key))
key)
((and (consp key)
(eq 'quote (first key))
(symbolp (second key))
(null (third key)))
(symbol-to-js-string (second key)))
(t
(error
"Slot key ~s is not one of symbol, string or number."
key)))
(compile-expression val-expr)))))
(cons (extentify
(xtent key)
(cond ((and (symbolp key) (reserved-symbol-p key))
(reserved-symbol-p key))
((or (stringp key) (numberp key) (symbolp key))
key)
((and (consp key)
(eq 'quote (first key))
(symbolp (second key))
(null (third key)))
(symbol-to-js-string (second key)))
(t
(error
"Slot key ~s is not one of symbol, string or number."
key))))
(compile-expression val-expr)))))
(define-expression-operator %js-getprop (obj slot)
(let ((expanded-slot (ps-macroexpand 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.")
`(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))))))
(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))
,(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
(loop for (statement . remaining) on (cdr form) do
(ps-print statement) (psw #\;) (when remaining (psw #\Newline)))
(do-source-map (xtent form)
(loop for (statement . remaining) on (cdr form) do
(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))
(loop for (arg . remaining) on args do
(psw (symbol-to-js-string arg)) (when remaining (psw ", ")))
(psw ") ")
(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 " ")
(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
for decl = "var " then "" do
(psw decl (symbol-to-js-string var-name) " = ") (ps-print var-init)
(when remaining (psw ", ")))
(do-source-map (xtent vars)
(loop for (var . remaining) on vars
for decl = "var " then "" do
(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
(ps-print test) (when remaining (psw ", ")))
(do-source-map (xtent tests)
(loop for (test . remaining) on tests do
(ps-print test)
(when remaining (psw ", "))))
"; "
(loop for (step . remaining) on steps do
(ps-print step) (when remaining (psw ", ")))
(do-source-map (xtent steps)
(loop for (step . remaining) on steps do
(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
(newline-and-indent)
(if (eq val 'ps-js:default)
(progn (psw "default:")
(print-body statements))
(progn (psw "case ") (ps-print val) (psw #\:)
(print-body statements)))))
(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)))))))
(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
(psw " catch ("(symbol-to-js-string (first catch))") ")
(ps-print (second catch)))
(do-source-map (xtent catch)
(psw " catch ("(symbol-to-js-string (first 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*))))))
......@@ -97,9 +97,9 @@
(ps-js:> ps-js:<=)))))
(define-expression-operator not (x)
(let ((form (compile-expression x)))
(acond ((and (listp form) (eq (car form) 'ps-js:!)) ;; not not → identity
(acond ((and (listp form) (eq (car form) 'ps-js:!))
(second form))
((and (listp form) (cadr (assoc (car form) inverses))) ;; not equal → !=
((and (listp form) (cadr (assoc (car form) inverses)))
`(,it ,@(cdr form)))
(t `(ps-js:! ,form))))))
......@@ -122,11 +122,11 @@
(define-expression-operator progn (&rest body)
(if (cdr body)
`(ps-js:|,| ,@(compile-progn body))
(extentify (extent-union body) `(ps-js:|,| ,@(compile-progn body)))
(compile-expression (car body))))
(define-statement-operator progn (&rest body)
`(ps-js:block ,@(compile-progn body)))
(extentify (extent-union body) `(ps-js:block ,@(compile-progn body))))
(defun fill-mv-reg (values)
`(setf __PS_MV_REG (create :tag (@ arguments callee)
......@@ -146,13 +146,13 @@
`(ps-js:block
(ps-js:try
,body
:catch (,_ps_err
,(let ((suppress-values? nil))
(compile-statement
`(progn (cond
,@(mapcar #'make-catch-clause it)
(t (throw ,_ps_err)))))))
:finally nil))))
(,_ps_err
,(let ((suppress-values? nil))
(compile-statement
`(progn (cond
,@(mapcar #'make-catch-clause it)
(t (throw ,_ps_err)))))))
nil))))
body))
(define-statement-operator block (name &rest body)
......@@ -172,17 +172,20 @@
(defun return-exp (tag &optional (value nil value?))
(let (rest-values)
(when (and (consp value) (eq 'values (car value))) ; multiple value return?
(setf rest-values (cddr value) value (cadr value)))
(setf rest-values (cddr value) value (extentify (xtent value) (cadr value))))
(flet ((ret1only ()
(let ((ret `(ps-js:return
,@(when value?
(list (compile-expression value))))))
(let ((ret (extentify
(xtent value)
`(ps-js:return
,@(when value?
(list (compile-expression value)))))))
(if suppress-values?
`(ps-js:block (ps-js:= __PS_MV_REG {})
,ret)
ret)))
(fill-mv ()
(fill-mv-reg `(list ,@rest-values))))
(fill-mv-reg (extentify (extent-union rest-values)
`(list ,@rest-values)))))
(acond ((eql tag *current-block-tag*)
(compile-statement
(if value?
......@@ -241,73 +244,82 @@ invocations or not.")
(defun expressionize-result (tag form)
(ps-compile
(case (car form)
((continue break throw) ;; non-local exit
form)
;; implicit progn forms
((with label let flet labels macrolet symbol-macrolet block)
`(,(first form) ,(second form)
,@(butlast (cddr form))
(return-from ,tag ,(car (last (cddr form))))))
(progn
`(progn ,@(butlast (cdr form))
(return-from ,tag ,(car (last (cdr form))))))
(switch
`(switch
,(second form)
,@(loop for (cvalue . cbody) in (cddr form)
for remaining on (cddr form) collect
(aif (cond ((or (eq 'default cvalue) (not (cdr remaining)))
1)
((eq 'break (car (last cbody)))
2))
(let ((result-form (ps-macroexpand (car (last cbody it)))))
`(,cvalue
,@(butlast cbody it)
(return-from ,tag
,(if (eq result-form 'break) nil result-form))))
(cons cvalue cbody)))))
(try
`(try (return-from ,tag ,(second form))
,@(let ((catch (cdr (assoc :catch (cdr form))))
(finally (assoc :finally (cdr form))))
(list (when catch
`(:catch ,(car catch)
,@(butlast (cdr catch))
(return-from ,tag ,(car (last (cdr catch))))))
finally))))
(cond
`(cond
,@(loop for clause in (cdr form) collect
`(,@(butlast clause) (return-from ,tag ,(car (last clause)))))
,@(when in-case? `((t (return-from ,tag nil))))))
(if
(if (and (try-expressionizing-if? form)
(not (find 'values (flatten form)))
(let ((used-up-names *used-up-names*)
(*lambda-wrappable-statements* ()))
(handler-case (compile-expression form)
(compile-expression-error ()
(setf *used-up-names* used-up-names)
nil))))
(return-from expressionize-result (return-exp tag form))
`(if ,(second form)
(return-from ,tag ,(third form))
,@(when (or in-case? (fourth form))
`((return-from ,tag ,(fourth form)))))))
(return-from ;; this will go away someday
(unless tag
(warn 'simple-style-warning
:format-control "Trying to RETURN a RETURN without a block tag specified. Perhaps you're still returning values from functions by hand?
Parenscript now implements implicit return, update your code! Things like (lambda () (return x)) are not valid Common Lisp and may not be supported in future versions of Parenscript."))
(extentify
(xtent form)
(case (car form)
((continue break throw) ;; non-local exit
form)
(otherwise
(return-from expressionize-result
(cond ((not (gethash (car form) *special-statement-operators*))
(return-exp tag form))
(in-case?
`(ps-js:block ,(compile-statement form) ,(return-exp tag)))
(t (compile-statement form))))))))
;; implicit progn forms
((with label let flet labels macrolet symbol-macrolet block)
`(,(first form) ,(second form)
,@(butlast (cddr form))
,(make-return-from tag (car (last (cddr form))))))
(progn
`(progn ,@(butlast (cdr form))
,(make-return-from tag (car (last (cdr form))))))
(switch
`(switch
,(second form)
,@(loop for clause in (cddr form)
for remaining on (cddr form) collect
(destructuring-bind (cvalue . cbody) clause
(extentify
(xtent clause)
(aif (cond ((or (eq 'default cvalue) (not (cdr remaining)))
1)
((eq 'break (car (last cbody)))
2))
(let ((result-form (ps-macroexpand (car (last cbody it)))))
`(,cvalue
,@(butlast cbody it)
(return-from ,tag
,(if (eq result-form 'break) nil result-form))))
(cons cvalue cbody)))))))
(try
(let* ((tagged-catch (assoc :catch (cdr form)))
(catch (cdr tagged-catch))
(finally-clause (assoc :finally (cdr form))))
`(try ,(make-return-from tag (second form))
,(when catch
(extentify
(xtent tagged-catch)
`(:catch ,(car catch)
,@(butlast (cdr catch))
,(make-return-from tag (car (last (cdr catch)))))))
,finally-clause)))
(cond
`(cond
,@(loop for clause in (cdr form)
for ret = (make-return-from tag (car (last clause)))
collect `(,@(butlast clause) ,ret))
,@(when in-case? `((t (return-from ,tag nil))))))
(if
(if (and (try-expressionizing-if? form)
(not (find 'values (flatten form)))
(let ((used-up-names *used-up-names*)
(*lambda-wrappable-statements* ()))
(handler-case (compile-expression form)
(compile-expression-error ()
(setf *used-up-names* used-up-names)
nil))))
(return-from expressionize-result (return-exp tag form))
`(if ,(second form)
(return-from ,tag ,(third form))
,@(when (or in-case? (fourth form))
`((return-from ,tag ,(fourth form)))))))
(return-from ;; this will go away someday
(unless tag
(warn 'simple-style-warning
:format-control "Trying to RETURN a RETURN without a block tag specified. Perhaps you're still returning values from functions by hand?
Parenscript now implements implicit return, update your code! Things like (lambda () (return x)) are not valid Common Lisp and may not be supported in future versions of Parenscript."))
form)
(otherwise
(return-from expressionize-result
(cond ((not (gethash (car form) *special-statement-operators*))
(return-exp tag form))
(in-case?
`(ps-js:block ,(compile-statement form) ,(return-exp tag)))
(t (compile-statement form)))))))))
(define-statement-operator return-from (tag &optional result)
(if tag
......@@ -315,7 +327,8 @@ Parenscript now implements implicit return, update your code! Things like (lambd
(if (or (atom form) (eq 'values (car form)))
(return-exp tag form)
(expressionize-result tag form)))
(ps-compile `(return-from nilBlock ,result))))
(ps-compile (extentify (xtent result)
`(return-from nilBlock ,result)))))
(define-expression-operator values (&optional main &rest additional)
(when main
......@@ -345,19 +358,19 @@ Parenscript now implements implicit return, update your code! Things like (lambd
(when clauses
(destructuring-bind (test &rest body) (car clauses)
(if (eq t test)
`(progn ,@body)
(make-progn body)
`(if ,test
(progn ,@body)
,(make-progn body)
(cond ,@(cdr clauses))))))))
(define-statement-operator cond (&rest clauses)
`(ps-js:if ,(compile-expression (caar clauses))
,(compile-statement `(progn ,@(cdar clauses)))
,(compile-statement (make-progn (cdar clauses)))
,@(loop for (test . body) in (cdr clauses) appending
(if (eq t test)
`(:else ,(compile-statement `(progn ,@body)))
`(:else ,(compile-statement (make-progn body)))
`(:else-if ,(compile-expression test)
,(compile-statement `(progn ,@body)))))))
,(compile-statement (make-progn body)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; macros
......@@ -384,7 +397,7 @@ Parenscript now implements implicit return, update your code! Things like (lambd
(setf (gethash name local-macro-dict) (lambda (x) (declare (ignore x)) expansion))
(push name local-var-bindings)))
(let ((*enclosing-lexicals* (append local-var-bindings *enclosing-lexicals*)))
(ps-compile `(progn ,@body))))))
(ps-compile (make-progn body))))))
(define-expression-operator defmacro (name args &body body)
(eval `(defpsmacro ,name ,args ,@body))
......@@ -412,17 +425,21 @@ Parenscript now implements implicit return, update your code! Things like (lambd
ps-js:/ ps-js:/=)
op))
(define-expression-operator ps-assign (lhs rhs)
(define-expression-operator ps-assign (lhs rhs &optional xt)
(let ((rhs (ps-macroexpand rhs)))
(if (and (listp rhs) (eq (car rhs) 'progn))
(ps-compile `(progn ,@(butlast (cdr rhs))
(ps-assign ,lhs ,(car (last (cdr rhs))))))
(if (and (listp rhs) (eq (car rhs) 'progn) (cddr rhs))
;; (setf x (progn y z)) → (progn y (setf x z))
;; If a text-extent for the root SETF was passed in,
;; propagate it to the assignment
(let ((pushed-down (extentify xt `(ps-assign ,lhs ,(car (last (cdr rhs))) ,xt))))
(ps-compile `(progn ,@(butlast (cdr rhs)) ,pushed-down)))
(let ((lhs (compile-expression lhs))
(rhs (compile-expression rhs)))
(aif (and (listp rhs)
(= 3 (length rhs))
(equal lhs (second rhs))
(assignment-op (first rhs)))
;; replace x = x + 1 with x += 1, etc.
(list it lhs (if (fourth rhs)
(cons (first rhs) (cddr rhs))
(third rhs)))
......@@ -462,8 +479,8 @@ Parenscript now implements implicit return, update your code! Things like (lambd
(ps-gensym (symbol-name x))))
(defun with-lambda-scope (body)
(prog1 `((lambda () ,body))
(setf *vars-needing-to-be-declared* ())))
(prog1 `((lambda () ,body))
(setf *vars-needing-to-be-declared* ())))
(define-expression-operator let (bindings &body body)
(with-declaration-effects (body body)
......@@ -473,9 +490,11 @@ Parenscript now implements implicit return, update your code! Things like (lambd
(let* ((new-lexicals ())
(normalized-bindings
(mapcar (lambda (x)
(if (symbolp x)
(list x nil)
(list (car x) (ps-macroexpand (cadr x)))))
(extentify
(xtent x)
(if (symbolp x)
(list x nil)
(list (car x) (ps-macroexpand (cadr x))))))
bindings))
(symbols-in-bindings
(mapcan (lambda (x) (flatten (cadr x)))
......@@ -483,20 +502,24 @@ Parenscript now implements implicit return, update your code! Things like (lambd
(lexical-bindings
(loop for x in normalized-bindings
unless (special-variable? (car x)) collect
(cons (aif (maybe-rename-lexical-var (car x)
symbols-in-bindings)
it
(progn
(push (car x) new-lexicals)
(when (boundp '*used-up-names*)
(push (car x) *used-up-names*))
nil))
x)))
(extentify
(xtent x)
(cons (aif (maybe-rename-lexical-var (car x)
symbols-in-bindings)
it
(progn
(push (car x) new-lexicals)
(when (boundp '*used-up-names*)
(push (car x) *used-up-names*))
nil))
x))))
(dynamic-bindings
(loop for x in normalized-bindings
when (special-variable? (car x)) collect
(cons (ps-gensym (format nil "~A_~A" (car x) 'tmp-stack))
x)))
(extentify
(xtent x)
(cons (ps-gensym (format nil "~A_~A" (car x) 'tmp-stack))
x))))
(renamed-body
`(symbol-macrolet ,(loop for x in lexical-bindings
when (rename x) collect
......@@ -510,21 +533,26 @@ Parenscript now implements implicit return, update your code! Things like (lambd
(let-body
`(progn
,@(mapcar (lambda (x)
`(var ,(or (rename x) (var x)) ,(val x)))
(extentify (xtent x) `(var ,(or (rename x) (var x)) ,(val x))))
lexical-bindings)
,(if dynamic-bindings
`(progn
,@(mapcar (lambda (x) `(var ,(rename x)))
,@(mapcar (lambda (x)
(extentify (xtent x) `(var ,(rename x))))
dynamic-bindings)
(try
(progn
(setf ,@(loop for x in dynamic-bindings append
`(,(rename x) ,(var x)
,@(loop for x in dynamic-bindings collect
(extentify
(xtent x)
`(setf ,(rename x) ,(var x)
,(var x) ,(val x))))
,renamed-body)
(:finally
(setf ,@(mapcan (lambda (x) `(,(var x) ,(rename x)))
dynamic-bindings)))))
,@(loop :for x :in dynamic-bindings collect
(extentify
(xtent x)
`(setf ,(var x) ,(rename x)))))))
renamed-body))))
(ps-compile (cond ((or in-function-scope?
(null bindings))
......@@ -534,8 +562,8 @@ Parenscript now implements implicit return, update your code! Things like (lambd
(member x '(defun% defvar)))
(flatten
(loop for x in body collecting
(or (ignore-errors (ps-macroexpand x))
x))))
(or (ignore-errors (ps-macroexpand x))
x))))
let-body)
(t
(with-lambda-scope let-body))))))))
......@@ -544,10 +572,14 @@ Parenscript now implements implicit return, update your code! Things like (lambd
;;; iteration
(defun make-for-vars/inits (init-forms)
(mapcar (lambda (x)
(cons (ps-macroexpand (if (atom x) x (first x)))
(compile-expression (if (atom x) nil (second x)))))
init-forms))
(extentify
(xtent init-forms)
(mapcar (lambda (x)
(extentify
(xtent x)
(cons (ps-macroexpand (if (atom x) x (first x)))
(compile-expression (if (atom x) nil (second x))))))
init-forms)))
(defun compile-loop-body (loop-vars body)
(let* ((in-loop-scope? t)
......@@ -574,7 +606,9 @@ Parenscript now implements implicit return, update your code! Things like (lambd
;;; evaluation
(define-expression-operator quote (x)
(flet ((quote% (expr) (when expr `',expr)))
(flet ((quote% (expr)
(when expr
(extentify (xtent expr) `',expr))))
(compile-expression
(typecase x
(cons `(array ,@(mapcar #'quote% x)))
......@@ -592,7 +626,7 @@ and :execute. The code in BODY is assumed to be Common Lisp code
in :compile-toplevel and :load-toplevel sitations, and Parenscript
code in :execute."
(when (and (member :compile-toplevel situation-list)
(member *compilation-level* '(:toplevel :inside-toplevel-form)))
(member *compilation-level* '(:toplevel :inside-toplevel-form)))
(eval `(progn ,@body)))
(if (member :execute situation-list)
(ps-compile `(progn ,@body))
......
......@@ -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;")
......
;; Copying and distribution of this file, with or without
;; modification, are permitted in any medium without royalty. This
;; file is offered as-is, without any warranty.
(in-package #:ps-test)
(named-readtables:in-readtable :parenscript)
(in-suite sourcemap-tests)
(test-source-maps srcmap-function-call
("(foo)" "foo()"))
(test-source-maps srcmap-nested-funcall
("(foo (bar))" "foo(bar())")
("(bar)" "bar()"))
(test-source-maps srcmap-funcall-with-literal-args
("(foo 1 \"abc\")" "foo(1, 'abc')"))
(test-source-maps srcmap-explicit-funcall
("(funcall foo 1 (bar))" "foo(1, bar())")
("(bar)" "bar()"))
(test-source-maps srcmap-this-apply
("(apply (foo) (bar) (baz))" "foo().apply(this, [bar()].concat(baz()))")
("(foo)" "foo()")
("(bar)" "bar()")
("(baz)" "baz()"))
(test-source-maps srcmap-object-apply
("(apply (@ obj foo) (bar))" "obj.foo.apply(obj, bar())")
("(@ obj foo)" "obj.foo")
("(bar)" "bar()"))
(test-source-maps srcmap-chain-apply
("(apply (getprop (make-an-object) foo 'bar) (baz))"
"(function () {
var _js1 = makeAnObject()[foo];
var _js2 = _js1.bar;
return _js2.apply(_js1, baz());
})()")
("(make-an-object)" "makeAnObject()")
;("'bar" "bar")
("(baz)" "baz()"))
(test-source-maps srcmap-simple-defun
("(defun foo (x y))"
"function foo(x, y) {
return null;
}")
("(x y)" "(x, y)"))
(test-source-maps srcmap-simple-defun-return
("(defun foo () (bar))"
"function foo() {
return bar();
}")
("(bar)" "return bar()")
("(bar)" "bar()"))
(test-source-maps srcmap-defun-statement-then-return
("(defun foo () (bar) (baz))"
"function foo() {
bar();
return baz();
}")
("(bar)" "bar()")
("(baz)" "return baz()")
("(baz)" "baz()"))
(test-source-maps srcmap-top-level-lambda
("(lambda () (foo))"
"(function () {
return foo();
})")
("(foo)" "return foo()")
("(foo)" "foo()"))
(test-source-maps srcmap-lambda-in-defun
("(defun foo () (lambda (x) (bar x)))"
"function foo() {
return function (x) {
return bar(x);
};
}")
("(lambda (x) (bar x))"
"return function (x) {
return bar(x);
}")
("(lambda (x) (bar x))"
"function (x) {
return bar(x);
}")
("(x)" "(x)")
("(bar x)" "return bar(x)")
("(bar x)" "bar(x)"))
(test-source-maps srcmap-simple-if-statement
("(if a b c)"
"if (a) {
b;
} else {
c;
}"))
(test-source-maps srcmap-simple-if-expression
("(defun foo (a b c) (if a b c))"
"function foo(a, b, c) {
return a ? b : c;
}")
("(a b c)" "(a, b, c)")
("(if a b c)" "return a ? b : c")
("(if a b c)" "a ? b : c"))
(test-source-maps srcmap-simplest-cond-statement
("(cond (t (foo)))"
"if (true) {
foo();
}")
("(foo)" "{
foo();
}")
("(foo)" "foo()"))
(test-source-maps srcmap-multi-cond-statement
("(cond ((foo) (bar)) ((baz) (bing)) (t (biff)))"
"if (foo()) {
bar();
} else if (baz()) {
bing();
} else {
biff();
}")
("(foo)" "foo()")
("(bar)" "{
bar();
}")
("(bar)" "bar()")
("(baz)" "baz()")
("(bing)" "{
bing();
}")
("(bing)" "bing()")
("(biff)" "{
biff();
}")
("(biff)" "biff()"))
(test-source-maps srcmap-return-cond
("(defun foo () (cond (a (bar)) (t (baz))))"
"function foo() {
if (a) {
return bar();
} else {
return baz();
};
}")
("(cond (a (bar)) (t (baz)))"
"if (a) {
return bar();
} else {
return baz();
}")
("(bar)"
"{
return bar();
}")
("(bar)" "return bar()")
("(bar)" "bar()")
("(baz)"
"{
return baz();
}")
("(baz)" "return baz()")
("(baz)" "baz()"))
(test-source-maps srcmap-cond-expression
("(defun foo () (bar (cond (a (baz)) (t (bing)))))"
"function foo() {
return bar(a ? baz() : bing());
}")
("(bar (cond (a (baz)) (t (bing))))" "return bar(a ? baz() : bing())")
("(bar (cond (a (baz)) (t (bing))))" "bar(a ? baz() : bing())")
("(cond (a (baz)) (t (bing)))" "a ? baz() : bing()")
("(baz)" "baz()")
("(bing)" "bing()"))
(test-source-maps srcmap-switch
("(switch (foo) (1) (2 (bar) (baz) break) (default (bing)))"
"switch (foo()) {
case 1:
case 2:
bar();
baz();
break;
default:
bing();
}")
("(foo)" "foo()")
("(1)" "case 1:")
("(2 (bar) (baz) break)"
"case 2:
bar();
baz();
break;")
("(bar)" "bar()")
("(baz)" "baz()")
("(default (bing))"
"default:
bing();")
("(bing)" "bing()"))
(test-source-maps srcmap-case-statement
("(case (foo) ((1 2) (bar) (baz)) (t (bing)))"
"switch (foo()) {
case 1:
case 2:
bar();
baz();
break;
default:
bing();
}")
("(foo)" "foo()")
("((1 2) (bar) (baz))"
"case 2:
bar();
baz();
break;")
("(bar)" "bar()")
("(baz)" "baz()")
("(t (bing))"
"default:
bing();")
("(bing)" "bing()"))
(test-source-maps srcmap-return-case
("(defun foo (x) (case x ((1 \"one\") (bar)) (2) (t (baz))))"
"function foo(x) {
switch (x) {
case 1:
case 'one':
return bar();
case 2:
return null;