X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler.lisp;h=45be8b3f9a4b76a83b3efa0ec81ce8464a0a60db;hb=da4ada5f21ad89eaab129a60f579a746200bd308;hp=09abdebd9ed8a9c6c22893bf0a21512f5e4cf1a9;hpb=99252fafa2c1bd2933787ca25cc16f5fd19364eb;p=jscl.git diff --git a/src/compiler.lisp b/src/compiler.lisp index 09abdeb..45be8b3 100644 --- a/src/compiler.lisp +++ b/src/compiler.lisp @@ -60,6 +60,10 @@ (defmacro js!selfcall (&body body) ``(call (function nil (code ,,@body)))) +(defmacro js!selfcall* (&body body) + ``(call (function nil ,,@body))) + + ;;; Like CODE, but prefix each line with four spaces. Two versions ;;; of this function are available, because the Ecmalisp version is ;;; very slow and bootstraping was annoying. @@ -190,10 +194,9 @@ *compilations*)) (define-compilation if (condition true &optional false) - `(code "(" ,(ls-compile condition) " !== " ,(ls-compile nil) - " ? " ,(ls-compile true *multiple-value-p*) - " : " ,(ls-compile false *multiple-value-p*) - ")")) + `(if (!== ,(ls-compile condition) ,(ls-compile nil)) + ,(ls-compile true *multiple-value-p*) + ,(ls-compile false *multiple-value-p*))) (defvar *ll-keywords* '(&optional &rest &key)) @@ -243,16 +246,14 @@ (ll-optional-arguments-canonical lambda-list)))) (remove nil (mapcar #'third args)))) -(defun lambda-name/docstring-wrapper (name docstring &rest code) +(defun lambda-name/docstring-wrapper (name docstring code) (if (or name docstring) - (js!selfcall - "var func = " `(code ,@code) ";" - (when name - `(code "func.fname = " ,(js-escape-string name) ";")) - (when docstring - `(code "func.docstring = " ,(js-escape-string docstring) ";")) - "return func;") - `(code ,@code))) + (js!selfcall* + `(var (func ,code)) + (when name `(= (get func |fname|) ,name)) + (when docstring `(= (get func |docstring|) ,docstring)) + `(return func)) + `(code ,code))) (defun lambda-check-argument-count (n-required-arguments n-optional-arguments rest-p) @@ -444,7 +445,9 @@ (eq (binding-type b) 'variable) (not (member 'special (binding-declarations b))) (not (member 'constant (binding-declarations b)))) - `(code ,(binding-value b) " = " ,(ls-compile val))) + ;; TODO: Unnecesary make-symbol when codegen migration is + ;; finished. + `(= ,(make-symbol (binding-value b)) ,(ls-compile val))) ((and b (eq (binding-type b) 'macro)) (ls-compile `(setf ,var ,val))) (t @@ -462,11 +465,9 @@ ((null (cdr pairs)) (error "Odd pairs in SETQ")) (t - (push `(code ,(setq-pair (car pairs) (cadr pairs)) - ,(if (null (cddr pairs)) "" ", ")) - result) + (push `,(setq-pair (car pairs) (cadr pairs)) result) (setq pairs (cddr pairs))))) - `(code "(" ,@(reverse result) ")"))) + `(progn ,@(reverse result)))) ;;; Compilation of literals an object dumping @@ -500,30 +501,29 @@ #-jscl (let ((package (symbol-package symbol))) (if (eq package (find-package "KEYWORD")) - `(code "(new Symbol(" ,(dump-string (symbol-name symbol)) ", " ,(dump-string (package-name package)) "))") - `(code "(new Symbol(" ,(dump-string (symbol-name symbol)) "))"))) + `(new (call |Symbol| ,(dump-string (symbol-name symbol)) ,(dump-string (package-name package)))) + `(new (call |Symbol| ,(dump-string (symbol-name symbol)))))) #+jscl (let ((package (symbol-package symbol))) (if (null package) - `(code "(new Symbol(" ,(dump-string (symbol-name symbol)) "))") + `(new (call |Symbol| ,(dump-string (symbol-name symbol)))) (ls-compile `(intern ,(symbol-name symbol) ,(package-name package)))))) (defun dump-cons (cons) (let ((head (butlast cons)) (tail (last cons))) - `(code "QIList(" - ,@(interleave (mapcar (lambda (x) (literal x t)) head) "," t) - ,(literal (car tail) t) - "," - ,(literal (cdr tail) t) - ")"))) + `(call |QIList| + ,@(mapcar (lambda (x) `(code ,(literal x t))) head) + (code ,(literal (car tail) t)) + (code ,(literal (cdr tail) t))))) (defun dump-array (array) (let ((elements (vector-to-list array))) - `(code "[" ,(join (mapcar #'literal elements) ", ") "]"))) + (list-to-vector (mapcar (lambda (x) `(code ,(literal x))) + elements)))) (defun dump-string (string) - `(code "make_lisp_string(" ,(js-escape-string string) ")")) + `(call |make_lisp_string| ,string)) (defun literal (sexp &optional recursive) (cond @@ -558,11 +558,13 @@ (literal sexp)) (define-compilation %while (pred &rest body) - (js!selfcall - "while(" (ls-compile pred) " !== " (ls-compile nil) "){" *newline* - `(code ,(ls-compile-block body)) - "}" *newline* - "return " (ls-compile nil) ";" *newline*)) + (js!selfcall* + `(while (!== ,(ls-compile pred) ,(ls-compile nil)) + 0 ; TODO: Force + ; braces. Unnecesary when code + ; is gone + (code ,(ls-compile-block body))) + `(return ,(ls-compile nil)))) (define-compilation function (x) (cond @@ -1327,20 +1329,20 @@ "return tmp === undefined? " (ls-compile nil) " : tmp;" ))) (define-raw-builtin oget (object key &rest keys) - `(code "js_to_lisp(" ,(ls-compile `(oget* ,object ,key ,@keys)) ")")) + `(call |js_to_lisp| ,(ls-compile `(oget* ,object ,key ,@keys)))) (define-raw-builtin oset (value object key &rest keys) (ls-compile `(oset* (lisp-to-js ,value) ,object ,key ,@keys))) (define-builtin objectp (x) - (js!bool `(code "(typeof (" ,x ") === 'object')"))) + (js!bool `(=== (typeof ,x) "object"))) -(define-builtin lisp-to-js (x) `(code "lisp_to_js(" ,x ")")) -(define-builtin js-to-lisp (x) `(code "js_to_lisp(" ,x ")")) +(define-builtin lisp-to-js (x) `(call |lisp_to_js| ,x)) +(define-builtin js-to-lisp (x) `(call |js_to_lisp| ,x)) (define-builtin in (key object) - (js!bool `(code "(xstring(" ,key ") in (" ,object "))"))) + (js!bool `(in (call |xstring| ,key) ,object))) (define-builtin map-for-in (function object) (js!selfcall @@ -1503,7 +1505,10 @@ (defun convert-toplevel (sexp &optional multiple-value-p) (let ((*toplevel-compilations* nil)) (cond - ((and (consp sexp) (eq (car sexp) 'progn)) + ;; Non-empty toplevel progn + ((and (consp sexp) + (eq (car sexp) 'progn) + (cdr sexp)) `(progn ,@(mapcar (lambda (s) (convert-toplevel s t)) (cdr sexp))))