Commit 3bbf7c27 authored by Daniel Gackle's avatar Daniel Gackle

Minor refactoring; comments.

parent 16144f60
......@@ -54,14 +54,14 @@ Syntax of key spec:
(mapcar (lambda (opt-spec)
(multiple-value-bind (name value suppl)
(parse-optional-spec opt-spec)
(if suppl
(var ,suppl (not (eql ,name undefined)))
,@(when value
`((when (not ,suppl) (setf ,name ,value)))))
(when value
`(when (eql ,name undefined)
(setf ,name ,value))))))
(cond (suppl
(var ,suppl (not (eql ,name undefined)))
,@(when value
`((when (not ,suppl) (setf ,name ,value))))))
`(when (eql ,name undefined)
(setf ,name ,value))))))
(when keys?
......@@ -105,7 +105,7 @@ Syntax of key spec:
(defun collapse-function-return-blocks (body)
(append (butlast body)
(let ((last (ps-macroexpand (car (last body)))))
(if (and (listp last) (eq 'block (car last)))
(if (and (listp last) (eq 'block (car last))) ; no need for a block at the end of a function body
(progn (push (or (second last) 'nilBlock) *function-block-names*)
(cddr last))
(list last)))))
......@@ -202,7 +202,7 @@ Syntax of key spec:
,@(compile-progn body)))
(ps-compile (with-lambda-scope `(,',special-op ,fn-defs ,@body)))))
(defun compile-local-function-body (fn-defs renames)
(defun compile-local-function-defs (fn-defs renames)
(loop for (fn-name . (args . body)) in fn-defs collect
(progn (when compile-expression?
(push (getf renames fn-name)
......@@ -215,7 +215,7 @@ Syntax of key spec:
(local-functions flet
;; the function definitions need to be compiled with previous
;; lexical bindings
(definitions (compile-local-function-body fn-defs fn-renames))
(definitions (compile-local-function-defs fn-defs fn-renames))
;; the flet body needs to be compiled with the extended
;; lexical environment
(*enclosing-lexicals* (append fn-renames *enclosing-lexicals*))
......@@ -229,7 +229,7 @@ Syntax of key spec:
(*loop-scope-lexicals* (when in-loop-scope?
(append fn-renames *loop-scope-lexicals*)))
(*local-function-names* (append fn-renames *local-function-names*))
(definitions (compile-local-function-body fn-defs *local-function-names*))))
(definitions (compile-local-function-defs fn-defs *local-function-names*))))
(define-expression-operator function (fn-name)
;; one of the things responsible for function namespace
......@@ -11,8 +11,8 @@
(defun property-bindings-p (x)
(when (consp x)
(every (lambda (y)
(or (keywordp y)
(and (consp y)
(or (keywordp y) ; standalone property name
(and (consp y) ; var name paired with property name
(= (length y) 2)
(symbolp (car y))
(not (keywordp (car y)))
......@@ -27,32 +27,33 @@
(list var (list x var))))
(t (loop :for y :on x
:for (d p) = (extract-bindings (car y))
:append (list d) :into ds
:collect d :into ds
:when p :append p :into ps
:finally (return (list ds ps))))))
(defun property-bindings (bindings expr body)
`(let ,(loop :for b :in bindings
:for (var p) = (if (consp b) b (list (intern (string b)) b))
:for (var p) = (cond ((consp b) b) ; var name paired with property name
(t (list (intern (string b)) b))) ; make var from prop
:collect `(,var (@ ,expr ,p)))
(defpsmacro bind (bindings expr &body body)
(setf bindings (dot->rest bindings))
(destructuring-bind (d p)
(extract-bindings bindings)
(cond ((and (atom d)
(or (= (length bindings) 1)
(atom expr)
(atom (ps-macroexpand expr))))
(property-bindings bindings expr body))
((atom d)
(with-ps-gensyms (var)
`(let ((,var ,expr))
(bind ,bindings ,var ,@body))))
((null p) `(destructuring-bind ,bindings ,expr ,@body))
(t `(destructuring-bind ,d ,expr
(bind* ,p ,@body))))))
(let ((bindings (dot->rest bindings)))
(destructuring-bind (d p)
(extract-bindings bindings)
(cond ((and (atom d)
(or (= (length bindings) 1)
(atom (ps-macroexpand expr))))
(property-bindings bindings expr body))
((atom d)
(with-ps-gensyms (var)
`(let ((,var ,expr))
(bind ,bindings ,var ,@body))))
((null p)
`(destructuring-bind ,bindings ,expr ,@body))
(t `(destructuring-bind ,d ,expr
(bind* ,p ,@body)))))))
(defpsmacro bind* (bindings &body body)
(cond ((= (length bindings) 2)
......@@ -106,6 +107,7 @@
(car (tokens state)))
(defun eat (state &optional what tag)
"Consumes the next meaningful chunk of loop for processing."
(case what
(:if (when (eq (as-keyword (peek state)) tag)
(eat state)
......@@ -230,7 +232,7 @@
(:count `(when ,item (incf ,var))) ;; note the JS semantics - neither 0 nor "" will count
(:minimize `(setf ,var (if (null ,var) ,item (min ,var ,item))))
(:maximize `(setf ,var (if (null ,var) ,item (max ,var ,item))))
(:collect `((@ ,var :push) ,item))
(:collect `((@ ,var 'push) ,item))
(:append `(setf ,var (append ,var ,item)))
(:map (destructuring-bind (key val) item
`(setf (getprop ,var ,key) ,val)))))
......@@ -314,8 +316,8 @@
(assert (not (or init step js-obj)) nil "Invalid iteration ~a: PLACE should not be null." clause)
(assert test nil "Iteration ~a has neither PLACE nor TEST." clause)
(unless (sixth (car folded)) ;; js-obj means a loop and those can't have tests
(let ((test^ (fifth (car folded))))
(setf (fifth (car folded)) (if test^ `(and ,test^ ,test) test))
(let ((prev-test (fifth (car folded))))
(setf (fifth (car folded)) (if prev-test `(and ,prev-test ,test) test))
(setf folded? t))))))
(unless folded?
(push clause folded))))
......@@ -315,20 +315,11 @@ lambda-list::=
;;; iteration
(defun do-make-let-bindings (decls)
(defun do-make-iteration-bindings (decls)
(mapcar (lambda (x)
(if (atom x)
(if (endp (cdr x))
(list (car x))
(subseq x 0 2))))
(defun do-make-for-vars/init (decls)
(mapcar (lambda (x)
(if (atom x) x
(if (endp (cdr x)) x
(subseq x 0 2))))
(cond ((atom x) x)
((endp (cdr x)) (list (car x)))
(t (subseq x 0 2))))
(defun do-make-for-steps (decls)
......@@ -346,18 +337,18 @@ lambda-list::=
(or (atom x) (< (length x) 3)))
(defpsmacro do* (decls (termination &optional (result nil result?)) &body body)
(defpsmacro do* (decls (end-test &optional (result nil result?)) &body body)
`(block nil
(for ,(do-make-for-vars/init decls)
((not ,termination))
(for ,(do-make-iteration-bindings decls)
((not ,end-test))
,(do-make-for-steps decls)
,@(when result? (list result))))
(defpsmacro do (decls (termination &optional (result nil result?)) &body body)
(defpsmacro do (decls (end-test &optional (result nil result?)) &body body)
`(block nil
(let ,(do-make-let-bindings decls)
(for () ((not ,termination)) ()
(let ,(do-make-iteration-bindings decls)
(for () ((not ,end-test)) ()
,(do-make-iter-psteps decls))
,@(when result? (list result)))))
......@@ -186,7 +186,7 @@
(defpsmacro stringify (&rest things)
(if (and (= (length things) 1) (stringp (car things)))
(car things)
`((@ (list ,@things) :join) "")))
`((@ (list ,@things) join) "")))
(defun stringify (&rest things)
"Like concatenate but prints all of its arguments."
(format nil "~{~A~}" things))
......@@ -342,20 +342,20 @@ vice-versa.")
(defprinter ps-js:switch (test &rest clauses)
"switch ("(ps-print test)") {"
(flet ((print-body-statements (body-statements)
(flet ((print-body (body)
(incf *indent-level*)
(loop for statement in body-statements do
(progn (newline-and-indent)
(ps-print statement)
(psw #\;)))
(loop for statement in body do
(ps-print statement)
(psw #\;))
(decf *indent-level*)))
(loop for (val . statements) in clauses
do (progn (newline-and-indent)
(if (eq val 'ps-js:default)
(progn (psw "default:")
(print-body-statements statements))
(progn (psw "case ") (ps-print val) (psw #\:)
(print-body-statements statements))))))
(loop for (val . statements) in clauses do
(if (eq val 'ps-js:default)
(progn (psw "default:")
(print-body statements))
(progn (psw "case ") (ps-print val) (psw #\:)
(print-body statements)))))
......@@ -97,9 +97,9 @@
(ps-js:> ps-js:<=)))))
(define-expression-operator not (x)
(let ((form (compile-expression x)))
(acond ((and (listp form) (eq (car form) 'ps-js:!))
(acond ((and (listp form) (eq (car form) 'ps-js:!)) ;; not not → identity
(second form))
((and (listp form) (cadr (assoc (car form) inverses)))
((and (listp form) (cadr (assoc (car form) inverses))) ;; not equal → !=
`(,it ,@(cdr form)))
(t `(ps-js:! ,form))))))
......@@ -182,12 +182,12 @@
(fill-mv ()
(list (fill-mv-reg `(list ,@rest-values)))))
(fill-mv-reg `(list ,@rest-values))))
(acond ((eql tag *current-block-tag*)
(if value?
`(progn ,value
,@(when rest-values (fill-mv))
,@(when rest-values (list (fill-mv)))
(break ,tag))
`(break ,tag))))
((or (eql '%function tag)
......@@ -200,7 +200,7 @@
(let ((suppress-values? nil))
`(let ,(when val1 `((,val1 ,value)))
(return-from ,tag ,(or val1 value))))))
((assoc tag *dynamic-return-tags*)
......@@ -572,7 +572,7 @@ Parenscript now implements implicit return, update your code! Things like (lambd
;;; evalutation
;;; evaluation
(define-expression-operator quote (x)
(flet ((quote% (expr) (when expr `',expr)))
......@@ -767,7 +767,7 @@ for (var _js1 = 0; _js1 < _js2; _js1 += 1) {
var collect3 = [];
for (var _js1 = 0; _js1 < _js2; _js1 += 1) {
var a = b[_js1];
return collect3;
......@@ -832,13 +832,13 @@ for (var _js1 = 0; _js1 < _js2; _js1 += 1) {
(test-ps-js the-html-generator-2
(ps-html ((:a :href (generate-a-link)) "blorg"))
"['<A HREF=\"', generateALink(), '\">blorg</A>']['join']('');")
"['<A HREF=\"', generateALink(), '\">blorg</A>'].join('');")
(test-ps-js the-html-generator-3
(funcall (getprop document 'write)
(ps-html ((:a :href "#"
:onclick (ps-inline (transport))) "link")))
"document.write(['<A HREF=\"#\" ONCLICK=\"', 'javascript:' + 'transport()', '\">link</A>']['join'](''));")
"document.write(['<A HREF=\"#\" ONCLICK=\"', 'javascript:' + 'transport()', '\">link</A>'].join(''));")
(test-ps-js the-html-generator-4
(let ((disabled nil)
......@@ -849,7 +849,7 @@ for (var _js1 = 0; _js1 < _js2; _js1 += 1) {
"(function () {
var disabled = null;
var authorized = true;
return element.innerHTML = ['<TEXTAREA', disabled || !authorized ? [' DISABLED=\"', 'disabled', '\"']['join']('') : '', '>Edit me</TEXTAREA>']['join']('');
return element.innerHTML = ['<TEXTAREA', disabled || !authorized ? [' DISABLED=\"', 'disabled', '\"'].join('') : '', '>Edit me</TEXTAREA>'].join('');
(test-ps-js plus-is-not-commutative
......@@ -1395,7 +1395,7 @@ __setf_someThing('foo', 1, 2);")
:onclick (ps-inline (transport)))
"document.write(LINKORNOT === 1 ? ['<A HREF=\"#\" ONCLICK=\"', 'javascript:' + 'transport()', '\">', img, '</A>']['join']('') : img);")
"document.write(LINKORNOT === 1 ? ['<A HREF=\"#\" ONCLICK=\"', 'javascript:' + 'transport()', '\">', img, '</A>'].join('') : img);")
(test-ps-js negate-number-literal
(- 1)
......@@ -1616,7 +1616,7 @@ __setf_someThing('foo', 1, 2);")
(:a :href ""
(:span :class "ticker-symbol-popup")))
"['<SPAN CLASS=\"ticker-symbol\" TICKER-SYMBOL=\"', symbol, '\"><A HREF=\"\">', symbol, '</A><SPAN CLASS=\"ticker-symbol-popup\"></SPAN></SPAN>']['join']('');")
"['<SPAN CLASS=\"ticker-symbol\" TICKER-SYMBOL=\"', symbol, '\"><A HREF=\"\">', symbol, '</A><SPAN CLASS=\"ticker-symbol-popup\"></SPAN></SPAN>'].join('');")
(test-ps-js who-html2
(who-ps-html (:p "t0" (:span "t1")))
Markdown is supported
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment