Commit 2f753d75 authored by hayeah via gmail com's avatar hayeah via gmail com

Hopefully fixed all the bugs I introduced into lispscript

darcs-hash:5c70a7ba1c92b28a5e216113cb19804596113a58
parent 3541e6ac
......@@ -357,7 +357,7 @@ statements such as blocks to *not* emit a semicolon."
(out "[" (expression slot) "]"))))
(define-javascript-special-operator ref :expression (processor expr &rest slots)
"Actually, according to JS document, foo['bar'] should always be written as foo.bar"
;;Actually, according to JS document, foo['bar'] should always be written as foo.bar
(expression expr)
(loop for slot in slots do
(out "[" (expression slot) "]")))
......@@ -425,21 +425,11 @@ statements such as blocks to *not* emit a semicolon."
"var " (name variable)
(when value (out " = " (expression value))) ";")
;; If
;; If
(define-javascript-special-operator %if :statement (processor condition then &optional else)
"if (" (expression condition) ") " (statement then)
(when else (out " else " (statement else))))
;; The common lisp 'if' defined in lispscript clobber the original if. So define cl if as a special operator in js.
;; (define-javascript-special-operator if :expression (processor condition then &optional else)
;; (out "(function () { " :newline :indent
;; "if (" (expression condition) ") " (statement then)
;; (when else (out " else " (statement else)))
;; :newline :unindent
;; "})()"))
;; Do-While
(define-javascript-special-operator %do-while :statement (processor body condition)
"do " (statement body) " while (" (expression condition) ");")
......
......@@ -42,10 +42,11 @@
(eql (com.gigamonkeys.foo.javascript::statement-or-expression env) :expression)))
(defun find-open-block (name env &key (expected t))
(let ((cons (assoc `(open-block ,name) env :test #'equal)))
(cond
((and expected (not cons))
(error "No open block named ~a in environment ~s" name env))
(progn (print (list name env)) (error "No open block named ~a in environment ~s" name env)))
#+(or)((and (not expected) cons)
(error "Already an open block named ~a in environment ~s" name env))
(t cons))))
......@@ -144,8 +145,7 @@ Widget.prototype.aClosure = function () {
(define-javascript-macro block (name &body body &environment env)
(let ((e (javascript-gensym))
(return-var (block-name name)))
(if (not (returned-p return-var body env))
;; something to do with returning from nested block. Dunno how exactly it works.
(if (not (returned-p return-var body env))
`(progn ,@body)
`(augment-environment
(((open-block ,return-var) . nil))
......@@ -154,7 +154,7 @@ Widget.prototype.aClosure = function () {
(try (%return (progn ,@body))
(catch ,e
(%if (eq ,e ,return-var)
(return (,return-var value))
(%return (,return-var value))
(throw ,e)))))
(object value undefined))
`((function (,return-var)
......@@ -170,6 +170,7 @@ Widget.prototype.aClosure = function () {
(intern (format nil "block$~a" symbol) :keyword))
(defun returned-p (block-name body env)
;; Is this generating all the subforms of a block just to find out if a throw is called to exit from it??
(loop with new-env = (add-open-block block-name env)
for form in body
do (process *lispscript* nil form new-env)
......@@ -178,8 +179,7 @@ Widget.prototype.aClosure = function () {
(define-javascript-macro return-from (name value &environment env)
(mark-block-return (block-name name) env)
(if (needs-value env)
;; doesn't look like it's ever getting in here.
(if (needs-value env)
`(progn
(set (,(block-name name) value) ,value)
((function () (throw ,(block-name name)))))
......@@ -187,7 +187,7 @@ Widget.prototype.aClosure = function () {
(set (,(block-name name) value) ,value)
(throw ,(block-name name)))))
;; Clobbers return special op
(define-javascript-macro return (value)
`(return-from nil ,value))
......@@ -209,8 +209,8 @@ Widget.prototype.aClosure = function () {
(define-javascript-macro if (test then &optional else &environment env)
(if (needs-value env)
`(scope () (%if ,test (%block (%return ,then)) (%block (%return ,(%if else else 'undefined)))))
`(%if ,test (%block ,then) ,@(%if else `((%block ,else))))))
`(scope () (%if ,test (%block (%return ,then)) (%block (%return ,(if else else 'undefined)))))
`(%if ,test (%block ,then) ,@(if else `((%block ,else))))))
(define-javascript-macro cond (&body clauses)
(destructuring-bind ((test &body body) &rest clauses) clauses
......@@ -300,7 +300,7 @@ Widget.prototype.aClosure = function () {
(define-javascript-macro new (type &rest args)
`(NEW ,type ,@args))
`(new ,type ,@args))
(define-javascript-macro ignore-errors (&body body &environment env)
(let ((e (javascript-gensym)))
......@@ -362,29 +362,34 @@ Widget.prototype.aClosure = function () {
(define-javascript-macro xml (body)
(multiple-value-bind (tag attributes body) (com.gigamonkeys.foo.html::parse-cons-form body)
`(let* ((document (.createDocument (@ document implementation) "" ,(string-upcase tag) null)))
`(let* ((document (document implementation createDocument ~
"" ,(string-upcase tag) null)))
,@(loop for (name value) on attributes by #'cddr
collect `(.setAttribute (@ document document-element) ,(string-upcase name) ,(attribute-value value)))
collect `(document document-element setAttribute ~
,(string-upcase name) ,(attribute-value value)))
,@(loop for thing in body collect
`(.appendChild (@ document document-element) (xml-element (document) ,thing)))
`(document document-element appendChild ~
(xml-element (document) ,thing)))
document)))
(define-javascript-macro xml-element ((document) body)
(etypecase body
(string `(.create-text-node ,document ,body))
(number `(.create-text-node document (+ "" ,body)))
(string `(,document create-text-node ~ ,body))
(number `(document create-text-node ~ (+ "" ,body)))
(symbol `(if (string= (typeof ,body) "string")
(.create-text-node document ,body)
(document create-text-node ~ ,body)
,body))
(cons
(cond
((sexp-form-p com.gigamonkeys.foo.html::*html* body)
(multiple-value-bind (tag attributes body) (com.gigamonkeys.foo.html::parse-cons-form body)
`(let* ((element (.create-element ,document ,(string-upcase tag))))
`(let* ((element (,document create-element ~ ,(string-upcase tag))))
,@(loop for (name value) on attributes by #'cddr
collect `(.setAttribute element ,(string-upcase name) ,(attribute-value value)))
collect `(element setAttribute ~ ,(string-upcase name) ,(attribute-value value)))
,@(loop for thing in body collect
`(.appendChild element (xml-element (,document) ,thing)))
`(element appendChild ~ (xml-element (,document) ,thing)))
element)))
(t body)))))
......@@ -395,20 +400,20 @@ Widget.prototype.aClosure = function () {
(number (princ-to-string thing))
(symbol thing))))
(etypecase body
(string `(.create-text-node document ,body))
(number `(.create-text-node document (+ "" ,body)))
(string `(document create-text-node ~ ,body))
(number `(document create-text-node ~ (+ "" ,body)))
(symbol `(if (string= (typeof ,body) "string")
(.create-text-node document ,body)
(document create-text-node ~ ,body)
,body))
(cons
(cond
((sexp-form-p com.gigamonkeys.foo.html::*html* body)
(multiple-value-bind (tag attributes body) (com.gigamonkeys.foo.html::parse-cons-form body)
`(let* ((element (.create-element document ,(string-upcase tag))))
`(let* ((element (document create-element ~ ,(string-upcase tag))))
,@(loop for (name value) on attributes by #'cddr
collect `(.set-attribute element ,(string-upcase name) ,(attribute-value value)))
collect `(element set-attribute ~ ,(string-upcase name) ,(attribute-value value)))
,@(loop for thing in body collect
`(.append-child element (html ,thing)))
`(element append-child ~ (html ,thing)))
element)))
(t body))))))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment