;;; compiler.lisp ---
-;; Copyright (C) 2012, 2013 David Vazquez
+;; copyright (C) 2012, 2013 David Vazquez
;; Copyright (C) 2012 Raimon Grau
;; This program is free software: you can redistribute it and/or
(cond
((null arg) "")
((integerp arg) (integer-to-string arg))
+ ((floatp arg) (float-to-string arg))
((stringp arg) arg)
(t (error "Unknown argument."))))
args))
;;; of this function are available, because the Ecmalisp version is
;;; very slow and bootstraping was annoying.
-#+ecmalisp
+#+jscl
(defun indent (&rest string)
(let ((input (apply #'code string)))
(let ((output "")
(let ((b (global-binding name 'variable 'variable)))
(push 'constant (binding-declarations b)))))))
-#+ecmalisp
+#+jscl
(fset 'proclaim #'!proclaim)
(defun %define-symbol-macro (name expansion)
(push-to-lexenv b *environment* 'variable)
name))
-#+ecmalisp
+#+jscl
(defmacro define-symbol-macro (name expansion)
`(%define-symbol-macro ',name ',expansion))
output))
-(defvar *literal-symbols* nil)
+(defvar *literal-table* nil)
(defvar *literal-counter* 0)
(defun genlit ()
(code "l" (incf *literal-counter*)))
+(defun dump-symbol (symbol)
+ #+common-lisp
+ (let ((package (symbol-package symbol)))
+ (if (eq package (find-package "KEYWORD"))
+ (code "{name: \"" (escape-string (symbol-name symbol))
+ "\", 'package': '" (package-name package) "'}")
+ (code "{name: \"" (escape-string (symbol-name symbol)) "\"}")))
+ #+jscl
+ (let ((package (symbol-package symbol)))
+ (if (null package)
+ (code "{name: \"" (escape-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("
+ (join-trailing (mapcar (lambda (x) (literal x t)) head) ",")
+ (literal (car tail) t)
+ ","
+ (literal (cdr tail) t)
+ ")")))
+
+(defun dump-array (array)
+ (let ((elements (vector-to-list array)))
+ (concat "[" (join (mapcar #'literal elements) ", ") "]")))
+
(defun literal (sexp &optional recursive)
(cond
((integerp sexp) (integer-to-string sexp))
+ ((floatp sexp) (float-to-string sexp))
((stringp sexp) (code "\"" (escape-string sexp) "\""))
- ((symbolp sexp)
- (or (cdr (assoc sexp *literal-symbols*))
- (let ((v (genlit))
- (s #+common-lisp
- (let ((package (symbol-package sexp)))
- (if (eq package (find-package "KEYWORD"))
- (code "{name: \"" (escape-string (symbol-name sexp))
- "\", 'package': '" (package-name package) "'}")
- (code "{name: \"" (escape-string (symbol-name sexp)) "\"}")))
- #+ecmalisp
- (let ((package (symbol-package sexp)))
- (if (null package)
- (code "{name: \"" (escape-string (symbol-name sexp)) "\"}")
- (ls-compile `(intern ,(symbol-name sexp) ,(package-name package)))))))
- (push (cons sexp v) *literal-symbols*)
- (toplevel-compilation (code "var " v " = " s))
- v)))
- ((consp sexp)
- (let* ((head (butlast sexp))
- (tail (last sexp))
- (c (code "QIList("
- (join-trailing (mapcar (lambda (x) (literal x t)) head) ",")
- (literal (car tail) t)
- ","
- (literal (cdr tail) t)
- ")")))
- (if recursive
- c
- (let ((v (genlit)))
- (toplevel-compilation (code "var " v " = " c))
- v))))
- ((arrayp sexp)
- (let ((elements (vector-to-list sexp)))
- (let ((c (concat "[" (join (mapcar #'literal elements) ", ") "]")))
- (if recursive
- c
- (let ((v (genlit)))
- (toplevel-compilation (code "var " v " = " c))
- v)))))))
+ (t
+ (or (cdr (assoc sexp *literal-table*))
+ (let ((dumped (typecase sexp
+ (symbol (dump-symbol sexp))
+ (cons (dump-cons sexp))
+ (array (dump-array sexp)))))
+ (if (and recursive (not (symbolp sexp)))
+ dumped
+ (let ((jsvar (genlit)))
+ (push (cons sexp jsvar) *literal-table*)
+ (toplevel-compilation (code "var " jsvar " = " dumped))
+ jsvar)))))))
(define-compilation quote (sexp)
(literal sexp))
(fargs '())
(prelude ""))
(dolist (x args)
- (if (numberp x)
- (push (integer-to-string x) fargs)
- (let ((v (code "x" (incf counter))))
- (push v fargs)
- (concatf prelude
- (code "var " v " = " (ls-compile x) ";" *newline*
- "if (typeof " v " !== 'number') throw 'Not a number!';"
- *newline*)))))
+ (cond
+ ((floatp x) (push (float-to-string x) fargs))
+ ((numberp x) (push (integer-to-string x) fargs))
+ (t (let ((v (code "x" (incf counter))))
+ (push v fargs)
+ (concatf prelude
+ (code "var " v " = " (ls-compile x) ";" *newline*
+ "if (typeof " v " !== 'number') throw 'Not a number!';"
+ *newline*))))))
(js!selfcall prelude (funcall function (reverse fargs)))))
(type-check (("x" "number" x))
"Math.floor(x)"))
+(define-builtin expt (x y)
+ (type-check (("x" "number" x)
+ ("y" "number" y))
+ "Math.pow(x, y)"))
+
+(define-builtin float-to-string (x)
+ (type-check (("x" "number" x))
+ "x.toString()"))
+
(define-builtin cons (x y)
(code "({car: " x ", cdr: " y "})"))
(code "(" x ").toString()"))
(define-builtin eq (x y) (js!bool (code "(" x " === " y ")")))
-(define-builtin equal (x y) (js!bool (code "(" x " == " y ")")))
(define-builtin char-to-string (x)
(type-check (("x" "number" x))
(type-check (("string" "string" string))
(if *multiple-value-p*
(js!selfcall
- "var v = eval.apply(window, [string]);" *newline*
+ "var v = globalEval(string);" *newline*
"if (typeof v !== 'object' || !('multiple-value' in v)){" *newline*
(indent "v = [v];" *newline*
"v['multiple-value'] = true;" *newline*)
"}" *newline*
"return values.apply(this, v);" *newline*)
- "eval.apply(window, [string])")))
+ "globalEval(string)")))
(define-builtin error (string)
(js!selfcall "throw " string ";" *newline*))
"if (i < 0 || i >= x.length) throw 'Out of range';" *newline*
"return x[i] = " value ";" *newline*))
-(define-builtin get-unix-time ()
- (code "(Math.round(new Date() / 1000))"))
+(define-builtin get-internal-real-time ()
+ "(new Date()).getTime()")
(define-builtin values-array (array)
(if *multiple-value-p*
;; us replace the list representation version of the
;; function with the compiled one.
;;
- #+ecmalisp (setf (binding-value macro-binding) compiled)
+ #+jscl (setf (binding-value macro-binding) compiled)
#+common-lisp (setf (gethash macro-binding *macroexpander-cache*) compiled)
(setq expander compiled))))
(values (apply expander (cdr form)) t))
(defun compile-funcall (function args)
(let* ((values-funcs (if *multiple-value-p* "values" "pv"))
(arglist (concat "(" (join (cons values-funcs (mapcar #'ls-compile args)) ", ") ")")))
+ (unless (or (symbolp function)
+ (and (consp function)
+ (eq (car function) 'lambda)))
+ (error "Bad function"))
(cond
((translate-function function)
(concat (translate-function function) arglist))
((and (symbolp function)
- #+ecmalisp (eq (symbol-package function) (find-package "COMMON-LISP"))
+ #+jscl (eq (symbol-package function) (find-package "COMMON-LISP"))
#+common-lisp t)
(code (ls-compile `',function) ".fvalue" arglist))
(t
(t
(ls-compile `(symbol-value ',sexp))))))
((integerp sexp) (integer-to-string sexp))
+ ((floatp sexp) (float-to-string sexp))
((stringp sexp) (code "\"" (escape-string sexp) "\""))
((arrayp sexp) (literal sexp))
((listp sexp)
projects / jscl.git / blobdiff