From a0efe39fc620733fd24cba68c98b41f0d27c7bf0 Mon Sep 17 00:00:00 2001 From: Vladimir Sedach Date: Mon, 4 Jan 2010 18:43:54 -0500 Subject: [PATCH] Made FLET and LABELS not gensym new names when it's not necessary. --- src/compiler.lisp | 9 ++---- src/special-forms.lisp | 68 ++++++++++++++++++++++++---------------- t/ps-tests.lisp | 84 ++++++++++++++++++++++++++++++++------------------ 3 files changed, 97 insertions(+), 64 deletions(-) diff --git a/src/compiler.lisp b/src/compiler.lisp index ff59786..5e948dd 100644 --- a/src/compiler.lisp +++ b/src/compiler.lisp @@ -88,7 +88,8 @@ lexical block.") (defvar *ps-symbol-macro-env* (list *ps-symbol-macro-toplevel*)) -(defvar *ps-local-function-names* ()) +(defvar *ps-local-function-names* ()) ;; contains a subset of +(defvar *ps-enclosing-lexicals* ()) (defvar *ps-setf-expanders* (make-macro-dictionary) "Setf expander dictionary. Key is the symbol of the access @@ -149,11 +150,6 @@ CL environment)." (values (ps-macroexpand (funcall it form)) t) form)) -(defun maybe-rename-local-function (fun-name) - (aif (lookup-macro-def fun-name *ps-local-function-names*) - it - fun-name)) - ;;;; compiler interface (defun adjust-ps-compilation-level (form level) "Given the current *ps-compilation-level*, LEVEL, and the fully macroexpanded @@ -164,7 +160,6 @@ form, FORM, returns the new value for *ps-compilation-level*." level) ((eq :toplevel level) :inside-toplevel-form))) - (defun ps-compile-symbol (form) "Compiles the given Parenscript form and guarantees that the resultant symbol has an associated script-package. Raises an error if diff --git a/src/special-forms.lisp b/src/special-forms.lisp index 7ce0678..749e88e 100644 --- a/src/special-forms.lisp +++ b/src/special-forms.lisp @@ -312,8 +312,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; function definition -(defvar *vars-bound-in-enclosing-lexical-scopes* ()) - (defun add-implicit-return (fbody) (let ((last-thing (car (last fbody)))) (if (ps-statement? last-thing) @@ -324,10 +322,9 @@ (defun compile-function-definition (args body) (let ((args (mapcar #'ps-compile-symbol args))) (list args - (let* ((*enclosing-lexical-block-declarations* - ()) - (*vars-bound-in-enclosing-lexical-scopes* - (append args *vars-bound-in-enclosing-lexical-scopes*)) + (let* ((*enclosing-lexical-block-declarations* ()) + (*ps-enclosing-lexicals* + (append args *ps-enclosing-lexicals*)) (body (ps-compile-statement `(progn ,@(add-implicit-return body)))) (var-decls @@ -510,25 +507,41 @@ lambda-list::= `(%js-lambda ,effective-args ,@effective-body))) +(defun maybe-rename-local-function (fun-name) + (aif (getf *ps-local-function-names* fun-name) + it + fun-name)) + +(defun collect-function-names (fn-defs) + (loop for (fn-name) in fn-defs + collect fn-name + collect (if (member fn-name *ps-enclosing-lexicals*) + (ps-gensym fn-name) + fn-name))) + (define-ps-special-form flet (fn-defs &rest body) - (let ((fn-renames (make-macro-dictionary))) - (loop for (fn-name) in fn-defs do - (setf (gethash fn-name fn-renames) (ps-gensym fn-name))) - (let ((fn-defs (loop for (fn-name . def) in fn-defs collect - (ps-compile `(var ,(gethash fn-name fn-renames) - (lambda ,@def))))) - (*ps-local-function-names* - (cons fn-renames *ps-local-function-names*))) - `(,(if compile-expression? 'js:|,| 'js:block) - ,@fn-defs ,@(flatten-blocks (mapcar #'ps-compile body)))))) + (let* ((fn-renames (collect-function-names fn-defs)) + (fn-defs (loop for (fn-name . def) in fn-defs collect + (ps-compile `(var ,(getf fn-renames fn-name) + (lambda ,@def))))) + (*ps-enclosing-lexicals* + (append fn-renames *ps-enclosing-lexicals*)) + (*ps-local-function-names* + (append fn-renames *ps-local-function-names*))) + `(,(if compile-expression? 'js:|,| 'js:block) + ,@fn-defs + ,@(flatten-blocks (mapcar #'ps-compile body))))) (define-ps-special-form labels (fn-defs &rest body) - (with-local-macro-environment (local-fn-renames *ps-local-function-names*) - (loop for (fn-name) in fn-defs do - (setf (gethash fn-name local-fn-renames) (ps-gensym fn-name))) + (let* ((fn-renames (collect-function-names fn-defs)) + (*ps-local-function-names* + (append fn-renames *ps-local-function-names*)) + (*ps-enclosing-lexicals* + (append fn-renames *ps-enclosing-lexicals*))) (ps-compile `(progn ,@(loop for (fn-name . def) in fn-defs collect - `(var ,(gethash fn-name local-fn-renames) (lambda ,@def))) + `(var ,(getf *ps-local-function-names* fn-name) + (lambda ,@def))) ,@body)))) (define-ps-special-form function (fn-name) @@ -604,16 +617,16 @@ lambda-list::= (declare (ignore x)) expansion)) (push name local-var-bindings))) - (let ((*vars-bound-in-enclosing-lexical-scopes* + (let ((*ps-enclosing-lexicals* (append local-var-bindings - *vars-bound-in-enclosing-lexical-scopes*))) + *ps-enclosing-lexicals*))) (ps-compile `(progn ,@body)))))) -(define-ps-special-form defmacro (name args &body body) ;; should this be a macro? +(define-ps-special-form defmacro (name args &body body) (eval `(defpsmacro ,name ,args ,@body)) nil) -(define-ps-special-form define-symbol-macro (name expansion) ;; should this be a macro? +(define-ps-special-form define-symbol-macro (name expansion) (eval `(define-ps-symbol-macro ,name ,expansion)) nil) @@ -747,7 +760,7 @@ lambda-list::= (free-variables-in-binding-value-expressions (mapcan (lambda (x) (flatten (cadr x))) normalized-bindings))) (flet ((maybe-rename-lexical-var (x) - (if (or (member x *vars-bound-in-enclosing-lexical-scopes*) + (if (or (member x *ps-enclosing-lexicals*) (member x free-variables-in-binding-value-expressions)) (ps-gensym x) (progn (push x lexical-bindings-introduced-here) nil))) @@ -764,8 +777,9 @@ lambda-list::= when (rename x) collect `(,(var x) ,(rename x))) ,@body)) - (*vars-bound-in-enclosing-lexical-scopes* (append lexical-bindings-introduced-here - *vars-bound-in-enclosing-lexical-scopes*))) + (*ps-enclosing-lexicals* + (append lexical-bindings-introduced-here + *ps-enclosing-lexicals*))) (ps-compile `(progn ,@(mapcar (lambda (x) `(var ,(or (rename x) (var x)) ,(val x))) lexical-bindings) diff --git a/t/ps-tests.lisp b/t/ps-tests.lisp index baeb0a4..6a7a8f6 100644 --- a/t/ps-tests.lisp +++ b/t/ps-tests.lisp @@ -782,35 +782,39 @@ try { (1+ x))) (return (foo 1))))) "(function () { - var foo1 = function (x) { + var foo = function (x) { return x + 1; }; - return foo1(1); + return foo(1); })();") (test-ps-js flet2 (flet ((foo (x) (return (1+ x))) (bar (y) (return (+ 2 y)))) (bar (foo 1))) -"var foo1 = function (x) { +"var foo = function (x) { return x + 1; }; -var bar2 = function (y) { +var bar = function (y) { return 2 + y; }; -bar2(foo1(1));") +bar(foo(1));") (test-ps-js flet3 - (flet ((foo (x) (return (1+ x))) - (bar (y) (return (+ 2 (foo y))))) - (bar (foo 1))) - "var foo1 = function (x) { + (flet ((foo (x) (+ 2 x))) + (flet ((foo (x) (1+ x)) + (bar (y) (+ 2 (foo y)))) + (bar (foo 1)))) + "var foo = function (x) { + return 2 + x; +}; +var foo1 = function (x) { return x + 1; }; -var bar2 = function (y) { +var bar = function (y) { return 2 + foo(y); }; -bar2(foo1(1));") +bar(foo1(1));") (test-ps-js labels1 ((lambda () (labels ((foo (x) @@ -819,39 +823,39 @@ bar2(foo1(1));") (+ x (foo (1- x)))))) (foo 3)))) "(function () { - var foo1 = function (x) { + var foo = function (x) { if (0 === x) { return 0; } else { - return x + foo1(x - 1); + return x + foo(x - 1); }; }; - return foo1(3); + return foo(3); })();") (test-ps-js labels2 (labels ((foo (x) (return (1+ (bar x)))) (bar (y) (return (+ 2 (foo y))))) (bar (foo 1))) - "var foo1 = function (x) { - return bar2(x) + 1; + "var foo = function (x) { + return bar(x) + 1; }; -var bar2 = function (y) { - return 2 + foo1(y); +var bar = function (y) { + return 2 + foo(y); }; -bar2(foo1(1));") +bar(foo(1));") (test-ps-js labels3 (labels ((foo (x) (return (1+ x))) (bar (y) (return (+ 2 (foo y))))) (bar (foo 1))) - "var foo1 = function (x) { + "var foo = function (x) { return x + 1; }; -var bar2 = function (y) { - return 2 + foo1(y); +var bar = function (y) { + return 2 + foo(y); }; -bar2(foo1(1));") +bar(foo(1));") (test-ps-js for-loop-var-init-exp ((lambda (x) @@ -1112,10 +1116,10 @@ x + x;") (test-ps-js flet-apply (flet ((foo () 'bar)) (apply (function foo) nil)) - "var foo1 = function () { + "var foo = function () { return 'bar'; }; -foo1.apply(this, null);") +foo.apply(this, null);") (test-ps-js let-apply (let ((foo (lambda () (return 1)))) @@ -1133,11 +1137,11 @@ foo1.apply(this, null);") (flet ((x (x) (return (1+ x)))) (let ((x 2)) (x x))) - "var x1 = function (x) { + "var x = function (x) { return x + 1; }; -var x = 2; -x1(x);") +var x1 = 2; +x(x1);") (test-ps-js let-flet (let ((x 2)) @@ -1149,6 +1153,26 @@ var x1 = function (x) { }; x1(x);") +(test-ps-js labels-let + (labels ((x (x) (return (1+ x)))) + (let ((x 2)) + (x x))) + "var x = function (x) { + return x + 1; +}; +var x1 = 2; +x(x1);") + +(test-ps-js let-labels + (let ((x 2)) + (labels ((x (x) (return (1+ x)))) + (x x))) + "var x = 2; +var x1 = function (x) { + return x + 1; +}; +x1(x);") + (test-ps-js macrolet-let-inteference (macrolet ((a (n) `(+ ,n 5))) (let ((a (a 1))) @@ -1245,9 +1269,9 @@ x1 - x1; (test-ps-js flet-expression (1+ (flet ((foo (x) (1+ x))) (foo 1))) - "(foo1 = function (x) { + "(foo = function (x) { return x + 1; -}, foo1(1)) + 1;") +}, foo(1)) + 1;") (test-ps-js return-case-break-elimination (return (case 1 -- 2.11.4.GIT