From 0ce67a33228383888a07b968ce978c170a112cc8 Mon Sep 17 00:00:00 2001 From: Vladimir Sedach Date: Mon, 6 Apr 2009 20:46:19 -0600 Subject: [PATCH] Modified the PS compiler to produce an intermediate representation that looks like raw JavaScript in s-exp notation. Removed the doeach macro. --- docs/reference.lisp | 20 +-- src/compiler.lisp | 15 +-- src/package.lisp | 26 +++- src/printer.lisp | 104 ++++++++------- src/special-forms.lisp | 286 +++++++++++++++++------------------------ src/utils.lisp | 2 +- t/ps-tests.lisp | 4 - t/reference-tests.lisp | 13 +- 8 files changed, 209 insertions(+), 261 deletions(-) diff --git a/docs/reference.lisp b/docs/reference.lisp index 8ead719..ec5a813 100644 --- a/docs/reference.lisp +++ b/docs/reference.lisp @@ -805,14 +805,14 @@ a-variable => aVariable ;;;t \index{DO} ;;;t \index{DOTIMES} ;;;t \index{DOLIST} -;;;t \index{DOEACH} +;;;t \index{FOR-IN} ;;;t \index{WHILE} ; (DO ({var | (var {init}? {step}?)}*) (end-test {result}?) body) ; (DO* ({var | (var {init}? {step}?)}*) (end-test {result}?) body) ; (DOTIMES (var numeric-form {result}?) body) ; (DOLIST (var list-form {result}?) body) -; (DOEACH ({var | (key value)} object-form {result}?) body) +; (FOR-IN (var object) body) ; (WHILE end-test body) ; ; var ::= a Lisp symbol @@ -926,28 +926,16 @@ a-variable => aVariable return s; })()); -;;; `DOEACH' iterates across the enumerable properties of JS objects, -;;; binding either simply the key of each slot, or alternatively, both -;;; the key and the value. +;;; `FOR-IN' is translated to the JS `for...in' statement. (let* ((obj (create :a 1 :b 2 :c 3))) - (doeach (i obj) + (for-in (i obj) (document.write (+ i ": " (aref obj i) "
")))) => var obj = { a : 1, b : 2, c : 3 }; for (var i in obj) { document.write(i + ': ' + obj[i] + '
'); }; -(let* ((obj (create :a 1 :b 2 :c 3))) - (doeach ((k v) obj) - (document.write (+ k ": " v "
")))) -=> var obj = { a : 1, b : 2, c : 3 }; - var v; - for (var k in obj) { - v = obj[k]; - document.write(k + ': ' + v + '
'); - }; - ;;; The `WHILE' form is transformed to the JavaScript form `while', ;;; and loops until a termination test evaluates to false. diff --git a/src/compiler.lisp b/src/compiler.lisp index 3cf539e..160ff52 100644 --- a/src/compiler.lisp +++ b/src/compiler.lisp @@ -198,7 +198,7 @@ compiled to an :expression (the default), a :statement, or a resultant symbol has an associated script-package. Raises an error if the form cannot be compiled to a symbol." (let ((exp (compile-parenscript-form form))) - (when (eql (first exp) 'js-variable) + (when (eq (first exp) 'js:variable) (setf exp (second exp))) (assert (symbolp exp) () "~a is expected to be a symbol, but compiles to ~a (the ParenScript output for ~a alone is \"~a\"). This could be due to ~a being a special form." form exp form (ps* form) form) @@ -227,7 +227,7 @@ the form cannot be compiled to a symbol." (if (ps-literal-p symbol) (funcall (get-ps-special-form symbol) :symbol) (error "Attempting to use Parenscript special form ~a as variable" symbol))) - (t (list 'js-variable symbol)))) + (t `(js:variable ,symbol)))) (defun ps-convert-op-name (op) (case (ensure-ps-symbol op) @@ -243,13 +243,12 @@ the form cannot be compiled to a symbol." (args (cdr form))) (cond ((ps-special-form-p form) (apply (get-ps-special-form name) (cons expecting args))) ((op-form-p form) - (list 'operator - (ps-convert-op-name (compile-parenscript-form (first form) :expecting :symbol)) - (mapcar (lambda (form) (compile-parenscript-form form :expecting :expression)) (rest form)))) + `(js:operator + ,(ps-convert-op-name (compile-parenscript-form (first form) :expecting :symbol)) + ,@(mapcar (lambda (form) (compile-parenscript-form form :expecting :expression)) (rest form)))) ((funcall-form-p form) - (list 'js-funcall - (compile-parenscript-form name :expecting :expression) - (mapcar (lambda (arg) (compile-parenscript-form arg :expecting :expression)) args))) + `(js:funcall ,(compile-parenscript-form name :expecting :expression) + ,@(mapcar (lambda (arg) (compile-parenscript-form arg :expecting :expression)) args))) (t (error "Cannot compile ~S to a ParenScript form." form))))) (defvar *ps-gensym-counter* 0) diff --git a/src/package.lisp b/src/package.lisp index b078cba..452de0e 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -92,7 +92,6 @@ #:do* #:dotimes #:dolist - #:doeach ;; with #:with @@ -250,6 +249,31 @@ #:if #:unary-operator #:-- + #:! + #:block + #:literal + #:break + #:continue + #:return + #:throw + #:array + #:aref + #:++ + #:+= + #:operator + #:-= + #:- + #:= + #:cond + #:lambda + #:object + #:variable + #:slot-value + #:new + #:funcall + #:instanceof + #:in + #:escape )) ) diff --git a/src/printer.lisp b/src/printer.lisp index c4ce792..778cd6b 100644 --- a/src/printer.lisp +++ b/src/printer.lisp @@ -15,11 +15,11 @@ vice-versa.") (defmethod parenscript-print (form) (let ((*indent-level* 0) (*print-accumulator* ())) - (if (and (listp form) (eql 'js-block (car form))) ; ignore top-level block - (loop for (statement . remaining) on (third form) do - (ps-print statement) (psw ";") (when remaining (psw #\Newline))) - (ps-print form)) - (nreverse *print-accumulator*))) + (if (and (listp form) (eq 'js:block (car form))) ; ignore top-level block + (loop for (statement . remaining) on (third form) do + (ps-print statement) (psw ";") (when remaining (psw #\Newline))) + (ps-print form)) + (nreverse *print-accumulator*))) (defun psw (obj) (push (if (characterp obj) (string obj) obj) *print-accumulator*)) @@ -83,10 +83,10 @@ arguments, defines a printer for that form using the given body." (defun expression-precedence (expr) (if (consp expr) (case (car expr) - ((js-slot-value js-aref) (op-precedence (car expr))) - (js-assign (op-precedence '=)) + ((js:slot-value js:aref) (op-precedence (car expr))) + (js:= (op-precedence 'js:=)) (js:? (op-precedence 'js:?)) - (unary-operator (op-precedence (second expr))) + (js:unary-operator (op-precedence (second expr))) (operator (op-precedence (second expr))) (otherwise 0)) 0)) @@ -95,13 +95,13 @@ arguments, defines a printer for that form using the given body." (defparameter *op-precedence-hash* (make-hash-table :test 'eq)) (let ((precedence 1)) - (dolist (ops '((new js-slot-value js-aref) + (dolist (ops '((js:new js:slot-value js:aref) (postfix++ postfix--) (delete void typeof ++ -- unary+ unary- ~ !) (* / %) (+ -) (<< >> >>>) - (< > <= >= js-instance-of in) + (< > <= >= js:instanceof js:in) (== != === !== eql) (&) (^) @@ -109,7 +109,7 @@ arguments, defines a printer for that form using the given body." (\&\& and) (\|\| or) (js:?) - (= *= /= %= += -= <<= >>= >>>= \&\= ^= \|= js-assign) + (= *= /= %= += -= <<= >>= >>>= \&\= ^= \|=) (comma))) (dolist (op ops) (setf (gethash op *op-precedence-hash*) precedence)) @@ -118,31 +118,31 @@ arguments, defines a printer for that form using the given body." (defun op-precedence (op) (gethash op *op-precedence-hash*))) -(defprinter js-literal (str) +(defprinter js:literal (str) (psw str)) (defun print-comma-delimited-list (ps-forms) (loop for (form . remaining) on ps-forms do (ps-print form) (when remaining (psw ", ")))) -(defprinter array-literal (&rest initial-contents) +(defprinter js:array (&rest initial-contents) (psw #\[) (print-comma-delimited-list initial-contents) (psw #\])) -(defprinter js-aref (array indices) - (if (>= (expression-precedence array) #.(op-precedence 'js-aref)) +(defprinter js:aref (array indices) + (if (>= (expression-precedence array) #.(op-precedence 'js:aref)) (parenthesize-print array) (ps-print array)) (loop for idx in indices do (psw #\[) (ps-print idx) (psw #\]))) -(defprinter js-variable (var) +(defprinter js:variable (var) (psw (js-translate-symbol var))) ;;; arithmetic operators (defun parenthesize-print (ps-form) (psw #\() (ps-print ps-form) (psw #\))) -(defprinter operator (op args) +(defprinter js:operator (op &rest args) (loop for (arg . remaining) on args with precedence = (op-precedence op) do (if (>= (expression-precedence arg) precedence) @@ -150,7 +150,7 @@ arguments, defines a printer for that form using the given body." (ps-print arg)) (when remaining (psw (format nil " ~(~A~) " op))))) -(defprinter unary-operator (op arg &key prefix space) +(defprinter js:unary-operator (op arg &key prefix space) (when prefix (psw (format nil "~(~a~)~:[~; ~]" op space))) (if (> (expression-precedence arg) (op-precedence (case op @@ -161,14 +161,14 @@ arguments, defines a printer for that form using the given body." (ps-print arg)) (unless prefix (psw (format nil "~(~a~)" op)))) -(defprinter js-funcall (fun-designator args) - (funcall (if (member (car fun-designator) '(js-variable js-aref js-slot-value js-funcall)) +(defprinter js:funcall (fun-designator &rest args) + (funcall (if (member (car fun-designator) '(js:variable js:aref js:slot-value js:funcall)) #'ps-print #'parenthesize-print) fun-designator) (psw #\() (print-comma-delimited-list args) (psw #\))) -(defprinter js-block (block-type statements) +(defprinter js:block (block-type statements) (case block-type (:statement (psw #\{) @@ -184,10 +184,10 @@ arguments, defines a printer for that form using the given body." (ps-print statement) (when remaining (psw ", "))) (psw #\))))) -(defprinter js-lambda (args body) +(defprinter js:lambda (args body) (print-fun-def nil args body)) -(defprinter js-defun (name args body) +(defprinter js:defun (name args body) (print-fun-def name args body)) (defun print-fun-def (name args body-block) @@ -197,7 +197,7 @@ arguments, defines a printer for that form using the given body." (psw ") ") (ps-print body-block)) -(defprinter js-object (slot-defs) +(defprinter js:object (&rest slot-defs) (psw "{ ") (loop for ((slot-name . slot-value) . remaining) on slot-defs do (if (and (listp slot-name) (eq 'quote (car slot-name)) (symbolp (second slot-name))) @@ -208,17 +208,17 @@ arguments, defines a printer for that form using the given body." (when remaining (psw ", "))) (psw " }")) -(defprinter js-slot-value (obj slot) - (if (or (> (expression-precedence obj) #.(op-precedence 'js-slot-value)) +(defprinter js:slot-value (obj slot) + (if (or (> (expression-precedence obj) #.(op-precedence 'js:slot-value)) (numberp obj) - (and (listp obj) (member (car obj) '(js-lambda js-object)))) + (and (listp obj) (member (car obj) '(js:lambda js:object)))) (parenthesize-print obj) (ps-print obj)) (if (symbolp slot) (progn (psw #\.) (psw (js-translate-symbol slot))) (progn (psw #\[) (ps-print slot) (psw #\])))) -(defprinter js-cond-statement (clauses) +(defprinter js:cond (clauses) (loop for (test body-block) in clauses for start = "if (" then " else if (" do (if (equalp test "true") @@ -246,30 +246,30 @@ arguments, defines a printer for that form using the given body." (parenthesize-print else) (ps-print else))) -(defprinter js-assign (lhs rhs) +(defprinter js:= (lhs rhs) (ps-print lhs) (psw " = ") (ps-print rhs)) -(defprinter js-var (var-name &rest var-value) +(defprinter js:var (var-name &rest var-value) (psw "var ") (psw (js-translate-symbol var-name)) (when var-value (psw " = ") (ps-print (car var-value)))) -(defprinter js-break (&optional label) +(defprinter js:break (&optional label) (psw "break") (when label (psw " ") (psw (js-translate-symbol label)))) -(defprinter js-continue (&optional label) +(defprinter js:continue (&optional label) (psw "continue") (when label (psw " ") (psw (js-translate-symbol label)))) ;;; iteration -(defprinter js-for (label vars tests steps body-block) +(defprinter js:for (label vars tests steps body-block) (when label (psw (js-translate-symbol label)) (psw ": ") (newline-and-indent)) (psw "for (") (loop for ((var-name . var-init) . remaining) on vars @@ -284,7 +284,7 @@ arguments, defines a printer for that form using the given body." (psw ") ") (ps-print body-block)) -(defprinter js-for-in (var object body-block) +(defprinter js:for-in (var object body-block) (psw "for (") (ps-print var) (psw " in ") (if (> (expression-precedence object) (op-precedence 'in)) (parenthesize-print object) @@ -292,15 +292,15 @@ arguments, defines a printer for that form using the given body." (psw ") ") (ps-print body-block)) -(defprinter js-while (test body-block) +(defprinter js:while (test body-block) (psw "while (") (ps-print test) (psw ") ") (ps-print body-block)) -(defprinter js-with (expression body-block) +(defprinter js:with (expression body-block) (psw "with (") (ps-print expression) (psw ") ") (ps-print body-block)) -(defprinter js-switch (test clauses) +(defprinter js:switch (test clauses) (flet ((print-body-statements (body-statements) (incf *indent-level*) (loop for statement in body-statements do @@ -321,7 +321,7 @@ arguments, defines a printer for that form using the given body." (newline-and-indent) (psw #\}))) -(defprinter js-try (body-block &key catch finally) +(defprinter js:try (body-block &key catch finally) (psw "try ") (ps-print body-block) (when catch @@ -332,42 +332,40 @@ arguments, defines a printer for that form using the given body." (ps-print finally))) ;;; regex -(defprinter js-regex (regex) +(defprinter js:regex (regex) (flet ((first-slash-p (string) (and (> (length string) 0) (char= (char string 0) #\/)))) (let ((slash (unless (first-slash-p regex) "/"))) (psw (format nil (concatenate 'string slash "~A" slash) regex))))) ;;; conditional compilation -(defprinter cc-if (test body-forms) +(defprinter js:cc-if (test &rest body) (psw "/*@if ") (ps-print test) (incf *indent-level*) - (dolist (form body-forms) + (dolist (form body) (newline-and-indent) (ps-print form) (psw #\;)) (decf *indent-level*) (newline-and-indent) (psw "@end @*/")) -(defprinter js-instanceof (value type) +(defprinter js:instanceof (value type) (psw #\() - (if (> (expression-precedence value) (op-precedence 'js-instance-of)) + (if (> (expression-precedence value) (op-precedence 'js:instanceof)) (parenthesize-print value) (ps-print value)) (psw " instanceof ") - (if (> (expression-precedence type) (op-precedence 'js-instance-of)) + (if (> (expression-precedence type) (op-precedence 'js:instanceof)) (parenthesize-print type) (ps-print type)) (psw #\))) -(defprinter js-escape (lisp-form) - (psw `(ps1* ,lisp-form))) +(defprinter js:escape (literal-js) + (psw literal-js)) ;;; named statements -(macrolet ((def-stmt-printer (&rest stmts) - `(progn ,@(mapcar (lambda (stmt) - `(defprinter ,(intern (format nil "JS-~a" stmt)) (expr) - (psw (format nil "~(~a~) " ',stmt)) - (ps-print expr))) - stmts)))) - (def-stmt-printer throw return)) +(defprinter js:throw (x) + (psw "throw ") (ps-print x)) + +(defprinter js:return (x) + (psw "return ") (ps-print x)) diff --git a/src/special-forms.lisp b/src/special-forms.lisp index d34f501..0839dcb 100644 --- a/src/special-forms.lisp +++ b/src/special-forms.lisp @@ -1,4 +1,4 @@ -(in-package :parenscript) +(in-package "PARENSCRIPT") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; literals @@ -6,7 +6,7 @@ `(progn (add-ps-literal ',name) (define-ps-special-form ,name () - (list 'js-literal ,string)))) + (list 'js:literal ,string)))) (defpsliteral this "this") (defpsliteral t "true") @@ -21,8 +21,8 @@ (add-ps-literal ',name) (define-ps-special-form ,name (&optional label) (list ',printer label))))) - (def-for-literal break js-break) - (def-for-literal continue js-continue)) + (def-for-literal break js:break) + (def-for-literal continue js:continue)) (defpsmacro quote (x) (typecase x @@ -39,7 +39,7 @@ (let ((op (if (listp op) (car op) op)) (spacep (if (listp op) (second op) nil))) `(define-ps-special-form ,op (x) - (list 'unary-operator ',op + (list 'js:unary-operator ',op (compile-parenscript-form x :expecting :expression) :prefix t :space ,spacep)))) ops)))) @@ -48,22 +48,22 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; statements (define-ps-special-form return (&optional value) - (list 'js-return (compile-parenscript-form value :expecting :expression))) + `(js:return ,(compile-parenscript-form value :expecting :expression))) (define-ps-special-form throw (value) - (list 'js-throw (compile-parenscript-form value :expecting :expression))) + `(js:throw ,(compile-parenscript-form value :expecting :expression))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; arrays (define-ps-special-form array (&rest values) - (cons 'array-literal (mapcar (lambda (form) (compile-parenscript-form form :expecting :expression)) + `(js:array ,@(mapcar (lambda (form) (compile-parenscript-form form :expecting :expression)) values))) (define-ps-special-form aref (array &rest coords) - (list 'js-aref (compile-parenscript-form array :expecting :expression) - (mapcar (lambda (form) - (compile-parenscript-form form :expecting :expression)) - coords))) + `(js:aref ,(compile-parenscript-form array :expecting :expression) + ,(mapcar (lambda (form) + (compile-parenscript-form form :expecting :expression)) + coords))) (defpsmacro list (&rest values) `(array ,@values)) @@ -74,47 +74,46 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; operators (define-ps-special-form incf (x &optional (delta 1)) - (if (equal delta 1) - (list 'unary-operator '++ (compile-parenscript-form x :expecting :expression) :prefix t) - (list 'operator '+= (list (compile-parenscript-form x :expecting :expression) - (compile-parenscript-form delta :expecting :expression))))) + (if (eql delta 1) + `(js:unary-operator js:++ ,(compile-parenscript-form x :expecting :expression) :prefix t) + `(js:operator js:+= ,(compile-parenscript-form x :expecting :expression) + ,(compile-parenscript-form delta :expecting :expression)))) (define-ps-special-form decf (x &optional (delta 1)) - (if (equal delta 1) - (list 'unary-operator '-- (compile-parenscript-form x :expecting :expression) :prefix t) - (list 'operator '-= (list (compile-parenscript-form x :expecting :expression) - (compile-parenscript-form delta :expecting :expression))))) + (if (eql delta 1) + `(js:unary-operator js:-- ,(compile-parenscript-form x :expecting :expression) :prefix t) + `(js:operator js:-= ,(compile-parenscript-form x :expecting :expression) + ,(compile-parenscript-form delta :expecting :expression)))) (define-ps-special-form - (first &rest rest) - (if (null rest) - (list 'unary-operator '- (compile-parenscript-form first :expecting :expression) :prefix t) - (list 'operator '- (mapcar (lambda (val) (compile-parenscript-form val :expecting :expression)) - (cons first rest))))) + (if rest + `(js:operator js:- ,@(mapcar (lambda (val) (compile-parenscript-form val :expecting :expression)) + (cons first rest))) + `(js:unary-operator js:- ,(compile-parenscript-form first :expecting :expression) :prefix t))) (define-ps-special-form not (x) (let ((form (compile-parenscript-form x :expecting :expression)) - (not-op nil)) - (if (and (eql (first form) 'operator) - (= (length (third form)) 2) - (setf not-op (case (second form) - (== '!=) - (< '>=) - (> '<=) - (<= '>) - (>= '<) - (!= '==) - (=== '!==) - (!== '===) - (t nil)))) - (list 'operator not-op (third form)) - (list 'unary-operator '! form :prefix t)))) + inverse-op) + (if (and (eq (car form) 'js:operator) + (= (length (cddr form)) 2) + (setf inverse-op (case (cadr form) + (== '!=) + (< '>=) + (> '<=) + (<= '>) + (>= '<) + (!= '==) + (=== '!==) + (!== '===)))) + `(js:operator ,inverse-op ,@(cddr form)) + `(js:unary-operator js:! ,form :prefix t)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; control structures (defun flatten-blocks (body) (when body (if (and (listp (car body)) - (eql 'js-block (caar body))) + (eq 'js:block (caar body))) (append (third (car body)) (flatten-blocks (cdr body))) (cons (car body) (flatten-blocks (cdr body)))))) @@ -122,31 +121,26 @@ (or (numberp form) (stringp form) (and (listp form) - (eql 'js-literal (car form))))) + (eq 'js:literal (car form))))) (define-ps-special-form progn (&rest body) (if (and (eq expecting :expression) (= 1 (length body))) (compile-parenscript-form (car body) :expecting :expression) - (list 'js-block - expecting - (let* ((block (mapcar (lambda (form) - (compile-parenscript-form form :expecting expecting)) - body)) - (clean-block (remove nil block)) - (flat-block (flatten-blocks clean-block)) - (reachable-block (append (remove-if #'constant-literal-form-p (butlast flat-block)) - (last flat-block)))) - reachable-block)))) + `(js:block + ,expecting + ,(let* ((block (flatten-blocks (remove nil (mapcar (lambda (form) + (compile-parenscript-form form :expecting expecting)) + body))))) + (append (remove-if #'constant-literal-form-p (butlast block)) (last block)))))) (define-ps-special-form cond (&rest clauses) (ecase expecting - (:statement (list 'js-cond-statement - (mapcar (lambda (clause) - (destructuring-bind (test &rest body) - clause - (list (compile-parenscript-form test :expecting :expression) - (compile-parenscript-form `(progn ,@body) :expecting :statement)))) - clauses))) + (:statement `(js:cond ,(mapcar (lambda (clause) + (destructuring-bind (test &rest body) + clause + (list (compile-parenscript-form test :expecting :expression) + (compile-parenscript-form `(progn ,@body) :expecting :statement)))) + clauses))) (:expression (make-cond-clauses-into-nested-ifs clauses)))) (defun make-cond-clauses-into-nested-ifs (clauses) @@ -158,7 +152,7 @@ `(js:? ,(compile-parenscript-form test :expecting :expression) ,(compile-parenscript-form `(progn ,@body) :expecting :expression) ,(make-cond-clauses-into-nested-ifs (cdr clauses))))) - (compile-parenscript-form nil :expecting :expression))) + (compile-parenscript-form nil :expecting :expression))) ;; js:null (define-ps-special-form if (test then &optional else) (ecase expecting @@ -170,18 +164,13 @@ ,(compile-parenscript-form else :expecting :expression))))) (define-ps-special-form switch (test-expr &rest clauses) - (let ((clauses (mapcar (lambda (clause) - (let ((val (car clause)) - (body (cdr clause))) - (cons (if (and (symbolp val) - (eq (ensure-ps-symbol val) 'default)) - 'default - (compile-parenscript-form val :expecting :expression)) - (mapcar (lambda (statement) (compile-parenscript-form statement :expecting :statement)) - body)))) - clauses)) - (expr (compile-parenscript-form test-expr :expecting :expression))) - (list 'js-switch expr clauses))) + `(js:switch ,(compile-parenscript-form test-expr :expecting :expression) + ,(loop for (val . body) in clauses collect + (cons (if (and (symbolp val) (eq (ensure-ps-symbol val) 'default)) + 'default + (compile-parenscript-form val :expecting :expression)) + (mapcar (lambda (x) (compile-parenscript-form x :expecting :statement)) + body))))) (defpsmacro case (value &rest clauses) (labels ((make-clause (val body more) @@ -212,14 +201,16 @@ ;; the first compilation will produce a list of variables we need to declare in the function body (compile-parenscript-form `(progn ,@body) :expecting :statement) ;; now declare and compile - (compile-parenscript-form `(progn ,@(loop for var in *enclosing-lexical-block-declarations* collect `(var ,var)) - ,@body) :expecting :statement)))) + (compile-parenscript-form `(progn + ,@(mapcar (lambda (var) `(var ,var)) *enclosing-lexical-block-declarations*) + ,@body) + :expecting :statement)))) (define-ps-special-form %js-lambda (args &rest body) - (cons 'js-lambda (compile-function-definition args body))) + `(js:lambda ,@(compile-function-definition args body))) (define-ps-special-form %js-defun (name args &rest body) - (append (list 'js-defun name) (compile-function-definition args body))) + `(js:defun ,name ,@(compile-function-definition args body))) (defun parse-function-body (body) (let* ((docstring @@ -314,7 +305,7 @@ the given lambda-list and body." (if rest? (with-ps-gensyms (i) `(progn (var ,rest (array)) - (dotimes (,i (- arguments.length ,(length effective-args))) + (dotimes (,i (- (slot-value arguments 'length) ,(length effective-args))) (setf (aref ,rest ,i) (aref arguments (+ ,i ,(length effective-args))))))) `(progn))) (body-paren-forms (parse-function-body body)) ; remove documentation @@ -429,11 +420,11 @@ lambda-list::= (cons t (lambda (x) (declare (ignore x)) expansion))))) (compile-parenscript-form `(progn ,@body)))) -(define-ps-special-form defmacro (name args &body body) +(define-ps-special-form defmacro (name args &body body) ;; should this be a macro? (eval `(defpsmacro ,name ,args ,@body)) nil) -(define-ps-special-form define-symbol-macro (name expansion) +(define-ps-special-form define-symbol-macro (name expansion) ;; should this be a macro? (eval `(define-ps-symbol-macro ,name ,expansion)) nil) @@ -443,28 +434,28 @@ lambda-list::= (define-ps-symbol-macro {} (create)) (define-ps-special-form create (&rest arrows) - (list 'js-object (loop for (key-expr val-expr) on arrows by #'cddr collecting - (let ((key (compile-parenscript-form key-expr :expecting :expression))) - (when (keywordp key) - (setf key (list 'js-variable key))) - (assert (or (stringp key) - (numberp key) - (and (listp key) - (or (eq 'js-variable (car key)) - (eq 'quote (car key))))) - () - "Slot key ~s is not one of js-variable, keyword, string or number." key) - (cons key (compile-parenscript-form val-expr :expecting :expression)))))) + `(js:object ,@(loop for (key-expr val-expr) on arrows by #'cddr collecting + (let ((key (compile-parenscript-form key-expr :expecting :expression))) + (when (keywordp key) + (setf key `(js:variable ,key))) + (assert (or (stringp key) + (numberp key) + (and (listp key) + (or (eq 'js:variable (car key)) + (eq 'quote (car key))))) + () + "Slot key ~s is not one of js-variable, keyword, string or number." key) + (cons key (compile-parenscript-form val-expr :expecting :expression)))))) (define-ps-special-form %js-slot-value (obj slot) - (list 'js-slot-value (compile-parenscript-form obj :expecting :expression) - (if (and (listp slot) (eq 'quote (car slot))) - (second slot) ;; assume we're quoting a symbol - (compile-parenscript-form slot)))) + `(js:slot-value ,(compile-parenscript-form obj :expecting :expression) + ,(if (and (listp slot) (eq 'quote (car slot))) + (second slot) ;; assume we're quoting a symbol + (compile-parenscript-form slot)))) (define-ps-special-form instanceof (value type) - (list 'js-instanceof (compile-parenscript-form value :expecting :expression) - (compile-parenscript-form type :expecting :expression))) + `(js:instanceof ,(compile-parenscript-form value :expecting :expression) + ,(compile-parenscript-form type :expecting :expression))) (defpsmacro slot-value (obj &rest slots) (if (null (rest slots)) @@ -497,21 +488,15 @@ lambda-list::= (/ '/=) (t nil))) -(defun smart-setf (lhs rhs) - (if (and (listp rhs) - (eql 'operator (car rhs)) - (member lhs (third rhs) :test #'equalp)) - (let ((args-without-first (remove lhs (third rhs) :count 1 :end 1 :test #'equalp))) - (cond ((and (assignment-op (second rhs)) - (member (second rhs) '(+ *)) - (equalp lhs (first (third rhs)))) - (list 'operator (assignment-op (second rhs)) - (list lhs (list 'operator (second rhs) args-without-first)))) - (t (list 'js-assign lhs rhs)))) - (list 'js-assign lhs rhs))) - (define-ps-special-form setf1% (lhs rhs) - (smart-setf (compile-parenscript-form lhs :expecting :expression) (compile-parenscript-form rhs :expecting :expression))) + (let ((lhs (compile-parenscript-form lhs :expecting :expression)) + (rhs (compile-parenscript-form rhs :expecting :expression))) + (if (and (listp rhs) + (eq 'js:operator (car rhs)) + (member (cadr rhs) '(+ *)) + (equalp lhs (caddr rhs))) + `(js:operator ,(assignment-op (cadr rhs)) ,lhs (js:operator ,(cadr rhs) ,@(cdddr rhs))) + `(js:= ,lhs ,rhs)))) (defpsmacro setf (&rest args) (flet ((process-setf-clause (place value-form) @@ -546,17 +531,15 @@ lambda-list::= (check-setq-args args) `(psetf ,@args)) -(define-ps-special-form var (name &rest value) - (append (list 'js-var name) - (when value - (assert (= (length value) 1) () "Wrong number of arguments to var: ~s" `(var ,name ,@value)) - (list (compile-parenscript-form (car value) :expecting :expression))))) +(define-ps-special-form var (name &optional (value (values) value-provided?) documentation) + (declare (ignore documentation)) + `(js:var ,name ,@(when value-provided? + (list (compile-parenscript-form value :expecting :expression))))) -(defpsmacro defvar (name &rest value) +(defpsmacro defvar (name &optional (value (values) value-provided?) documentation) "Note: this must be used as a top-level form, otherwise the result will be undefined behavior." (pushnew name *ps-special-variables*) - (assert (or (null value) (= (length value) 1)) () "Wrong number of arguments to defvar: ~s" `(defvar ,name ,@value)) - `(var ,name ,@value)) + `(var ,name ,@(when value-provided? (list value)))) (defun make-let-vars (bindings) (mapcar (lambda (x) (if (listp x) (car x) x)) bindings)) @@ -625,11 +608,11 @@ lambda-list::= init-forms)) (define-ps-special-form labeled-for (label init-forms cond-forms step-forms &rest body) - (let ((vars (make-for-vars/inits init-forms)) - (steps (mapcar (lambda (x) (compile-parenscript-form x :expecting :expression)) step-forms)) - (tests (mapcar (lambda (x) (compile-parenscript-form x :expecting :expression)) cond-forms)) - (body (compile-parenscript-form `(progn ,@body)))) - (list 'js-for label vars tests steps body))) + `(js:for ,label + ,(make-for-vars/inits init-forms) + ,(mapcar (lambda (x) (compile-parenscript-form x :expecting :expression)) cond-forms) + ,(mapcar (lambda (x) (compile-parenscript-form x :expecting :expression)) step-forms) + ,(compile-parenscript-form `(progn ,@body)))) (defpsmacro for (init-forms cond-forms step-forms &body body) `(labeled-for nil ,init-forms ,cond-forms ,step-forms ,@body)) @@ -687,43 +670,14 @@ lambda-list::= ,@body ,(do-make-iter-psteps decls))))) -(define-ps-special-form for-in (decl &rest body) - (list 'js-for-in - (compile-parenscript-form (first decl) :expecting :expression) - (compile-parenscript-form (second decl) :expecting :expression) - (compile-parenscript-form `(progn ,@body)))) - -(defpsmacro doeach ((var array &optional (result (values) result?)) &body body) - "Iterates over `array'. If `var' is a symbol, binds `var' to each -element key. If `var' is a list, it must be a list of two -symbols, (key value), which will be bound to each successive key/value -pair in `array'." - (if result? - (if (consp var) - (destructuring-bind (key val) var - `((lambda () - (let* (,val) - (for-in ((var ,key) ,array) - (setf ,val (aref ,array ,key)) - ,@body) - (return ,result))))) - `((lambda () - (for-in ((var ,var) ,array) - ,@body) - (return ,result)))) - (if (consp var) - (destructuring-bind (key val) var - `(progn - (let* (,val) - (for-in ((var ,key) ,array) - (setf ,val (aref ,array ,key)) - ,@body)))) - `(progn - (for-in ((var ,var) ,array) ,@body))))) +(define-ps-special-form for-in ((var object) &rest body) + `(js:for-in ,(compile-parenscript-form `(var ,var) :expecting :expression) + ,(compile-parenscript-form object :expecting :expression) + ,(compile-parenscript-form `(progn ,@body)))) (define-ps-special-form while (test &rest body) - (list 'js-while (compile-parenscript-form test :expecting :expression) - (compile-parenscript-form `(progn ,@body)))) + `(js:while ,(compile-parenscript-form test :expecting :expression) + ,(compile-parenscript-form `(progn ,@body)))) (defpsmacro dotimes ((var count &optional (result nil result?)) &rest body) `(do* ((,var 0 (1+ ,var))) @@ -744,8 +698,8 @@ pair in `array'." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; misc (define-ps-special-form with (expression &rest body) - (list 'js-with (compile-parenscript-form expression :expecting :expression) - (compile-parenscript-form `(progn ,@body)))) + `(js:with ,(compile-parenscript-form expression :expecting :expression) + ,(compile-parenscript-form `(progn ,@body)))) (define-ps-special-form try (form &rest clauses) (let ((catch (cdr (assoc :catch clauses))) @@ -753,18 +707,18 @@ pair in `array'." (assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.") (assert (or catch finally) () "Try form should have either a catch or a finally clause or both.") - (list 'js-try (compile-parenscript-form `(progn ,form)) - :catch (when catch (list (compile-parenscript-form (caar catch) :expecting :symbol) + `(js:try ,(compile-parenscript-form `(progn ,form)) + :catch ,(when catch (list (compile-parenscript-form (caar catch) :expecting :symbol) (compile-parenscript-form `(progn ,@(cdr catch))))) - :finally (when finally (compile-parenscript-form `(progn ,@finally)))))) + :finally ,(when finally (compile-parenscript-form `(progn ,@finally)))))) (define-ps-special-form cc-if (test &rest body) - (list 'cc-if test (mapcar #'compile-parenscript-form body))) + `(js:cc-if ,test ,@(mapcar #'compile-parenscript-form body))) (define-ps-special-form regex (regex) - (list 'js-regex (string regex))) + `(js:regex ,(string regex))) (define-ps-special-form lisp (lisp-form) ;; (ps (foo (lisp bar))) is in effect equivalent to (ps* `(foo ,bar)) ;; when called from inside of ps*, lisp-form has access only to the dynamic environment (like for eval) - (list 'js-escape lisp-form)) + `(js:escape ,(ps1* lisp-form))) diff --git a/src/utils.lisp b/src/utils.lisp index 897305e..4e2066a 100644 --- a/src/utils.lisp +++ b/src/utils.lisp @@ -103,4 +103,4 @@ SOMEGLOBAL." (defun flatten (x &optional acc) (cond ((null x) acc) ((atom x) (cons x acc)) - (t (flatten (car x) (flatten (cdr x) acc))))) \ No newline at end of file + (t (flatten (car x) (flatten (cdr x) acc))))) diff --git a/t/ps-tests.lisp b/t/ps-tests.lisp index 97b37dd..4e61258 100644 --- a/t/ps-tests.lisp +++ b/t/ps-tests.lisp @@ -682,10 +682,6 @@ try { (instanceof (or a b) (if x y z)) "((a || b) instanceof (x ? y : z))") -(test-ps-js op-p6 - (doeach (x (or a b))) - "for (var x in (a || b)) { };") - (test-ps-js op-p7 (or x (if (= x 0) "zero" "empty")) "x || (x == 0 ? 'zero' : 'empty')") diff --git a/t/reference-tests.lisp b/t/reference-tests.lisp index 3460390..0701942 100644 --- a/t/reference-tests.lisp +++ b/t/reference-tests.lisp @@ -507,7 +507,7 @@ alert('Sum of ' + l + ' is: ' + (function () { (test-ps-js iteration-constructs-8 (let* ((obj (create :a 1 :b 2 :c 3))) - (doeach (i obj) + (for-in (i obj) (document.write (+ i ": " (aref obj i) "
")))) "var obj = { a : 1, b : 2, c : 3 }; for (var i in obj) { @@ -515,17 +515,6 @@ for (var i in obj) { };") (test-ps-js iteration-constructs-9 - (let* ((obj (create :a 1 :b 2 :c 3))) - (doeach ((k v) obj) - (document.write (+ k ": " v "
")))) - "var obj = { a : 1, b : 2, c : 3 }; -var v; -for (var k in obj) { - v = obj[k]; - document.write(k + ': ' + v + '
'); -};") - -(test-ps-js iteration-constructs-10 (while (film.is-not-finished) (this.eat (new *popcorn))) "while (film.isNotFinished()) { -- 2.20.1