;;; Wrap X with a Javascript code to convert the result from
;;; Javascript generalized booleans to T or NIL.
(defun js!bool (x)
- `(code "(" ,x "?" ,(ls-compile t) ": " ,(ls-compile nil) ")"))
+ `(if ,x ,(ls-compile t) ,(ls-compile nil)))
;;; Concatenate the arguments and wrap them with a self-calling
;;; Javascript anonymous function. It is used to make some Javascript
;;; It could be defined as function, but we could do some
;;; preprocessing in the future.
(defmacro js!selfcall (&body body)
- ``(code "(function(){" ,*newline*
- (code ,,@body)
- ,*newline*
- "})()"))
+ ``(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
*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))
(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)
(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
((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
#-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
(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
+ ,(ls-compile-block body))
+ `(return ,(ls-compile nil))))
(define-compilation function (x)
(cond
,@(interleave (mapcar #'translate-function fnames) ",")
"){"
,(ls-compile-block body t)
- "})(" ,@cfuncs ")")))
+ "})(" ,@(interleave cfuncs ",") ")")))
(define-compilation labels (definitions &rest body)
(let* ((fnames (mapcar #'car definitions))
(define-compilation progn (&rest body)
(if (null (cdr body))
(ls-compile (car body) *multiple-value-p*)
- `(code "("
- ,@(interleave
- (append (mapcar #'ls-compile (butlast body))
- (list (ls-compile (car (last body)) t)))
- ",")
- ")")))
+ `(progn
+ ,@(append (mapcar #'ls-compile (butlast body))
+ (list (ls-compile (car (last body)) t))))))
(define-compilation macrolet (definitions &rest body)
(let ((*environment* (copy-lexenv *environment*)))
"})")))
(define-compilation catch (id &rest body)
- (js!selfcall
- "var id = " (ls-compile id) ";"
- "try {"
- `(code ,(ls-compile-block body t))
- "}"
- "catch (cf){"
- " if (cf.type == 'catch' && cf.id == id)"
- (if *multiple-value-p*
- " return values.apply(this, forcemv(cf.values));"
- " return pv.apply(this, forcemv(cf.values));")
-
- " else"
- " throw cf;"
- "}" ))
+ (js!selfcall*
+ `(var (|id| ,(ls-compile id)))
+ `(try
+ ,(ls-compile-block body t))
+ `(catch (|cf|)
+ (if (and (== (get |cf| |type|) "catch")
+ (== (get |cf| |id|) |id|))
+ ,(if *multiple-value-p*
+ `(return (call (get |values| |apply|)
+ this
+ (call |forcemv| (get |cf| |values|))))
+ `(return (call (get |pv| |apply|)
+ this
+ (call |forcemv| (get |cf| |values|)))))
+ (throw |cf|)))))
(define-compilation throw (id value)
- (js!selfcall
- "var values = mv;"
- "throw ({"
- "type: 'catch', "
- "id: " (ls-compile id) ", "
- "values: " (ls-compile value t) ", "
- "message: 'Throw uncatched.'"
- "})"))
+ (js!selfcall*
+ `(var (|values| |mv|))
+ `(throw (object
+ |type| "catch"
+ |id| ,(ls-compile id)
+ |values| ,(ls-compile value t)
+ |message| "Throw uncatched."))))
(defun go-tag-p (x)
(or (integerp x) (symbolp x)))
"})" )))
(define-compilation unwind-protect (form &rest clean-up)
- (js!selfcall
- "var ret = " (ls-compile nil) ";"
- "try {"
- `(code "ret = " ,(ls-compile form) ";" )
- "} finally {"
- `(code ,(ls-compile-block clean-up))
- "}"
- "return ret;" ))
+ (js!selfcall*
+ `(var (|ret| ,(ls-compile nil)))
+ `(try
+ (= |ret| ,(ls-compile form)))
+ `(finally
+ ,(ls-compile-block clean-up))
+ `(return |ret|)))
(define-compilation multiple-value-call (func-form &rest forms)
(js!selfcall
(prelude '()))
(dolist (x args)
(cond
- ((floatp x) (push (float-to-string x) fargs))
- ((numberp x) (push (integer-to-string x) fargs))
- (t (let ((v (code "x" (incf counter))))
+ ((or (floatp x) (numberp x)) (push x fargs))
+ (t (let ((v (make-symbol (code "x" (incf counter)))))
(push v fargs)
(push `(code "var " ,v " = " ,(ls-compile x) ";"
"if (typeof " ,v " !== 'number') throw 'Not a number!';")
(define-raw-builtin + (&rest numbers)
(if (null numbers)
- "0"
+ 0
(variable-arity numbers
- `(code ,@(interleave numbers "+")))))
+ `(+ ,@numbers))))
(define-raw-builtin - (x &rest others)
(let ((args (cons x others)))
- (variable-arity args
- (if (null others)
- `(code "-" ,(car args))
- `(code ,@(interleave args "-"))))))
+ (variable-arity args `(- ,@args))))
(define-raw-builtin * (&rest numbers)
(if (null numbers)
- "1"
- (variable-arity numbers
- `(code ,@(interleave numbers "*")))))
+ 1
+ (variable-arity numbers `(* ,@numbers))))
(define-raw-builtin / (x &rest others)
(let ((args (cons x others)))
(variable-arity args
(if (null others)
- `(code "1 /" ,(car args))
- `(code ,@(interleave args "/"))))))
+ `(/ 1 ,(car args))
+ (reduce (lambda (x y) `(/ ,x ,y))
+ args)))))
(define-builtin mod (x y) (num-op-num x "%" y))
(defun comparison-conjuntion (vars op)
(cond
((null (cdr vars))
- "true")
+ 'true)
((null (cddr vars))
- `(code ,(car vars) ,op ,(cadr vars)))
+ `(,op ,(car vars) ,(cadr vars)))
(t
- `(code ,(car vars) ,op ,(cadr vars)
- " && "
- ,(comparison-conjuntion (cdr vars) op)))))
+ `(and (,op ,(car vars) ,(cadr vars))
+ ,(comparison-conjuntion (cdr vars) op)))))
(defmacro define-builtin-comparison (op sym)
`(define-raw-builtin ,op (x &rest args)
(let ((args (cons x args)))
(variable-arity args
- (js!bool (comparison-conjuntion args ,sym))))))
+ (js!bool (comparison-conjuntion args ',sym))))))
-(define-builtin-comparison > ">")
-(define-builtin-comparison < "<")
-(define-builtin-comparison >= ">=")
-(define-builtin-comparison <= "<=")
-(define-builtin-comparison = "==")
-(define-builtin-comparison /= "!=")
+(define-builtin-comparison > >)
+(define-builtin-comparison < <)
+(define-builtin-comparison >= >=)
+(define-builtin-comparison <= <=)
+(define-builtin-comparison = ==)
+(define-builtin-comparison /= !=)
(define-builtin numberp (x)
- (js!bool `(code "(typeof (" ,x ") == \"number\")")))
+ (js!bool `(== (typeof ,x) "number")))
(define-builtin floor (x)
(type-check (("x" "number" x))
"make_lisp_string(x.toString())"))
(define-builtin cons (x y)
- `(code "({car: " ,x ", cdr: " ,y "})"))
+ `(object "car" ,x "cdr" ,y))
(define-builtin consp (x)
(js!bool
"return (typeof tmp == 'object' && 'car' in tmp);" )))
(define-builtin car (x)
- (js!selfcall
- "var tmp = " x ";"
- "return tmp === " (ls-compile nil)
- "? " (ls-compile nil)
- ": tmp.car;" ))
+ (js!selfcall*
+ `(var (tmp ,x))
+ `(return (if (=== tmp ,(ls-compile nil))
+ ,(ls-compile nil)
+ (get tmp "car")))))
(define-builtin cdr (x)
- (js!selfcall
- "var tmp = " x ";"
- "return tmp === " (ls-compile nil) "? "
- (ls-compile nil)
- ": tmp.cdr;" ))
+ (js!selfcall*
+ `(var (tmp ,x))
+ `(return (if (=== tmp ,(ls-compile nil))
+ ,(ls-compile nil)
+ (get tmp "cdr")))))
(define-builtin rplaca (x new)
(type-check (("x" "object" x))
"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
" *newline*)
";" ,*newline*))))
-(defun ls-compile (sexp &optional multiple-value-p)
+(defun ls-compile* (sexp &optional multiple-value-p)
(multiple-value-bind (sexp expandedp) (!macroexpand-1 sexp)
(when expandedp
- (return-from ls-compile (ls-compile sexp multiple-value-p)))
+ (return-from ls-compile* (ls-compile sexp multiple-value-p)))
;; The expression has been macroexpanded. Now compile it!
(let ((*multiple-value-p* multiple-value-p))
(cond
(t
(error "How should I compile `~S'?" sexp))))))
+(defun ls-compile (sexp &optional multiple-value-p)
+ `(code "(" ,(ls-compile* sexp multiple-value-p) ")"))
+
(defvar *compile-print-toplevels* nil)
(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))))
projects / jscl.git / blobdiff