X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=244d07cb45075cb50a4bff28a2ef92bdabedda53;hb=ada1317b0077e7caaf3e410fba76b4936202da65;hp=bf96d3f65a645f56ae6392c0453da0c9b997a1fe;hpb=529bff356c5b4de5f403a300610eafe05db631c1;p=jscl.git diff --git a/ecmalisp.lisp b/ecmalisp.lisp index bf96d3f..244d07c 100644 --- a/ecmalisp.lisp +++ b/ecmalisp.lisp @@ -1228,48 +1228,46 @@ (define-compilation progn (&rest body) (js!selfcall (ls-compile-block body t))) - -(defun restoring-dynamic-binding (bindings body) +(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 body) + (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 - (join-trailing (mapcar (lambda (b) - (let ((s (ls-compile `(quote ,(car b))))) - (concat s ".value" " = " (cdr b)))) - bindings) - (concat ";" *newline*))) + (mapconcat (lambda (b) + (let ((s (ls-compile `(quote ,(car b))))) + (concat s ".value" " = " (cdr b) ";" *newline*))) + bindings)) "}" *newline*)) -(defun dynamic-binding-wrapper (bindings body) - (if (null bindings) - body - (restoring-dynamic-binding - bindings - (concat "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*)))) - (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) @@ -1278,31 +1276,56 @@ ",") "){" *newline* (let ((body (ls-compile-block body t))) - (indent (dynamic-binding-wrapper dynamic-bindings body))) + (indent (let-binding-wrapper dynamic-bindings body))) "})(" (join cvalues ",") ")"))))) -(defun let*-initialize (x) - (let ((var (first x)) - (value (second x))) - (if (claimp var 'variable 'special) - (ls-compile `(setq ,var ,value)) +;;; 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 ((body - (concat (mapconcat #'let*-initialize bindings) - (ls-compile-block body t)))) - (if (some (lambda (b) (claimp (car b) 'variable 'special)) bindings) - (restoring-dynamic-binding bindings body) - body))))) - + (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) @@ -1515,10 +1538,19 @@ (type-check (("x" "number" x) ("y" "number" y)) (concat "x" op "y"))) -(define-builtin + (x y) (num-op-num x "+" y)) -(define-builtin - (x y) (num-op-num x "-" y)) -(define-builtin * (x y) (num-op-num x "*" y)) -(define-builtin / (x y) (num-op-num x "/" y)) +(defmacro define-builtin-arithmetic (op) +`(define-raw-builtin ,op (&rest args) + (if args + (let ((res (ls-compile (car args)))) + (dolist (x (cdr args)) + (setq res (num-op-num res ,(symbol-name op) (ls-compile x)))) + res) + "0"))) + +(define-builtin-arithmetic +) +(define-builtin-arithmetic -) +(define-builtin-arithmetic *) +(define-builtin-arithmetic /) (define-builtin mod (x y) (num-op-num x "%" y)) @@ -1811,26 +1843,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 - if in-package incf integerp integerp intern keywordp - lambda 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*)