var startPrompt = function () {
// Start the prompt with history enabled.
- jqconsole.Write(xstring(lisp.evalString(pv, 1, make_lisp_string('(CL:PACKAGE-NAME CL:*PACKAGE*)'))) + '> ', 'jqconsole-prompt');
+ jqconsole.Write(lisp.evalString('(CL:PACKAGE-NAME CL:*PACKAGE*)') + '> ', 'jqconsole-prompt');
jqconsole.Prompt(true, function (input) {
// Output input with the class jqconsole-return.
if (input[0] != ','){
try {
- var vs = lisp.evalInput(mv, 1, make_lisp_string(input));
- for (var i=0; i<vs.length; i++){
- jqconsole.Write(xstring(lisp.print(pv, 1, vs[i])) + '\n', 'jqconsole-return');
- }
+ var vs = lisp.evalInput(input);
+ // for (var i=0; i<vs.length; i++){
+ jqconsole.Write(lisp.print(vs) + '\n', 'jqconsole-return');
+ // }
} catch(error) {
var msg = error.message || error || 'Unknown error';
if (typeof(msg) != 'string') msg = xstring(msg);
jqconsole.Write('ERROR: ' + msg + '\n', 'jqconsole-error');
}
- } else {
- jqconsole.Write(xstring(lisp.compileString(pv, 1, make_lisp_string(input.slice(1)))) + '\n', 'jqconsole-return');
- }
+ } else
+ jqconsole.Write(lisp.compileString(input.slice(1)) + '\n', 'jqconsole-return');
+
// Restart the prompt.
startPrompt();
}, function(input){
try {
- lisp.read(pv, 1, make_lisp_string(input[0]==','? input.slice(1): input));
+ lisp.read(input[0]==','? input.slice(1): input);
} catch(error) {
return 0;
}
("string" :target)
("print" :target)
("package" :target)
+ ("ffi" :target)
("read" :both)
("compiler" :both)
("toplevel" :target)))
#+common-lisp
(let ((package (symbol-package symbol)))
(if (eq package (find-package "KEYWORD"))
- (code "{name: " (dump-string (symbol-name symbol))
- ", 'package': " (dump-string (package-name package)) "}")
- (code "{name: " (dump-string (symbol-name symbol)) "}")))
+ (code "(new Symbol(" (dump-string (symbol-name symbol)) ", "
+ (dump-string (package-name package)) "))")
+ (code "(new Symbol(" (dump-string (symbol-name symbol)) "))")))
#+jscl
(let ((package (symbol-package symbol)))
(if (null package)
- (code "{name: " (dump-symbol (symbol-name symbol)) "}")
+ (code "(new Symbol(" (dump-symbol (symbol-name symbol)) "))")
(ls-compile `(intern ,(symbol-name symbol) ,(package-name package))))))
(defun dump-cons (cons)
"return args;" *newline*))
-;;; Javascript FFI
-
-(define-compilation %js-vref (var) var)
-
-(define-compilation %js-vset (var val)
- (code "(" var " = " (ls-compile val) ")"))
-
-(define-setf-expander %js-vref (var)
- (let ((new-value (gensym)))
- (unless (stringp var)
- (error "`~S' is not a string." var))
- (values nil
- (list var)
- (list new-value)
- `(%js-vset ,var ,new-value)
- `(%js-vref ,var))))
-
-
;;; Backquote implementation.
;;;
;;; Author: Guy L. Steele Jr. Date: 27 December 1985
(code "(x.cdr = " new ", x)")))
(define-builtin symbolp (x)
- (js!bool
- (js!selfcall
- "var tmp = " x ";" *newline*
- "return (typeof tmp == 'object' && 'name' in tmp);" *newline*)))
+ (js!bool (code "(" x " instanceof Symbol)")))
(define-builtin make-symbol (name)
- (code "({name: " name "})"))
+ (code "(new Symbol(" name "))"))
(define-builtin symbol-name (x)
(code "(" x ").name"))
(code "values(" (join (mapcar #'ls-compile args) ", ") ")")
(code "pv(" (join (mapcar #'ls-compile args) ", ") ")")))
-;; Receives the JS function as first argument as a literal string. The
-;; second argument is compiled and should evaluate to a vector of
-;; values to apply to the the function. The result returned.
-(define-builtin %js-call (fun args)
- (code fun ".apply(this, " args ")"))
+
+;;; Javascript FFI
+
+(define-compilation %js-vref (var)
+ (code "js_to_lisp(" var ")"))
+
+(define-compilation %js-vset (var val)
+ (code "(" var " = lisp_to_js(" (ls-compile val) "))"))
+
+(define-setf-expander %js-vref (var)
+ (let ((new-value (gensym)))
+ (unless (stringp var)
+ (error "`~S' is not a string." var))
+ (values nil
+ (list var)
+ (list new-value)
+ `(%js-vset ,var ,new-value)
+ `(%js-vref ,var))))
+
#+common-lisp
(defvar *macroexpander-cache*
(if (and b (eq (binding-type b) 'macro))
(values (binding-value b) t)
(values form nil))))
- ((consp form)
+ ((and (consp form) (symbolp (car form)))
(let ((macrofun (!macro-function (car form))))
(if macrofun
(values (apply macrofun (cdr form)) t)
--- /dev/null
+;;; ffi.lisp ---
+
+;; JSCL is free software: you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+;;
+;; JSCL is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with JSCL. If not, see <http://www.gnu.org/licenses/>.
+
+(defvar *js-package*
+ (make-package "JS"))
+
+(defun ffi-intern-hook (symbol)
+ (when (eq (symbol-package symbol) *js-package*)
+ (let ((sym-name (symbol-name symbol))
+ (args (gensym)))
+ ;; Generate a trampoline to call the JS function
+ ;; properly. This trampoline is very inefficient,
+ ;; but it still works. Ideas to optimize this are
+ ;; provide a special lambda keyword
+ ;; cl::&rest-vector to avoid list argument
+ ;; consing, as well as allow inline declarations.
+ (fset symbol
+ (eval `(lambda (&rest ,args)
+ (apply (%js-vref ,sym-name) ,args))))
+ ;; Define it as a symbol macro to access to the
+ ;; Javascript variable literally.
+ (%define-symbol-macro symbol `(%js-vref ,(string symbol))))))
+
+(setq *intern-hook* #'ffi-intern-hook)
(defvar *common-lisp-package*
(make-package "CL"))
-(defvar *js-package*
- (make-package "JS"))
-
(defvar *user-package*
(make-package "CL-USER" :use (list *common-lisp-package*)))
(when (in name exports)
(return (values (oget exports name) :inherit)))))))))
+
+;;; It is a function to call when a symbol is interned. The function
+;;; is invoked with the already interned symbol as argument.
+(defvar *intern-hook* nil)
+
(defun intern (name &optional (package *package*))
(let ((package (find-package-or-fail package)))
(multiple-value-bind (symbol foundp)
(when (eq package *keyword-package*)
(oset symbol "value" symbol)
(export (list symbol) package))
- (when (eq package *js-package*)
- (let ((sym-name (symbol-name symbol))
- (args (gensym)))
- ;; Generate a trampoline to call the JS function
- ;; properly. This trampoline is very inefficient,
- ;; but it still works. Ideas to optimize this are
- ;; provide a special lambda keyword
- ;; cl::&rest-vector to avoid list argument
- ;; consing, as well as allow inline declarations.
- (fset symbol
- (eval `(lambda (&rest ,args)
- (let ((,args (list-to-vector ,args)))
- (%js-call (%js-vref ,sym-name) ,args)))))
- ;; Define it as a symbol macro to access to the
- ;; Javascript variable literally.
- (%define-symbol-macro symbol `(%js-vref ,(string symbol)))))
+ (when *intern-hook*
+ (funcall *intern-hook* symbol))
(oset symbols name symbol)
(values symbol nil)))))))
function xstring(x){ return x.join(''); }
+
+function Symbol(name, package_name){
+ this.name = name;
+ if (package_name)
+ this['package'] = package_name;
+}
+
+function lisp_to_js (x) {
+ if (typeof x == 'object' && 'length' in x && x.type == 'character')
+ return xstring(x);
+ else if (typeof x == 'function'){
+ // Trampoline calling the Lisp function
+ return (function(){
+ var args = Array.prototype.slice.call(arguments);
+ for (var i in args)
+ args[i] = js_to_lisp(args[i]);
+ return lisp_to_js(x.apply(this, [pv, arguments.length].concat(args)));
+ });
+ }
+ else return x;
+}
+
+function js_to_lisp (x) {
+ if (typeof x == 'string')
+ return make_lisp_string(x);
+ else if (typeof x == 'function'){
+ // Trampoline calling the JS function
+ return (function(values, nargs){
+ var args = Array.prototype.slice.call(arguments, 2);
+ for (var i in args)
+ args[i] = lisp_to_js(args[i]);
+ return values(js_to_lisp(x.apply(this, args)));
+ });
+ } else return x;
+}
(skip-whitespaces stream)
(setq ch (%peek-char stream)))))
+(defun discard-char (stream expected)
+ (let ((ch (%read-char stream)))
+ (when (null ch)
+ (error "End of file when character ~S was expected." expected))
+ (unless (char= ch expected)
+ (error "Character ~S was found but ~S was expected." ch expected))))
+
(defun %read-list (stream)
(skip-whitespaces-and-comments stream)
(let ((ch (%peek-char stream)))
((null ch)
(error "Unspected EOF"))
((char= ch #\))
- (%read-char stream)
+ (discard-char stream #\))
nil)
(t
- (let ((car (ls-read-1 stream)))
+ (let* ((eof (gensym))
+ (next (ls-read stream nil eof)))
(skip-whitespaces-and-comments stream)
- (cons car
- (if (char= (%peek-char stream) #\.)
- (progn
- (%read-char stream)
- (if (terminalp (%peek-char stream))
- (ls-read-1 stream) ; Dotted pair notation
- (cons (let ((string (concat "." (read-escaped-until stream #'terminalp))))
- (or (values (!parse-integer string nil))
- (read-float string)
- (read-symbol string)))
- (%read-list stream))))
- (%read-list stream))))))))
+ (cond
+ ((eq next eof)
+ (discard-char stream #\)))
+ (t
+ (cons next
+ (if (char= (%peek-char stream) #\.)
+ (progn
+ (discard-char stream #\.)
+ (if (terminalp (%peek-char stream))
+ (prog1 (ls-read stream) ; Dotted pair notation
+ (discard-char stream #\)))
+ (let ((token (concat "." (read-escaped-until stream #'terminalp))))
+ (cons (interpret-token token)
+ (%read-list stream)))))
+ (%read-list stream))))))))))
(defun read-string (stream)
(let ((string "")
(setq ch (%read-char stream)))
string))
-(defun read-sharp (stream)
+(defun read-sharp (stream &optional eof-error-p eof-value)
(%read-char stream)
(ecase (%read-char stream)
(#\'
- (list 'function (ls-read-1 stream)))
+ (list 'function (ls-read stream)))
(#\( (list-to-vector (%read-list stream)))
(#\: (make-symbol (string-upcase (read-until stream #'terminalp))))
(#\\
((string= cname "newline") #\newline)
(t (char cname 0)))))
(#\+
- (let ((feature (read-until stream #'terminalp)))
- (cond
- ((string= feature "common-lisp")
- (ls-read-1 stream) ;ignore
- (ls-read-1 stream))
- ((string= feature "jscl")
- (ls-read-1 stream))
- (t
- (error "Unknown reader form.")))))))
+ (let ((feature (let ((symbol (ls-read stream)))
+ (unless (symbolp symbol)
+ (error "Invalid feature ~S" symbol))
+ (intern (string symbol) "KEYWORD"))))
+ (ecase feature
+ (:common-lisp
+ (ls-read stream)
+ (ls-read stream eof-error-p eof-value))
+ (:jscl
+ (ls-read stream eof-error-p eof-value)))))))
(defun unescape (x)
(let ((result ""))
(values num index)
(error "Junk detected."))))
-(defvar *eof* (gensym))
-(defun ls-read-1 (stream)
+
+(defun interpret-token (string)
+ (or (read-integer string)
+ (read-float string)
+ (read-symbol string)))
+
+(defun ls-read (stream &optional (eof-error-p t) eof-value)
(skip-whitespaces-and-comments stream)
(let ((ch (%peek-char stream)))
(cond
((or (null ch) (char= ch #\)))
- *eof*)
+ (if eof-error-p
+ (error "End of file")
+ eof-value))
((char= ch #\()
(%read-char stream)
(%read-list stream))
((char= ch #\')
(%read-char stream)
- (list 'quote (ls-read-1 stream)))
+ (list 'quote (ls-read stream)))
((char= ch #\`)
(%read-char stream)
- (list 'backquote (ls-read-1 stream)))
+ (list 'backquote (ls-read stream)))
((char= ch #\")
(%read-char stream)
(read-string stream))
((char= ch #\,)
(%read-char stream)
(if (eql (%peek-char stream) #\@)
- (progn (%read-char stream) (list 'unquote-splicing (ls-read-1 stream)))
- (list 'unquote (ls-read-1 stream))))
+ (progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
+ (list 'unquote (ls-read stream))))
((char= ch #\#)
(read-sharp stream))
(t
(let ((string (read-escaped-until stream #'terminalp)))
- (or (read-integer string)
- (read-float string)
- (read-symbol string)))))))
-
-(defun ls-read (stream &optional (eof-error-p t) eof-value)
- (let ((x (ls-read-1 stream)))
- (if (eq x *eof*)
- (if eof-error-p
- (error "End of file")
- eof-value)
- x)))
+ (interpret-token string))))))
(defun ls-read-from-string (string &optional (eof-error-p t) eof-value)
(ls-read (make-string-stream string) eof-error-p eof-value))