;;; It could be defined as function, but we could do some
;;; preprocessing in the future.
(defmacro js!selfcall (&body body)
- `(code "(function(){" *newline* (indent ,@body) "})()"))
+ `(code "(function(){" *newline* (code ,@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.
-#+jscl
-(defun indent (&rest string)
- (let ((input (apply #'code string)))
- (let ((output "")
- (index 0)
- (size (length input)))
- (when (plusp (length input)) (concatf output " "))
- (while (< index size)
- (let ((str
- (if (and (char= (char input index) #\newline)
- (< index (1- size))
- (not (char= (char input (1+ index)) #\newline)))
- (concat (string #\newline) " ")
- (string (char input index)))))
- (concatf output str))
- (incf index))
- output)))
-
-#-jscl
-(defun indent (&rest string)
- (with-output-to-string (*standard-output*)
- (with-input-from-string (input (apply #'code string))
- (loop
- for line = (read-line input nil)
- while line
- do (write-string " ")
- do (write-line line)))))
-
-
;;; A Form can return a multiple values object calling VALUES, like
;;; values(arg1, arg2, ...). It will work in any context, as well as
;;; returning an individual object. However, if the special variable
`(push (list ',name (lambda ,args (block ,name ,@body)))
*compilations*))
-(define-compilation if (condition true false)
+(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*)
(while (< idx n-optional-arguments)
(let ((arg (nth idx optional-arguments)))
(push (code "case " (+ idx n-required-arguments) ":" *newline*
- (indent (translate-variable (car arg))
- "="
- (ls-compile (cadr arg)) ";" *newline*)
+ (code (translate-variable (car arg))
+ "="
+ (ls-compile (cadr arg)) ";" *newline*)
(when (third arg)
- (indent (translate-variable (third arg))
- "="
- (ls-compile nil)
- ";" *newline*)))
+ (code (translate-variable (third arg))
+ "="
+ (ls-compile nil)
+ ";" *newline*)))
cases)
(incf idx)))
(push (code "default: break;" *newline*) cases)
(code "var " js!rest "= " (ls-compile nil) ";" *newline*
"for (var i = nargs-1; i>=" (+ n-required-arguments n-optional-arguments)
"; i--)" *newline*
- (indent js!rest " = {car: arguments[i+2], cdr: " js!rest "};" *newline*))))))
+ (code js!rest " = {car: arguments[i+2], cdr: " js!rest "};" *newline*))))))
(defun compile-lambda-parse-keywords (ll)
(let ((n-required-arguments
;; ((keyword-name var) init-form)
(code "for (i=" (+ n-required-arguments n-optional-arguments)
"; i<nargs; i+=2){" *newline*
- (indent
+ (code
"if (arguments[i+2] === " (ls-compile (caar keyarg)) "){" *newline*
- (indent (translate-variable (cadr (car keyarg)))
- " = arguments[i+3];"
- *newline*
- (let ((svar (third keyarg)))
- (when svar
- (code (translate-variable svar) " = " (ls-compile t) ";" *newline*)))
- "break;" *newline*)
+ (code (translate-variable (cadr (car keyarg)))
+ " = arguments[i+3];"
+ *newline*
+ (let ((svar (third keyarg)))
+ (when svar
+ (code (translate-variable svar) " = " (ls-compile t) ";" *newline*)))
+ "break;" *newline*)
"}" *newline*)
"}" *newline*
;; Default value
"if (i == nargs){" *newline*
- (indent (translate-variable (cadr (car keyarg))) " = " (ls-compile (cadr keyarg)) ";" *newline*)
+ (code (translate-variable (cadr (car keyarg))) " = " (ls-compile (cadr keyarg)) ";" *newline*)
"}" *newline*)))
(when keyword-arguments
(code "var i;" *newline*
(mapconcat #'parse-keyword keyword-arguments))))
;; Check for unknown keywords
(when keyword-arguments
- (code "for (i=" (+ n-required-arguments n-optional-arguments)
- "; i<nargs; i+=2){" *newline*
- (indent "if ("
- (join (mapcar (lambda (x)
- (concat "arguments[i+2] !== " (ls-compile (caar x))))
- keyword-arguments)
- " && ")
- ")" *newline*
- (indent
- "throw 'Unknown keyword argument ' + xstring(arguments[i].name);" *newline*))
+ (code "var start = " (+ n-required-arguments n-optional-arguments) ";" *newline*
+ "if ((nargs - start) % 2 == 1){" *newline*
+ (code "throw 'Odd number of keyword arguments';" *newline*)
+ "}" *newline*
+ "for (i = start; i<nargs; i+=2){" *newline*
+ (code "if ("
+ (join (mapcar (lambda (x)
+ (concat "arguments[i+2] !== " (ls-compile (caar x))))
+ keyword-arguments)
+ " && ")
+ ")" *newline*
+ (code
+ "throw 'Unknown keyword argument ' + xstring(arguments[i+2].name);" *newline*))
"}" *newline*)))))
(defun parse-lambda-list (ll)
(append required-arguments optional-arguments)))
",")
"){" *newline*
- (indent
+ (code
;; Check number of arguments
(lambda-check-argument-count n-required-arguments
n-optional-arguments
(define-compilation setq (&rest pairs)
(let ((result ""))
+ (when (null pairs)
+ (return-from setq (ls-compile nil)))
(while t
(cond
- ((null pairs) (return))
+ ((null pairs)
+ (return))
((null (cdr pairs))
(error "Odd pairs in SETQ"))
(t
;;; Compilation of literals an object dumping
-;;; Two seperate functions are needed for escaping strings:
-;;; One for producing JavaScript string literals (which are singly or
-;;; doubly quoted)
-;;; And one for producing Lisp strings (which are only doubly quoted)
-;;;
-;;; The same function would suffice for both, but for javascript string
-;;; literals it is neater to use either depending on the context, e.g:
-;;; foo's => "foo's"
-;;; "foo" => '"foo"'
-;;; which avoids having to escape quotes where possible
-(defun js-escape-string (string)
- (let ((index 0)
- (size (length string))
- (seen-single-quote nil)
- (seen-double-quote nil))
- (flet ((%js-escape-string (string escape-single-quote-p)
- (let ((output "")
- (index 0))
- (while (< index size)
- (let ((ch (char string index)))
- (when (char= ch #\\)
- (setq output (concat output "\\")))
- (when (and escape-single-quote-p (char= ch #\'))
- (setq output (concat output "\\")))
- (when (char= ch #\newline)
- (setq output (concat output "\\"))
- (setq ch #\n))
- (setq output (concat output (string ch))))
- (incf index))
- output)))
- ;; First, scan the string for single/double quotes
- (while (< index size)
- (let ((ch (char string index)))
- (when (char= ch #\')
- (setq seen-single-quote t))
- (when (char= ch #\")
- (setq seen-double-quote t)))
- (incf index))
- ;; Then pick the appropriate way to escape the quotes
- (cond
- ((not seen-single-quote)
- (concat "'" (%js-escape-string string nil) "'"))
- ((not seen-double-quote)
- (concat "\"" (%js-escape-string string nil) "\""))
- (t (concat "'" (%js-escape-string string t) "'"))))))
-
-(defun lisp-escape-string (string)
- (let ((output "")
- (index 0)
- (size (length string)))
- (while (< index size)
- (let ((ch (char string index)))
- (when (or (char= ch #\") (char= ch #\\))
- (setq output (concat output "\\")))
- (when (or (char= ch #\newline))
- (setq output (concat output "\\"))
- (setq ch #\n))
- (setq output (concat output (string ch))))
- (incf index))
- (concat "\"" output "\"")))
-
;;; BOOTSTRAP MAGIC: We record the macro definitions as lists during
;;; the bootstrap. Once everything is compiled, we want to dump the
;;; whole global environment to the output file to reproduce it in the
(define-compilation %while (pred &rest body)
(js!selfcall
"while(" (ls-compile pred) " !== " (ls-compile nil) "){" *newline*
- (indent (ls-compile-block body))
+ (code (ls-compile-block body))
"}"
"return " (ls-compile nil) ";" *newline*))
(join (mapcar #'translate-function fnames) ",")
"){" *newline*
(let ((body (ls-compile-block body t)))
- (indent body))
+ (code body))
"})(" (join cfuncs ",") ")")))
(define-compilation labels (definitions &rest body)
",")
")")))
+(define-compilation macrolet (definitions &rest body)
+ (let ((*environment* (copy-lexenv *environment*)))
+ (dolist (def definitions)
+ (destructuring-bind (name lambda-list &body body) def
+ (let ((binding (make-binding :name name :type 'macro :value
+ (let ((g!form (gensym)))
+ `(lambda (,g!form)
+ (destructuring-bind ,lambda-list ,g!form
+ ,@body))))))
+ (push-to-lexenv binding *environment* 'function))))
+ (ls-compile `(progn ,@body) *multiple-value-p*)))
+
+
(defun special-variable-p (x)
(and (claimp x 'variable 'special) t))
(return-from let-binding-wrapper body))
(code
"try {" *newline*
- (indent "var tmp;" *newline*
+ (code "var tmp;" *newline*
(mapconcat
(lambda (b)
(let ((s (ls-compile `(quote ,(car b)))))
body *newline*)
"}" *newline*
"finally {" *newline*
- (indent
+ (code
(mapconcat (lambda (b)
(let ((s (ls-compile `(quote ,(car b)))))
(code s ".value" " = " (cdr b) ";" *newline*)))
",")
"){" *newline*
(let ((body (ls-compile-block body t t)))
- (indent (let-binding-wrapper dynamic-bindings body)))
+ (code (let-binding-wrapper dynamic-bindings body)))
"})(" (join cvalues ",") ")")))
(remove-if-not #'special-variable-p symbols))))
(code
"try {" *newline*
- (indent
+ (code
(mapconcat (lambda (b)
(let ((s (ls-compile `(quote ,(car b)))))
(code "var " (cdr b) " = " s ".value;" *newline*)))
body)
"}" *newline*
"finally {" *newline*
- (indent
+ (code
(mapconcat (lambda (b)
(let ((s (ls-compile `(quote ,(car b)))))
(code s ".value" " = " (cdr b) ";" *newline*)))
(js!selfcall
"try {" *newline*
"var " idvar " = [];" *newline*
- (indent cbody)
+ (code cbody)
"}" *newline*
"catch (cf){" *newline*
" if (cf.type == 'block' && cf.id == " idvar ")" *newline*
(js!selfcall
"var id = " (ls-compile id) ";" *newline*
"try {" *newline*
- (indent (ls-compile-block body t)) *newline*
+ (code (ls-compile-block body t)) *newline*
"}" *newline*
"catch (cf){" *newline*
" if (cf.type == 'catch' && cf.id == id)" *newline*
"var " tbidx " = [];" *newline*
"tbloop:" *newline*
"while (true) {" *newline*
- (indent "try {" *newline*
- (indent (let ((content ""))
+ (code "try {" *newline*
+ (code (let ((content ""))
(code "switch(" branch "){" *newline*
"case " initag ":" *newline*
(dolist (form (cdr body) content)
(concatf content
(if (not (go-tag-p form))
- (indent (ls-compile form) ";" *newline*)
+ (code (ls-compile form) ";" *newline*)
(let ((b (lookup-in-lexenv form *environment* 'gotag)))
(code "case " (second (binding-value b)) ":" *newline*)))))
"default:" *newline*
(js!selfcall
"var ret = " (ls-compile nil) ";" *newline*
"try {" *newline*
- (indent "ret = " (ls-compile form) ";" *newline*)
+ (code "ret = " (ls-compile form) ";" *newline*)
"} finally {" *newline*
- (indent (ls-compile-block clean-up))
+ (code (ls-compile-block clean-up))
"}" *newline*
"return ret;" *newline*))
(mapconcat (lambda (form)
(code "vs = " (ls-compile form t) ";" *newline*
"if (typeof vs === 'object' && 'multiple-value' in vs)" *newline*
- (indent "args = args.concat(vs);" *newline*)
+ (code "args = args.concat(vs);" *newline*)
"else" *newline*
- (indent "args.push(vs);" *newline*)))
+ (code "args.push(vs);" *newline*)))
forms)
"args[1] = args.length-2;" *newline*
"return func.apply(window, args);" *newline*) ";" *newline*))
decls)
,@(mapcar (lambda (decl)
`(code "if (typeof " ,(first decl) " != '" ,(second decl) "')" *newline*
- (indent "throw 'The value ' + "
+ (code "throw 'The value ' + "
,(first decl)
" + ' is not a type "
,(second decl)
"var x = " x ";" *newline*
"return (typeof(" x ") == \"string\") && (x.length == 1 || x.length == 2);")))
-(define-builtin char-to-string (x)
- (js!selfcall
- "var r = [" x "];" *newline*
- "r.type = 'character';"
- "return r"))
-
(define-builtin char-upcase (x)
(code "safe_char_upcase(" x ")"))
(js!bool
(js!selfcall
"var x = " x ";" *newline*
- "return typeof(x) == 'object' && 'length' in x && x.type == 'character';")))
-
-(define-builtin string-upcase (x)
- (code "make_lisp_string(xstring(" x ").toUpperCase())"))
-
-(define-builtin string-length (x)
- (code x ".length"))
-
-(define-raw-builtin slice (vector a &optional b)
- (js!selfcall
- "var vector = " (ls-compile vector) ";" *newline*
- "var a = " (ls-compile a) ";" *newline*
- "var b;" *newline*
- (when b (code "b = " (ls-compile b) ";" *newline*))
- "return vector.slice(a,b);" *newline*))
-
-(define-builtin char (string index)
- (code string "[" index "]"))
-
-(define-builtin concat-two (string1 string2)
- (js!selfcall
- "var r = " string1 ".concat(" string2 ");" *newline*
- "r.type = 'character';"
- "return r;" *newline*))
+ "return typeof(x) == 'object' && 'length' in x && x.stringp == 1;")))
(define-raw-builtin funcall (func &rest args)
(js!selfcall
(define-builtin %throw (string)
(js!selfcall "throw " string ";" *newline*))
-(define-builtin new () "{}")
-
-(define-builtin objectp (x)
- (js!bool (code "(typeof (" x ") === 'object')")))
-
-(define-builtin oget (object key)
- (js!selfcall
- "var tmp = " "(" object ")[xstring(" key ")];" *newline*
- "return tmp == undefined? " (ls-compile nil) ": tmp ;" *newline*))
-
-(define-builtin oset (object key value)
- (code "((" object ")[xstring(" key ")] = " value ")"))
-
-(define-builtin in (key object)
- (js!bool (code "(xstring(" key ") in (" object "))")))
-
-(define-builtin map-for-in (function object)
- (js!selfcall
- "var f = " function ";" *newline*
- "var g = (typeof f === 'function' ? f : f.fvalue);" *newline*
- "var o = " object ";" *newline*
- "for (var key in o){" *newline*
- (indent "g(" (if *multiple-value-p* "values" "pv") ", 1, o[key]);" *newline*)
- "}"
- " return " (ls-compile nil) ";" *newline*))
-
(define-builtin functionp (x)
(js!bool (code "(typeof " x " == 'function')")))
-(define-builtin write-string (x)
+(define-builtin %write-string (x)
(code "lisp.write(" x ")"))
-(define-builtin make-array (n)
- (js!selfcall
- "var r = [];" *newline*
- "for (var i = 0; i < " n "; i++)" *newline*
- (indent "r.push(" (ls-compile nil) ");" *newline*)
- "return r;" *newline*))
-;;; FIXME: should take optional min-extension.
-;;; FIXME: should use fill-pointer instead of the absolute end of array
-(define-builtin vector-push-extend (new vector)
- (js!selfcall
- "var v = " vector ";" *newline*
- "v.push(" new ");" *newline*
- "return v;"))
+;;; Storage vectors. They are used to implement arrays and (in the
+;;; future) structures.
-(define-builtin arrayp (x)
+(define-builtin storage-vector-p (x)
(js!bool
(js!selfcall
"var x = " x ";" *newline*
"return typeof x === 'object' && 'length' in x;")))
-(define-builtin aref (array n)
+(define-builtin make-storage-vector (n)
+ (js!selfcall
+ "var r = [];" *newline*
+ "r.length = " n ";" *newline*
+ "return r;" *newline*))
+
+(define-builtin storage-vector-size (x)
+ (code x ".length"))
+
+(define-builtin resize-storage-vector (vector new-size)
+ (code "(" vector ".length = " new-size ")"))
+
+(define-builtin storage-vector-ref (vector n)
(js!selfcall
- "var x = " "(" array ")[" n "];" *newline*
+ "var x = " "(" vector ")[" n "];" *newline*
"if (x === undefined) throw 'Out of range';" *newline*
"return x;" *newline*))
-(define-builtin aset (array n value)
+(define-builtin storage-vector-set (vector n value)
(js!selfcall
- "var x = " array ";" *newline*
+ "var x = " vector ";" *newline*
"var i = " n ";" *newline*
"if (i < 0 || i >= x.length) throw 'Out of range';" *newline*
"return x[i] = " value ";" *newline*))
-(define-builtin afind (value array)
- (js!selfcall
- "var v = " value ";" *newline*
- "var x = " array ";" *newline*
- "return x.indexOf(v);" *newline*))
-
-(define-builtin aresize (array new-size)
+(define-builtin concatenate-storage-vector (sv1 sv2)
(js!selfcall
- "var x = " array ";" *newline*
- "var n = " new-size ";" *newline*
- "return x.length = n;" *newline*))
+ "var sv1 = " sv1 ";" *newline*
+ "var r = sv1.concat(" sv2 ");" *newline*
+ "r.type = sv1.type;" *newline*
+ "r.stringp = sv1.stringp;" *newline*
+ "return r;" *newline*))
(define-builtin get-internal-real-time ()
"(new Date()).getTime()")
;;; Javascript FFI
+(define-builtin new () "{}")
+
+(define-raw-builtin oget* (object key &rest keys)
+ (js!selfcall
+ "var tmp = (" (ls-compile object) ")[xstring(" (ls-compile key) ")];" *newline*
+ (mapconcat (lambda (key)
+ (code "if (tmp === undefined) return " (ls-compile nil) ";" *newline*
+ "tmp = tmp[xstring(" (ls-compile key) ")];" *newline*))
+ keys)
+ "return tmp === undefined? " (ls-compile nil) " : tmp;" *newline*))
+
+(define-raw-builtin oset* (value object key &rest keys)
+ (let ((keys (cons key keys)))
+ (js!selfcall
+ "var obj = " (ls-compile object) ";" *newline*
+ (mapconcat (lambda (key)
+ (code "obj = obj[xstring(" (ls-compile key) ")];"
+ "if (obj === undefined) throw 'Impossible to set Javascript property.';" *newline*))
+ (butlast keys))
+ "var tmp = obj[xstring(" (ls-compile (car (last keys))) ")] = " (ls-compile value) ";" *newline*
+ "return tmp === undefined? " (ls-compile nil) " : tmp;" *newline*)))
+
+(define-raw-builtin oget (object key &rest keys)
+ (code "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')")))
+
+(define-builtin lisp-to-js (x) (code "lisp_to_js(" x ")"))
+(define-builtin js-to-lisp (x) (code "js_to_lisp(" x ")"))
+
+
+(define-builtin in (key object)
+ (js!bool (code "(xstring(" key ") in (" object "))")))
+
+(define-builtin map-for-in (function object)
+ (js!selfcall
+ "var f = " function ";" *newline*
+ "var g = (typeof f === 'function' ? f : f.fvalue);" *newline*
+ "var o = " object ";" *newline*
+ "for (var key in o){" *newline*
+ (code "g(" (if *multiple-value-p* "values" "pv") ", 1, o[key]);" *newline*)
+ "}"
+ " return " (ls-compile nil) ";" *newline*))
+
(define-compilation %js-vref (var)
(code "js_to_lisp(" var ")"))
(mapcar #'ls-compile args)) ", ") ")")))
(unless (or (symbolp function)
(and (consp function)
- (eq (car function) 'lambda)))
+ (member (car function) '(lambda oget))))
(error "Bad function designator `~S'" function))
(cond
((translate-function function)
#+jscl (eq (symbol-package function) (find-package "COMMON-LISP"))
#-jscl t)
(code (ls-compile `',function) ".fvalue" arglist))
+ #+jscl((symbolp function)
+ (code (ls-compile `#',function) arglist))
+ ((and (consp function) (eq (car function) 'lambda))
+ (code (ls-compile `#',function) arglist))
+ ((and (consp function) (eq (car function) 'oget))
+ (code (ls-compile function) arglist))
(t
- (code (ls-compile `#',function) arglist)))))
+ (error "Bad function descriptor")))))
(defun ls-compile-block (sexps &optional return-last-p decls-allowed-p)
(multiple-value-bind (sexps decls)
projects / jscl.git / blobdiff