Commit e1756498 authored by hayeah's avatar hayeah

Worked in the ~ @ message passing syntax for javascript.lisp

Function call not working yet.

darcs-hash:bd5647589aeb865203b9075d8f7d478bbf937cbd
parent 56161009
......@@ -42,52 +42,130 @@
(defmethod special-operator-symbol ((language javascript)) 'javascript-special-operator)
(defmethod macro-symbol ((language javascript)) 'javascript-macro)
(defmethod macro-symbol ((language javascript)) 'javascript-macro)
;;;; Utility for Javascript message-passing parser .
(defun split-by-tests (lst test-lst &key ((:test default-test) #'eql))
"The provided list of tests are used as separators to break a list into list of alists.
The if the test if an not a procedure, it is compared to each element of the list with eql as default.
-
The list to be splitted must satisfy 2 conditions:
1) The separators must occur in sequential order.
2) Separators must not occur twice in the same list.
-
Some separators may be omitted from the list.
-
Return:
(<args-before-first-separator> (<separator> <args-between-this-and-next-separator>)*) "
(flet ((do-test (test msg)
(if (functionp test)
(funcall test msg)
(funcall default-test test msg))))
(loop with tests = test-lst
with done-tests = nil
with section = nil ; What I really want is use collect instead, but see next comment
for msgs on lst
for msg = (car msgs)
for is-separator? = (loop for test in tests
collect test into done-tests2
thereis (and (do-test test msg)
(setq done-tests (append done-tests2 done-tests)) done-tests2))
if is-separator?
collect (nreverse section) into sections
and do (setq section (list msg) ; I need to set section nil here, but if using collect would reset it back.
tests (cdr tests))
else
if (loop for test in done-tests thereis (do-test test msg))
do (error "repeated separator ~S found. With tests ~S on list ~S" msg test-lst lst)
else do (push msg section)
end
end
finally (return (nconc sections (list (nreverse section)))))))
(defun parse-js-form (js-form)
"Parse javascript form of the form
(<js-form>* [~ <js-form>*] [@ <js-form>*])
Where forms before ~ are object path.
Between ~ and @ are arguments to method application.
After @ are array references.
-
Return
((<js-form>*) (~ <js-form>*) (@ <js-form>*)) "
(let* ((separators '(~ @))
(broken-form (split-by-tests js-form '(~ @))))
(cons (car broken-form)
(mapcar #'(lambda (separator)(assoc separator broken-form))
separators))))
;; (parse-js-form '(1 2 3 ~ 2 4 5 @ 39))
;; ;; error
;; (parse-js-form '(~ 2 4 5 @ 3 9))
;; ;; ok
;; (parse-js-form '(2 @ 3 9))
;; ;; ok
;; (parse-js-form '(2 ~ @ 3 9))
;; ;; ok?
;; (parse-js-form '(2 ~ @))
;; (use-package :wisp.util)
(defmethod process-sexp ((language javascript) processor form environment)
(if (consp form)
(destructuring-bind (name &rest arguments) form
(if (method-name name)
(process-method-call language processor environment
(method-name name)
(first arguments)
(rest arguments))
(process-function-call language processor environment
name
arguments)))
;; Need to deal with anonymous function call using process-function-call
(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)))
;; allows empty array reference??
;; ;; or raise error here.
;; ;; ;; Currently (foo @) => foo
(when arefs (process-array-reference language processor environment (cdr arefs))))
(process-javascript-scalar processor form))
(maybe-semicolon processor environment))
(defun method-name (name)
(cond
((and (consp name) (eql (first name) 'method))
(second name))
((and (symbolp name) (char= (char (string name) 0) #\.))
(intern (subseq (string name) 1) (symbol-package name)))
(t nil)))
(defun process-method-call (language processor environment method-name object arguments)
(process language processor object (new-env 'statement-or-expression :expression environment))
(raw-string processor ".")
(process language processor method-name (new-env 'statement-or-expression :expression environment))
(defun process-object-path (language processor environment objects)
(loop for (obj . rest) on objects do
(process language processor obj (new-env 'statement-or-expression :expression environment))
when rest do (raw-string processor ".")))
(defun process-method-call (language processor environment arguments)
(raw-string processor "(")
(loop for (arg . rest) on arguments do
(loop for (arg . rest) on arguments do
(process language processor arg (new-env 'statement-or-expression :expression environment))
when rest do (raw-string processor ", "))
when rest do (raw-string processor ","))
(raw-string processor ")"))
(defun process-function-call (language processor environment name arguments)
(let ((function-expression-statement-p
(and (consp name) (eql (car name) 'function) (eql (statement-or-expression environment) :statement))))
(when function-expression-statement-p (raw-string processor "("))
(process language processor name (new-env 'statement-or-expression :expression environment))
(when function-expression-statement-p (raw-string processor ")"))
(raw-string processor "(")
(loop for (arg . rest) on arguments do
(defun process-array-reference (language processor environment references)
(loop for (arg . rest) on references do
(progn
(raw-string processor "[")
(process language processor arg (new-env 'statement-or-expression :expression environment))
when rest do (raw-string processor ", "))
(raw-string processor ")")))
(raw-string processor "]"))))
;;;; Functionl call not dealt with yet
;; (defun process-function-call (language processor environment name arguments)
;; (let ((function-expression-statement-p
;; (and (consp name) (eql (car name) 'function) (eql (statement-or-expression environment) :statement))))
;; (when function-expression-statement-p (raw-string processor "("))
;; (process language processor name (new-env 'statement-or-expression :expression environment))
;; (when function-expression-statement-p (raw-string processor ")"))
;; (raw-string processor "(")
;; (loop for (arg . rest) on arguments do
;; (process language processor arg (new-env 'statement-or-expression :expression environment))
;; when rest do (raw-string processor ", "))
;; (raw-string processor ")")))
(defun process-javascript-scalar (processor value)
;; This is where better smarts about translating Lisp values to
......@@ -226,7 +304,7 @@ statements such as blocks to *not* emit a semicolon."
(define-javascript-special-operator array :expression (processor &rest elements)
"["
(loop for (e . rest) on elements
do (expression e)
do (expression e)
when rest do (out ", "))
"]")
......@@ -373,9 +451,9 @@ statements such as blocks to *not* emit a semicolon."
(out "return" (when expr (out " " (expression expr))) ";"))))
;;; Is this needed anymore? Probabyl won't work for Lispscript since
;;; we generate calls to apply. On the other hand, Lispscript has its
;;; own way of avoiding generating redundant scopes. Maybe.
;; Is this needed anymore? Probabyl won't work for Lispscript since
;; 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)
(and
(consp expr)
......
......@@ -73,3 +73,9 @@
(format t ";; For test results view ~A~%" (namestring html-file))
(format t ";; using a Firefox broswer.~%")
nil))
(generate-from-string *lispscript* "(@ (.foo bar))")
(generate-from-string *lispscript* "(.foo bar (.baz maz jo jo))")
(generate-from-string *lispscript* "(@ (.foo bar) baz)")
(generate-from-string *lispscript* "((foo ~ bar) baz)")
\ No newline at end of file
......@@ -2,29 +2,32 @@
(defvar fail 0)
(defun dotest (ls js result expected note)
(let* ((results (.get-element-by-id document "results"))
(row (.insert-row results (@ results rows length))))
(set (@ (.insert-cell row (@ row cells length)) innerHTML) ls)
(set (@ (.insert-cell row (@ row cells length)) innerHTML) js)
(set (@ (.insert-cell row (@ row cells length)) innerHTML) (display-string expected))
(set (@ (.insert-cell row (@ row cells length)) innerHTML) (display-string result))
(let* ((results (document get-element-by-id ~ "results"))
(row (results insert-row (results rows length))))
(set ((row insert-cell ~ (row cells length)) innerHTML) ls)
(set ((row insert-cell ~ (row cells length)) innerHTML) js)
(set ((row insert-cell ~ (row cells length)) innerHTML) (display-string expected))
(set ((row insert-cell ~ (row cells length)) innerHTML) (display-string result))
(cond
((eq result expected)
(set (@ (.insert-cell row (@ row cells length)) innerHTML) "Pass")
(set (@ row style background) "#aaffaa")
(++ pass)
(set (@ (.get-element-by-id document "passes") innerHTML) pass))
(set ((row insert-cell ~ (row cells length)) innerHTML) "Pass")
(set (row style background) "#aaffaa")
(+1 pass) ; pre increment
(set ((document get-element-by-id ~ "passes") innerHTML) pass))
(true
(set (@ (.insert-cell row (@ row cells length)) innerHTML) "Fail")
(set (@ row style background) "#ffaaaa")
(++ fail)
(set (@ (.get-element-by-id document "failures") innerHTML) fail)))))
(set ((row insert-cell ~ (row cells length)) innerHTML) "Fail")
(set (row style background) "#ffaaaa")
(1+ fail) ; post increment, cute.
(set ((document get-element-by-id ~ "failures") innerHTML) fail)))))
(defun all-tests-done ()
(set (@ (.get-element-by-id document "done") innerHTML) "All tests completed."))
(set ((document get-element-by-id ~ "done") innerHTML) "All tests completed."))
(defun display-string (obj)
(if (and obj (equal (@ obj constructor) String))
(if (and obj (equal (obj constructor) String))
(+ "\"" obj "\"")
(+ "" obj)))
\ No newline at end of file
(+ "" obj)))
(defpackage :wisp.util (:use :cl :cl-interpol :it.bese.fiveam)
(:export :with-gensyms
:while
;; :while
:until
:fn
......@@ -25,7 +25,9 @@
:awhile
:acond
:aand
:afn))
:afn
:split-if))
(in-package :wisp.util)
......
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