Changeset 1458

Timestamp:

03/13/05 22:43:46 (4 years ago)

Author:

manuel

Message:

radiosendung, einchecken fuer nachher, eigentlich geht alles

Files:

• trunk/bknr/src/js/js2.lisp (modified) (10 diffs)
• trunk/bknr/src/js/utils.lisp (modified) (1 diff)

trunk/bknr/src/js/js2.lisp

@@ -70 +70 @@
-;;; void
-;;; function
+;;; case
+;;; default
+;;; do
+;;; for
+;;; switch
+;;; while
+;;; with
+;;; throw
-;;;
-;;; TODO:
-;;; case
-;;; catch
-;;; default
-;;; do
-;;; finally
-;;; for
-;;; switch
-;;; throw
-;;; try
-;;; while
-;;; with
-
-;;; Punctuators
@@ -360 +360 @@
-;;; variables
-
-
+js-
-  ())
-
-
+js-
-  (list (symbol-to-js (value v))))
-
@@ -633 +633 @@
-               :collect nil)))
-
-
+js-
-  ((object :initarg :object
-           :accessor sv-object)
@@ -640 +640 @@
-
-(define-js-compiler-macro slot-value (obj slot)
-
+js-
-                 :slot (js-compile-to-symbol slot)))
-
-
+js-
-  (append-to-last (js-to-strings (sv-object sv) start-pos)
-                  (format nil ".~A" (symbol-to-js (sv-slot sv)))))
@@ -704 +704 @@
-
-(defmethod expression-precedence ((if js-if))
-  (declare (ignore if))
-  (gethash 'if *op-precedence-hash*))
-
@@ -757 +756 @@
-
-(define-js-single-op return statement)
+(define-js-single-op throw statement)
-(define-js-single-op delete)
-(define-js-single-op void)
@@ -786 +786 @@
-
-(defmethod expression-precedence ((setf js-setf))
-  (declare (ignore setf))
-  (gethash '= *op-precedence-hash*))
-
@@ -829 +828 @@
-;;; iteration
-
+(defclass js-for (statement)
+  ((vars :initarg :vars :accessor for-vars)
+   (steps :initarg :steps :accessor for-steps)
+   (check :initarg :check :accessor for-check)
+   (body :initarg :body :accessor for-body)))
+
+(defun make-for-vars (decls)
+  (loop for decl in decls
+        for var = (if (atom decl) decl (first decl))
+        for init = (if (atom decl) nil (second decl))
+        collect (make-instance 'js-defvar :names (list (js-compile-to-symbol var))
+                               :value (js-compile-to-expression init))))
+
+(defun make-for-steps (decls)
+  (loop for decl in decls
+        when (= (length decl) 3)
+        collect (js-compile-to-expression (third decl))))
+
+(define-js-compiler-macro do (decls termination &rest body)
+  (let ((vars (make-for-vars decls))
+        (steps (make-for-steps decls))
+        (check (js-compile-to-expression (list 'not (first termination))))
+        (body (js-compile-to-body (cons 'progn body) :indent "  ")))
+    (make-instance 'js-for
+                   :vars vars
+                   :steps steps
+                   :check check
+                   :body body)))
+
+(defun strings-length (string-list)
+  (reduce #'max (mapcar #'length string-list) :initial-value most-negative-fixnum))
+
+(defmethod js-to-statement-strings ((for js-for) start-pos)
+  (let* ((init (dwim-join (mapcar #'(lambda (x)
+                                      (dwim-join (list (list (symbol-to-js (first (var-names x))))
+                                                       (js-to-strings (var-value x)
+                                                                      (+ start-pos 2)))
+                                                 (- 80 start-pos 2)
+                                                 :join-after " ="))
+                                  (for-vars for))
+                          (- 80 start-pos 2)
+                          :start "var " :join-after ","))
+         #+nil
+         (init-len (strings-length init))
+         (check (js-to-strings (for-check for) (+ start-pos 2)))
+         #+nil
+         (check-len (strings-length check))
+         (steps (dwim-join (mapcar #'(lambda (x)
+                                       (js-to-strings x (- start-pos 2)))
+                                   (for-steps for))
+                           (- 80 start-pos 2)
+                           :join-after ","))
+         (header (dwim-join (list init check steps)
+                            (- 80 start-pos 2)
+                            :start "for (" :end ") {"
+                            :join-after ";"))
+         (body (js-to-statement-strings (for-body for) (+ start-pos 2))))
+    (nconc header body (list "}"))))
+
+  (let ((fun-header (dwim-join (mapcar #'(lambda (x) (list (symbol-to-js x)))
+                                       (d-args defun))
+                               (- 80 start-pos 2)
+                               :start (format nil "function ~A("
+                                              (symbol-to-js (d-name defun)))
+                               :end ") {" :join-after ","))
+        (fun-body (js-to-statement-strings (d-body defun) (+ start-pos 2))))
+    (nconc fun-header fun-body (list "}"))))
+
+(defclass for-each (statement)
+  ((name :initarg :name :accessor fe-name)
+   (value :initarg :value :accessor fe-value)
+   (body :initarg :value :accessor fe-body)))
+
+(define-js-compiler-macro do-each (decl &rest body)
+  (make-instance 'for-each :name (js-compile-to-symbol (first decl))
+                 :value (js-compile-to-expression (second decl))
+                 :body (js-compile-to-body (cons 'progn body) :indent "  ")))
+
+(defmethod js-to-statement-strings ((fe for-each) start-pos)
+  (let ((header (dwim-join (list (list (symbol-to-js (fe-name fe)) " in ")
+                                 (js-to-strings (fe-value fe) (+ start-pos 2)))
+                           :start "for (var "
+                           :end ") {"))
+        (body (js-to-statement-strings (fe-body fe) (+ start-pos 2))))
+    (nconc header body (list "}"))))
+
+(defclass js-while (statement)
+  ((check :initarg :check :accessor while-check)
+   (body :initarg :body :accessor while-body)))
+
+(define-js-compiler-macro while (check &rest body)
+  (make-instance 'js-while
+                 :check (js-compile-to-expression check)
+                 :body (js-compile-to-body (cons 'progn body) :indent "  ")))
+
+(defmethod js-to-statement-strings ((while js-while) start-pos)
+  (let ((header (dwim-join (list (js-to-strings (while-check while) (+ start-pos 2)))
+                           (- 80 start-pos 2)
+                           :start "while ("
+                           :end ") {"))
+        (body (js-to-statement-strings (while-body while) (+ start-pos 2))))
+    (nconc header body (list "}"))))
+
-;;; with
-
+(defclass js-with (statement)
+  ((obj :initarg :obj :accessor with-obj)
+   (body :initarg :body :accessor with-body)))
+
+(define-js-compiler-macro with (statement &rest body)
+  (make-instance 'js-with
+                 :obj (js-compile-to-expression (first statement))
+                 :body (js-compile-to-body (cons 'progn body) :indent "  ")))
+
+(defmethod js-to-statement-strings ((with js-with) start-pos)
+  (nconc (dwim-join (list (js-to-strings (with-obj with) (+ start-pos 2)))
+                    (- 80 start-pos 2)
+                    :start "with (" :end ") {")
+         (js-to-statement-strings (with-body with) (+ start-pos 2))
+         (list "}")))
+
-;;; case
-
+(defclass js-case (statement)
+  ((value :initarg :value :accessor case-value)
+   (clauses :initarg :clauses :accessor case-clauses)))
+
+;;; XXX DEFAULT exporten
+(define-js-compiler-macro case (value &rest clauses)
+  (let ((clauses (mapcar #'(lambda (clause)
+                             (let ((val (first clause))
+                                   (body (cdr clause)))
+                               (list (if (eql val 'default)
+                                         'default
+                                         (js-compile-to-expression val))
+                                     (js-compile-to-body (cons 'progn body) :indent "  "))))
+                         clauses))
+        (check (js-compile-to-expression value)))
+    (make-instance 'js-case :value check
+                   :clauses clauses)))
+
+(defmethod js-to-statement-strings ((case js-case) start-pos)
+  (let ((body    (mapcan #'(lambda (clause)
+                     (let ((val (car clause))
+                           (body (second clause)))
+                       (dwim-join (list (if (eql val 'default)
+                                            (list "")
+                                            (js-to-strings val (+ start-pos 2)))
+                                        (js-to-statement-strings body (+ start-pos 2)))
+                                  (- 80 start-pos 2)
+                                  :start (if (eql val 'default) "  default" "  case ")
+                                  :white-space "   "
+                                  :join-after ":"))) (case-clauses case))))
+
+    (format t "body: ~S~%" body)
+    (nconc (dwim-join (list (js-to-strings (case-value case) (+ start-pos 2)))
+                    (- 80 start-pos 2)
+                    :start "switch (" :end ") {")
+           body
+           (list "}"))))
+
-;;; throw catch
+
+(defclass js-try (statement)
+  ((body :initarg :body :accessor try-body)
+   (catch :initarg :catch :accessor try-catch)
+   (finally :initarg :finally :accessor try-finally)))
+
+(define-js-compiler-macro try (body clauses)
+  (let ((body (js-compile-to-body body :indent "  "))
+        (catch (cdr (assoc :catch clauses)))
+        (finally (cdr (assoc :finally clauses))))
+    (make-instance 'js-try
+                   :body body
+                   :catch (when catch (list (js-compile-to-symbol (first catch))
+                                            (js-compile-to-body (cons 'progn (cdr catch))
+                                                                :indent "  ")))
+                   :finally (when finally (js-compile-to-body finally :indent "   ")))))
+
+(defmethod js-to-statement-strings ((try js-try) start-pos)
+  (let* ((catch (try-catch try))
+         (finally (try-finally try))
+         (catch-list (when catch
+                       (dwim-join (list (list (symbol-to-js (first catch)))
+                                        (js-to-strings (second catch) (+ start-pos 2)))
+                                  (- 80 start-pos 2)
+                                  :start "} catch ("
+                                  :end ") {")))
+         (finally-list (when finally
+                         (dwim-join (list (js-to-strings finally (+ start-pos 2)))
+                                    (- 80 start-pos 2)
+                                    :start "finally {"))))
+    (nconc (dwim-join (list (js-to-statement-strings (try-body try) (+ start-pos 2)))
+                      (- 80 start-pos 2)
+                      :start "try {")
+           catch-list
+           finally-list
+           (list "}"))))
-
-;;; regex
@@ -870 +1062 @@
-           (if c-macro
-               (funcall c-macro)
-
+js-
-        ((and (consp form)
-              (eql (first form) 'quote))
@@ -909 +1101 @@
-(defun js-compile-to-symbol (form)
-  (let ((res (js-compile form)))
-
+js-
-      (setf res (value res)))
-    (assert (symbolp res))

trunk/bknr/src/js/utils.lisp

@@ -22 +22 @@
-        (t (princ-to-string val))))
-
+(defun prepend-to-first (form elt)
+  (cond ((stringp form)
+         (concatenate 'string elt form))
+        ((consp form)
+         (cond ((stringp (first form))
+                (rplaca form (concatenate 'string elt (car form))))
+               ((consp (first form))
+                (prepend-to-first (first form) elt))
+               (t (error "unknown form")))
+         form)
+        (t (error "unknown form"))))
+
+(defun append-to-last (form elt)
+  (cond ((stringp form)
+         (concatenate 'string form elt))
+        ((consp form)
+         (let ((last (last form)))
+           (cond ((stringp (first last))
+                  (rplaca last (concatenate 'string (first last) elt)))
+                 ((consp (first last))
+                  (append-to-last last elt))
+                 (t (error "unknown form")))
+           form))
+        (t (error "unknown form"))))