Commit 3541e6ac authored by hayeah via gmail com's avatar hayeah via gmail com

Half solved the case clobbering problem between javascript.lisp and lispscript.lisp

darcs-hash:4f386eaec0aa82f40c73ca78d83c8d689df2888d
parent 738d9a34
......@@ -139,21 +139,17 @@ Return: ((<js-form>*) (~ <js-form>*) (@ <js-form>*)) "
;; (use-package :wisp.util)
(defmacro process-js (js-form)
`(process *javascript* (get-pretty-printer) ,js-form (top-level-environment *javascript*)))
;; (process-js '(foo bar BazBaf ~ ab cd @ la boo))
;; (process-js 'foo)
`(process *javascript* (get-pretty-printer) ,js-form (top-level-environment *javascript*)))
(defmethod process-sexp ((language javascript) processor form environment)
;; TODO get rid of redundant function
;; ;; (process-js '((function () 3) ~)) for example
;; ;; This is actually kinda hairy. Doesn't apply in most cases anyway.
;; ;; ;; possibly make function a special form s.t. ~ is not required?
(if (consp form)
;; Need to deal with anonymous function call using process-function-call
(destructuring-bind (objects args arefs) (parse-js-form form)
(destructuring-bind (objects args arefs) (parse-js-form form)
(unless objects (error "illegal javascript form ~S. No object path." form))
(process-object-path language processor environment objects)
(when args (process-method-call language processor environment (cdr args)))
......@@ -361,6 +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"
(expression expr)
(loop for slot in slots do
(out "[" (expression slot) "]")))
......@@ -397,23 +394,24 @@ statements such as blocks to *not* emit a semicolon."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Statements -- special operators that produce statements
(define-javascript-special-operator progn :expression (processor &rest body)
;;;; what with progn and prog?????
(define-javascript-special-operator %progn :expression (processor &rest body)
"("
(loop for (e . rest) on body do (out (expression e)) (when rest (out ", ")))
")")
(define-javascript-special-operator prog :statement (processor &rest body)
(define-javascript-special-operator %prog :statement (processor &rest body)
(loop for s in body do (out (statement s) :freshline)))
;; Block -- we handle this a bit specially to avoid creating redundant
;; blocks in the generated code. In the case where a block contains
;; only another block (or a macro that expands into a block) we strip
;; the inner block.
(define-javascript-special-operator block :statement (processor &rest body &environment env)
(define-javascript-special-operator %block :statement (processor &rest body &environment env)
(when (and body (not (cdr body)))
(loop while (macro-form-p *javascript* (car body)) do
(setf (car body) (expand-macro-form *javascript* (car body) env)))
(loop while (and body (not (cdr body)) (consp (car body)) (eql (caar body) 'block)) do
(loop while (and body (not (cdr body)) (consp (car body)) (eql (caar body) '%block)) do
(setf body (rest (car body)))))
(out
"{" :newline :indent
......@@ -428,16 +426,26 @@ statements such as blocks to *not* emit a semicolon."
(when value (out " = " (expression value))) ";")
;; If
(define-javascript-special-operator if :statement (processor condition then &optional else)
(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)
(define-javascript-special-operator %do-while :statement (processor body condition)
"do " (statement body) " while (" (expression condition) ");")
;; While
(define-javascript-special-operator while :statement (processor condition body)
(define-javascript-special-operator %while :statement (processor condition body)
"while (" (expression condition) ") " (statement body))
;; For
......@@ -464,11 +472,12 @@ statements such as blocks to *not* emit a semicolon."
#+(or)(define-javascript-special-operator return :statement (processor &optional expr)
"return" (when expr (out " " (expression expr))) ";")
(define-javascript-special-operator return :statement (processor &optional expr &environment env)
(define-javascript-special-operator %return :statement (processor &optional expr &environment env)
;; macro expansion
(loop while (macro-form-p *javascript* expr) do
(setf expr (expand-macro-form *javascript* expr env)))
(cond
((and (consp expr) (consp (car expr)))
((and (consp expr) (consp (car expr))) ;; lisp1 syntax. The car can be arbitrary lisp form
(loop while (macro-form-p *javascript* (car expr)) do
(setf expr (cons (expand-macro-form *javascript* (car expr) env) (cdr expr))))
(if (redundant-function-p expr)
......@@ -493,27 +502,32 @@ statements such as blocks to *not* emit a semicolon."
;; we generate calls to apply. On the other hand, Lispscript has its
;; own way of avoiding generating redundant scopes. Maybe.
(defun redundant-function-p (expr)
"((function () ...))"
(and
(consp expr)
(consp (car expr))
(eql (caar expr) 'function)
(or (eql (caar expr) 'function) (eql (caar expr) 'fn))
(eql (cadar expr) '())))
;; Bit of a hack to help out Lispscript generation.
(defun redundant-apply-p (expr)
(and (consp expr) (eql (car expr) 'com.gigamonkeys.foo.lispscript::|.apply|)
;; (apply (<obj-path>) this (array))
"(apply _name _function this (array))"
(and (consp expr) (eql (car expr) 'com.gigamonkeys.foo.lispscript::apply)
(destructuring-bind (name function this &optional args) expr
(declare (ignore name function))
(and
(eql this 'com.gigamonkeys.foo.lispscript::|this|)
(eql this 'com.gigamonkeys.foo.lispscript::this)
(equal args '(array))))))
(defun redundant-call-p (expr)
(and (consp expr) (eql (car expr) 'com.gigamonkeys.foo.lispscript::|.call|)
;; needs fixing. In ~ @ syntax, I would have something like (call (<obj-path>) this)
"(call _name _function this)"
(and (consp expr) (eql (car expr) 'com.gigamonkeys.foo.lispscript::call)
(destructuring-bind (name function this &rest args) expr
(declare (ignore name function))
(and
(eql this 'com.gigamonkeys.foo.lispscript::|this|)
(eql this 'com.gigamonkeys.foo.lispscript::this)
(null args)))))
;; With
......@@ -532,6 +546,7 @@ statements such as blocks to *not* emit a semicolon."
:freshline :unindent
"}")
;; Labeled statement
(define-javascript-special-operator label :statement (processor label statement)
(name label) ": " (statement statement))
......@@ -608,7 +623,7 @@ statements such as blocks to *not* emit a semicolon."
(out (name p)) (when rest (out ", ")))
")"))
(body (body)
(process *javascript* processor `(block ,@body) (new-env 'statement-or-expression :statement env))))
(process *javascript* processor `(%block ,@body) (new-env 'statement-or-expression :statement env))))
(if (and (symbolp (first body)) (not (null (first body))))
(destructuring-bind (name (&rest params) &rest body) body
(out "function " (name name) " " (params params) " " (body body)))
......@@ -618,9 +633,34 @@ statements such as blocks to *not* emit a semicolon."
(when (eql (statement-or-expression env) :expression) (raw-string processor ")"))))))
(define-javascript-special-operator fn :statement (processor &rest body &environment env)
(process *javascript* processor (cons 'function body) env))
(define-javascript-special-operator augment-environment :statement (processor (&rest pairs) &body body &environment env)
(let ((env (append pairs env)))
(loop for form in body do
(process *javascript* processor form env))))
(export '%if)
(remprop 'if 'javascript-special-operator)
(remprop 'if 'javascript-special-operator-type)
(export '%return)
(remprop 'return 'javascript-special-operator)
(remprop 'return 'javascript-special-operator-type)
(export '%block)
(remprop 'block 'javascript-special-operator)
(remprop 'block 'javascript-special-operator-type)
(export '%while)
(remprop 'while 'javascript-special-operator)
(remprop 'while 'javascript-special-operator-type)
(export '%do-while)
(remprop 'do-while 'javascript-special-operator)
(remprop 'do-while 'javascript-special-operator-type)
(export '%progn)
(remprop 'progn 'javascript-special-operator)
(remprop 'progn 'javascript-special-operator-type)
(export '%prog)
(remprop 'prog 'javascript-special-operator)
(remprop 'prog 'javascript-special-operator-type)
\ No newline at end of file
......@@ -13,6 +13,8 @@
;;; will return someobject rather than the Foo object which is 'this'
;;; in a-method. Blech.
;;; Probably should prefix all javascript primitives with %.
(in-package :com.gigamonkeys.foo.lispscript)
(defclass lispscript (javascript)
......@@ -64,6 +66,8 @@
;;; user code but handy for implementing primitive special operators
;;; and "built-in" macros.
;; it feels a little wrong the have augment-environment as a js macro. Weird
(define-javascript-macro needs-value (&body body)
`(augment-environment ((needs-value . t)) ,@body))
......@@ -71,12 +75,13 @@
`(augment-environment ((needs-value . nil)) ,@body))
(define-javascript-macro return-last (&body body)
`(prog (discard-value (prog ,@(butlast body))) (needs-value (return ,@(last body)))))
`(%prog (discard-value (%prog ,@(butlast body))) (needs-value (%return ,@(last body)))))
(define-javascript-macro scope ((&rest bindings) &body body)
`(.call
(function (,@(mapcar #'first bindings)) ,@body)
this ,@(mapcar #'second bindings)))
`(call ~
(function (,@(mapcar #'first bindings)) ,@body)
this ,@(mapcar #'second bindings)))
;;; Language constructs. These are the "special-operators" of the
;;; Lispscript language.
......@@ -85,22 +90,14 @@
`(scope (,@bindings)
,(if (needs-value env)
`(return-last ,@body)
`(discard-value (prog ,@body)))))
(define-javascript-macro let ((&rest bindings) &body body &environment env)
`(scope (,@bindings)
,(if (needs-value env)
`(return-last ,@body)
`(discard-value (prog ,@body)))))
(process-ls '(let ((foo (some randome object mmk))) (foo bar ~ a b c)))
`(discard-value (%prog ,@body)))))
(define-javascript-macro let* ((&rest bindings) &body body)
(if bindings
`(let (,(first bindings))
,@(if (rest bindings)
`((let* (,@(rest bindings)) ,@body))
body))
,@(if (rest bindings)
`((let* (,@(rest bindings)) ,@body))
body))
`(let () ,@body)))
......@@ -142,36 +139,35 @@ Widget.prototype.aClosure = function () {
(define-javascript-macro progn (&body body &environment env)
(if (needs-value env)
`(let () ,@body)
`(prog ,@body)))
`(%prog ,@body)))
(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.
`(progn ,@body)
`(augment-environment
(((open-block ,return-var) . nil))
,(if (needs-value env)
`((function
(,return-var)
(try
(return (progn ,@body))
(catch ,e
(if (eq ,e ,return-var)
(return (@ ,return-var value))
(throw ,e)))))
`((function (,return-var)
(try (%return (progn ,@body))
(catch ,e
(%if (eq ,e ,return-var)
(return (,return-var value))
(throw ,e)))))
(object value undefined))
`((function
(,return-var)
(try (prog ,@body)
`((function (,return-var)
(try (%prog ,@body)
(catch ,e
(if (eq ,e ,return-var)
(return (@ ,return-var value))
(%if (eq ,e ,return-var)
(%return (,return-var value))
(throw ,e)))))
(object value undefined)))))))
(defun block-name (symbol)
(intern (format nil "block$~a" (symbol-name symbol)) :keyword))
(intern (format nil "block$~a" symbol) :keyword))
(defun returned-p (block-name body env)
(loop with new-env = (add-open-block block-name env)
......@@ -183,13 +179,15 @@ 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.
`(progn
(set (@ ,(block-name name) value) ,value)
(set (,(block-name name) value) ,value)
((function () (throw ,(block-name name)))))
`(prog
(set (@ ,(block-name name) value) ,value)
`(%prog
(set (,(block-name name) value) ,value)
(throw ,(block-name name)))))
;; Clobbers return special op
(define-javascript-macro return (value)
`(return-from nil ,value))
......@@ -199,7 +197,7 @@ Widget.prototype.aClosure = function () {
;; Common Lisp style -- even internal DEFUN's are gobal
(define-javascript-macro defun (name (&rest params) &body body)
`(set (@ window ,name) (function ,params (return (block ,name ,@body)))))
`(set (window ,name) (function ,params (%return (block ,name ,@body)))))
;; Scheme style
#+(or)(define-javascript-macro defvar (name &optional value)
......@@ -207,12 +205,12 @@ Widget.prototype.aClosure = function () {
;; Common Lisp style
(define-javascript-macro defvar (name &optional value)
`(set (@ window ,name) ,@(when value `(,value))))
`(set (window ,name) ,@(when value `(,value))))
(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
......@@ -231,7 +229,7 @@ Widget.prototype.aClosure = function () {
`(&& ,first ,@rest))
(define-javascript-macro or (first &rest rest)
`(\\ ,first ,@rest))
`(\|\| ,first ,@rest))
(define-javascript-macro not (form)
`(! ,form))
......@@ -240,8 +238,8 @@ Widget.prototype.aClosure = function () {
(multiple-value-bind (bindings step-forms) (parse-do-variables variables)
`(block nil
(let (,@bindings)
(while (! ,end-test-form)
(block ,@body
(%while (! ,end-test-form)
(%block ,@body
,@step-forms))
,@(when result-form (list result-form))))))
......@@ -249,10 +247,10 @@ Widget.prototype.aClosure = function () {
(multiple-value-bind (bindings step-forms) (parse-do-variables variables)
`(block nil
(let* (,@bindings)
(while (! ,end-test-form)
(block ,@body
,@step-forms))
,@(when result-form (list result-form))))))
(%while (! ,end-test-form)
(%block ,@body
,@step-forms))
,@(when result-form (list result-form))))))
(define-javascript-macro dotimes ((var iterations) &body body)
(let ((iterations-value (javascript-gensym)))
......@@ -266,7 +264,7 @@ Widget.prototype.aClosure = function () {
`(block nil
(var ,sequence-value ,sequence)
(for (,idxvar in ,sequence-value)
(block (discard-value (let ((,var (ref ,sequence-value ,idxvar))) ,@body))))
(%block (discard-value (let ((,var (ref ,sequence-value ,idxvar))) ,@body))))
,@(if (needs-value env) '(undefined)))))
(define-javascript-macro doslots (((name value) sequence) &body body &environment env)
......@@ -274,11 +272,11 @@ Widget.prototype.aClosure = function () {
`(block nil
(var ,sequence-value ,sequence)
(for (,name in ,sequence-value)
(block (discard-value (let ((,value (ref ,sequence-value ,name))) ,@body))))
(%block (discard-value (let ((,value (ref ,sequence-value ,name))) ,@body))))
,@(if (needs-value env) '(undefined)))))
(define-javascript-macro while (condition &body body &environment env)
`(block nil (while ,condition (block (discard-value ,@body))) undefined))
`(block nil (%while ,condition (%block (discard-value ,@body))) undefined))
(define-javascript-macro until (condition &body body)
`(while (! ,condition) ,@body))
......@@ -296,9 +294,9 @@ Widget.prototype.aClosure = function () {
(define-javascript-macro for ((var test step) &body body &environment env)
(if (needs-value env)
`(progn
(for (,var ,test ,step) (block ,@body))
(for (,var ,test ,step) (%block ,@body))
undefined)
`(for (,var ,test ,step) (block ,@body))))
`(for (,var ,test ,step) (%block ,@body))))
(define-javascript-macro new (type &rest args)
......@@ -311,10 +309,10 @@ Widget.prototype.aClosure = function () {
`(try ,@body (catch ,e)))))
(define-javascript-macro defmethod ((class name) (&rest parameters) &body body)
`(set (@ ,class prototype ,name) (function ,parameters (return (block ,name ,@body)))))
`(set (,class prototype ,name) (function ,parameters (%return (block ,name ,@body)))))
(define-javascript-macro define-class-method ((class name) (&rest parameters) &body body)
`(set (@ ,class ,name) (function ,parameters (return (block ,name ,@body)))))
`(set (,class ,name) (function ,parameters (%return (block ,name ,@body)))))
(define-javascript-macro ref (var &rest slots)
`(ref ,var ,@slots))
......
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