X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=46b92932bca175ecddedabad07b1eb37f57dfad3;hb=ea250a1c0f5e0bc48a43fba2cdcaea1a7932cf0f;hp=12ee19d8b342ef372d1441869bf280d1a0666c60;hpb=cfaa37082d44f5e34c7a92623320a30096fb063b;p=jscl.git diff --git a/ecmalisp.lisp b/ecmalisp.lisp index 12ee19d..46b9293 100644 --- a/ecmalisp.lisp +++ b/ecmalisp.lisp @@ -1228,45 +1228,46 @@ (define-compilation progn (&rest body) (js!selfcall (ls-compile-block body t))) -(defun dynamic-binding-wrapper (bindings body) - (if (null bindings) - body - (concat - "try {" *newline* - (indent - "var tmp;" *newline* - (join - (mapcar (lambda (b) - (let ((s (ls-compile `(quote ,(car b))))) - (concat "tmp = " s ".value;" *newline* - s ".value = " (cdr b) ";" *newline* - (cdr b) " = tmp;" *newline*))) - bindings)) - body) - "}" *newline* - "finally {" *newline* - (indent - (join-trailing - (mapcar (lambda (b) - (let ((s (ls-compile `(quote ,(car b))))) - (concat s ".value" " = " (cdr b)))) - bindings) - (concat ";" *newline*))) - "}" *newline*))) - +(defun special-variable-p (x) + (claimp x 'variable 'special)) + +;;; Wrap CODE to restore the symbol values of the dynamic +;;; bindings. BINDINGS is a list of pairs of the form +;;; (SYMBOL . PLACE), where PLACE is a Javascript variable +;;; name to initialize the symbol value and where to stored +;;; the old value. +(defun let-binding-wrapper (bindings body) + (when (null bindings) + (return-from let-binding-wrapper body)) + (concat + "try {" *newline* + (indent "var tmp;" *newline* + (mapconcat + (lambda (b) + (let ((s (ls-compile `(quote ,(car b))))) + (concat "tmp = " s ".value;" *newline* + s ".value = " (cdr b) ";" *newline* + (cdr b) " = tmp;" *newline*))) + bindings) + body *newline*) + "}" *newline* + "finally {" *newline* + (indent + (mapconcat (lambda (b) + (let ((s (ls-compile `(quote ,(car b))))) + (concat s ".value" " = " (cdr b) ";" *newline*))) + bindings)) + "}" *newline*)) (define-compilation let (bindings &rest body) (let ((bindings (mapcar #'ensure-list bindings))) - (let ((variables (mapcar #'first bindings)) - (values (mapcar #'second bindings))) - (let ((cvalues (mapcar #'ls-compile values)) - (*environment* - (extend-local-env (remove-if (lambda (v)(claimp v 'variable 'special)) - variables))) + (let ((variables (mapcar #'first bindings))) + (let ((cvalues (mapcar #'ls-compile (mapcar #'second bindings))) + (*environment* (extend-local-env (remove-if #'special-variable-p variables))) (dynamic-bindings)) (concat "(function(" (join (mapcar (lambda (x) - (if (claimp x 'variable 'special) + (if (special-variable-p x) (let ((v (gvarname x))) (push (cons x v) dynamic-bindings) v) @@ -1275,10 +1276,58 @@ ",") "){" *newline* (let ((body (ls-compile-block body t))) - (indent (dynamic-binding-wrapper dynamic-bindings body))) + (indent (let-binding-wrapper dynamic-bindings body))) "})(" (join cvalues ",") ")"))))) +;;; Return the code to initialize BINDING, and push it extending the +;;; current lexical environment if the variable is special. +(defun let*-initialize-value (binding) + (let ((var (first binding)) + (value (second binding))) + (if (special-variable-p var) + (concat (ls-compile `(setq ,var ,value)) ";" *newline*) + (let ((v (gvarname var))) + (let ((b (make-binding var 'variable v))) + (prog1 (concat "var " v " = " (ls-compile value) ";" *newline*) + (push-to-lexenv b *environment* 'variable))))))) + +;;; Wrap BODY to restore the symbol values of SYMBOLS after body. It +;;; DOES NOT generate code to initialize the value of the symbols, +;;; unlike let-binding-wrapper. +(defun let*-binding-wrapper (symbols body) + (when (null symbols) + (return-from let*-binding-wrapper body)) + (let ((store (mapcar (lambda (s) (cons s (gvarname s))) + (remove-if-not #'special-variable-p symbols)))) + (concat + "try {" *newline* + (indent + (mapconcat (lambda (b) + (let ((s (ls-compile `(quote ,(car b))))) + (concat "var " (cdr b) " = " s ".value;" *newline*))) + store) + body) + "}" *newline* + "finally {" *newline* + (indent + (mapconcat (lambda (b) + (let ((s (ls-compile `(quote ,(car b))))) + (concat s ".value" " = " (cdr b) ";" *newline*))) + store)) + "}" *newline*))) + + +(define-compilation let* (bindings &rest body) + (let ((bindings (mapcar #'ensure-list bindings)) + (*environment* (copy-lexenv *environment*))) + (js!selfcall + (let ((specials (remove-if-not #'special-variable-p (mapcar #'first bindings))) + (body (concat (mapconcat #'let*-initialize-value bindings) + (ls-compile-block body t)))) + (let*-binding-wrapper specials body))))) + + (defvar *block-counter* 0) (define-compilation block (name &rest body) @@ -1723,9 +1772,10 @@ ((symbolp sexp) (let ((b (lookup-in-lexenv sexp *environment* 'variable))) (cond - ((eq (binding-type b) 'lexical-variable) + ((and b (not (member 'special (binding-declarations b)))) (binding-value b)) - ((or (keywordp sexp) (claimp sexp 'variable 'constant)) + ((or (keywordp sexp) + (member 'constant (binding-declarations b))) (concat (ls-compile `',sexp) ".value")) (t (ls-compile `(symbol-value ',sexp)))))) @@ -1784,26 +1834,23 @@ (ls-compile-toplevel x)))) (js-eval code))) - (export '(* *gensym-counter* *package* + - / 1+ 1- < <= = = > >= and append - apply assoc atom block boundp boundp butlast caar cadddr - caddr cadr car car case catch cdar cdddr cddr cdr cdr char - char-code char= code-char cond cons consp copy-list decf - declaim defparameter defun defvar digit-char-p disassemble - documentation dolist dotimes ecase eq eql equal error eval - every export fdefinition find-package find-symbol first - fourth fset funcall function functionp gensym go identity - in-package incf integerp integerp intern keywordp - lambda-code last length let list-all-packages list listp - make-package make-symbol mapcar member minusp mod nil not - nth nthcdr null numberp or package-name package-use-list - packagep plusp prin1-to-string print proclaim prog1 prog2 - pron push quote remove remove-if remove-if-not return - return-from revappend reverse second set setq some - string-upcase string string= stringp subseq - symbol-function symbol-name symbol-package symbol-plist - symbol-value symbolp t tagbody third throw truncate unless - unwind-protect variable warn when write-line write-string - zerop)) + (export '(&rest &optional &body * *gensym-counter* *package* + - / 1+ 1- < <= = += > >= and append apply assoc atom block boundp boundp butlast caar +cadddr caddr cadr car car case catch cdar cdddr cddr cdr cdr char +char-code char= code-char cond cons consp copy-list decf declaim +defparameter defun defvar digit-char-p disassemble documentation +dolist dotimes ecase eq eql equal error eval every export fdefinition +find-package find-symbol first fourth fset funcall function functionp +gensym go identity if in-package incf integerp integerp intern +keywordp lambda last length let let* list-all-packages list listp +make-package make-symbol mapcar member minusp mod nil not nth nthcdr +null numberp or package-name package-use-list packagep plusp +prin1-to-string print proclaim prog1 prog2 pron push quote remove +remove-if remove-if-not return return-from revappend reverse second +set setq some string-upcase string string= stringp subseq +symbol-function symbol-name symbol-package symbol-plist symbol-value +symbolp t tagbody third throw truncate unless unwind-protect variable +warn when write-line write-string zerop)) (setq *package* *user-package*)