(in-package :parenscript)
-;;;; The mechanisms for parsing Parenscript.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *toplevel-special-forms* (make-hash-table :test #'equal)
"A hash-table containing functions that implement Parenscript special forms,
"Returns the special form function corresponding to the given name."
(gethash (lisp-symbol-to-ps-identifier name :special-form) *toplevel-special-forms*))
+(defvar *enclosing-lexical-block-declarations* ()
+ "This special variable is expected to be bound to a fresh list by
+special forms that introduce a new JavaScript lexical block (currently
+function definitions and lambdas). Enclosed special forms are expected
+to push variable declarations onto the list when the variables
+declaration cannot be made by the enclosed form (for example, a
+(x,y,z) expression progn). It is then the responsibility of the
+enclosing special form to introduce the variable bindings in its
+lexical block.")
+
;;; ParenScript form predicates
(defun ps-special-form-p (form)
(and (consp form)
:symbol."))
(defmethod compile-parenscript-form :around (form &key expecting)
+ (assert (if expecting (member expecting '(:expression :statement :symbol)) t))
(if (eql expecting :symbol)
(compile-to-symbol form)
(multiple-value-bind (expanded-form expanded-p)
(define-ps-special-form ~ (expecting x)
(declare (ignore expecting))
- (list 'unary-operator "~" (compile-parenscript-form x :expecting :expressin) :prefix t))
+ (list 'unary-operator "~" (compile-parenscript-form x :expecting :expression) :prefix t))
(defun flatten-blocks (body)
(when body
(if (and (eql expecting :expression) (= 1 (length body)))
(compile-parenscript-form (car body) :expecting :expression)
(list 'js-block
- (if (eql expecting :statement) t nil)
+ expecting
(let* ((block (mapcar (lambda (form)
- (compile-parenscript-form form :expecting :statement))
+ (compile-parenscript-form form :expecting expecting))
body))
(clean-block (remove nil block))
(flat-block (flatten-blocks clean-block))
reachable-block))))
;;; function definition
+(defun compile-function-definition (args body)
+ (list (mapcar (lambda (arg) (compile-parenscript-form arg :expecting :symbol)) args)
+ (let ((*enclosing-lexical-block-declarations* ()))
+ ;; the first compilation will produce a list of variables we need to declare in the function body
+ (compile-parenscript-form `(progn ,@body) :expecting :statement)
+ ;; now declare and compile
+ (compile-parenscript-form `(progn ,@(loop for var in *enclosing-lexical-block-declarations* collect `(defvar ,var))
+ ,@body) :expecting :statement))))
+
(define-ps-special-form %js-lambda (expecting args &rest body)
(declare (ignore expecting))
- (list 'js-lambda (mapcar (lambda (arg)
- (compile-parenscript-form arg :expecting :symbol))
- args)
- (compile-parenscript-form `(progn ,@body))))
+ (cons 'js-lambda (compile-function-definition args body)))
(define-ps-special-form %js-defun (expecting name args &rest body)
(declare (ignore expecting))
- (list 'js-defun name
- (mapcar (lambda (val) (compile-parenscript-form val :expecting :symbol)) args)
- (compile-parenscript-form `(progn ,@body))))
+ (append (list 'js-defun name) (compile-function-definition args body)))
;;; object creation
(define-ps-special-form create (expecting &rest args)
(destructuring-bind (test &rest body)
clause
(list (compile-parenscript-form test :expecting :expression)
- (compile-parenscript-form `(progn ,@body)))))
+ (compile-parenscript-form `(progn ,@body) :expecting :statement))))
clauses)))
(:expression (make-cond-clauses-into-nested-ifs clauses))))
(let ((clauses (mapcar (lambda (clause)
(let ((val (car clause))
(body (cdr clause)))
- (list (if (eql val 'default)
+ (cons (if (eql val 'default)
'default
(compile-parenscript-form val :expecting :expression))
- (compile-parenscript-form `(progn ,@body)))))
+ (mapcar (lambda (statement) (compile-parenscript-form statement :expecting :statement))
+ body))))
clauses))
(expr (compile-parenscript-form test-expr :expecting :expression)))
(list 'js-switch expr clauses)))
(defprinter js-method-call (method object args)
;; TODO: this may not be the best way to add ()'s around lambdas
;; probably there is or should be a more general solution working
- ;; in other situations involving lambda's
+ ;; in other situations involving lambdas
(if (or (numberp object) (and (consp object) (member (car object) '(js-lambda js-object operator js-expression-if))))
(parenthesize-print object)
(ps-print object))
(psw (js-translate-symbol method))
(psw #\() (print-comma-delimited-list args) (psw #\)))
-(defprinter js-block (statement-p statements)
- (if statement-p
- (progn (psw #\{)
- (incf *indent-level*)
- (dolist (statement statements)
- (newline-and-indent) (ps-print statement) (psw #\;))
- (decf *indent-level*)
- (newline-and-indent)
- (psw #\}))
- (progn (psw #\()
- (loop for (statement . remaining) on statements do
- (ps-print statement) (when remaining (psw ", ")))
- (psw #\)))))
+(defprinter js-block (block-type statements)
+ (case block-type
+ (:statement
+ (psw #\{)
+ (incf *indent-level*)
+ (dolist (statement statements)
+ (newline-and-indent) (ps-print statement) (psw #\;))
+ (decf *indent-level*)
+ (newline-and-indent)
+ (psw #\}))
+ (:expression
+ (psw #\()
+ (loop for (statement . remaining) on statements do
+ (ps-print statement) (when remaining (psw ", ")))
+ (psw #\)))))
(defprinter js-lambda (args body)
(print-fun-def nil args body))
(psw #\;)))
(decf *indent-level*)))
(psw "switch (") (ps-print test) (psw ") {")
- (loop for (val body-block) in clauses
- for body-statements = (third body-block)
+ (loop for (val . statements) in clauses
do (progn (newline-and-indent)
(if (eql val 'default)
(progn (psw "default: ")
- (print-body-statements body-statements))
+ (print-body-statements statements))
(progn (psw "case ")
(ps-print val)
(psw #\:)
- (print-body-statements body-statements)))))
+ (print-body-statements statements)))))
+ (newline-and-indent)
(psw #\})))
(defprinter js-try (body-block &key catch finally)
clauses))))
(define-ps-special-form let (expecting bindings &rest body)
- (declare (ignore expecting))
- (let ((defvars (mapcar (lambda (binding) (if (atom binding)
- `(defvar ,binding)
- `(defvar ,@binding)))
- bindings)))
- (compile-parenscript-form `(progn ,@defvars ,@body))))
+ (ecase expecting
+ (:statement
+ (let ((defvars (mapcar (lambda (binding) (if (atom binding)
+ `(defvar ,binding)
+ `(defvar ,@binding)))
+ bindings)))
+ (compile-parenscript-form `(progn ,@defvars ,@body) :expecting :statement)))
+ (:expression
+ (let ((declared-variables (mapcar (lambda (binding) (if (atom binding) binding (car binding))) bindings))
+ (variable-assignments (loop for b in bindings when (listp b) collect (cons 'setf b))))
+ (setf *enclosing-lexical-block-declarations* (append declared-variables *enclosing-lexical-block-declarations*))
+ (compile-parenscript-form `(progn ,@variable-assignments ,@body) :expecting :expression)))))
;;; iteration
(defpsmacro dotimes (iter &rest body)
[&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
[&aux {var | (var [init-form])}*])"
(if (symbolp name)
- `(defun-normal ,name ,lambda-list ,@body)
+ `(defun-function ,name ,lambda-list ,@body)
(progn (assert (and (= (length name) 2) (eql 'setf (car name))) ()
"(defun ~s ~s ...) needs to have a symbol or (setf symbol) for a name." name lambda-list)
`(defun-setf ,name ,lambda-list ,@body))))
-(defpsmacro defun-normal (name lambda-list &body body)
+(defpsmacro defun-function (name lambda-list &body body)
(multiple-value-bind (effective-args effective-body)
(parse-extended-function lambda-list body name)
`(%js-defun ,name ,effective-args
(progn (define-symbol-macro tst-sym-macro 2)
tst-sym-macro)
"2;")
+
+(test-ps-js expression-progn
+ (defun f () (return (progn (foo) (if x 1 2))))
+ "function f() {
+ return (foo(), x ? 1 : 2);
+}")
+
+(test-ps-js let-decl-in-expression
+ (defun f (x) (return (if x 1 (let ((foo x)) foo))))
+ "function f(x) {
+ var foo;
+ return x ? 1 : (foo = x, foo);
+}")
HCoop / clinton / parenscript.git / commitdiff