+
+(defvar *block-counter* 0)
+
+(define-compilation block (name &rest body)
+ (let ((tr (integer-to-string (incf *block-counter*))))
+ (let ((b (make-binding name 'block tr t)))
+ (concat "(function(){" *newline*
+ (indent "try {" *newline*
+ (indent "return " (ls-compile `(progn ,@body)
+ (extend-lexenv b env 'block))) ";" *newline*
+ "}" *newline*
+ "catch (cf){" *newline*
+ " if (cf.type == 'block' && cf.id == " tr ")" *newline*
+ " return cf.value;" *newline*
+ " else" *newline*
+ " throw cf;" *newline*
+ "}" *newline*)
+ "})()"))))
+
+(define-compilation return-from (name &optional value)
+ (let ((b (lookup-in-lexenv name env 'block)))
+ (if b
+ (concat "(function(){ throw ({"
+ "type: 'block', "
+ "id: " (binding-translation b) ", "
+ "value: " (ls-compile value env) ", "
+ "message: 'Return from unknown block " (symbol-name name) ".'"
+ "})})()")
+ (error (concat "Unknown block `" (symbol-name name) "'.")))))
+