Merge branch 'master' of https://github.com/davazp/jscl into list-stuff
authorOwen Rodley <Strigoides@gmail.com>
Sat, 4 May 2013 05:58:20 +0000 (17:58 +1200)
committerOwen Rodley <Strigoides@gmail.com>
Sat, 4 May 2013 05:58:20 +0000 (17:58 +1200)
jscl.html
jscl.lisp
src/compiler.lisp
src/ffi.lisp [new file with mode: 0644]
src/package.lisp
src/prelude.js
src/read.lisp

index 782db20..47b4efb 100644 (file)
--- a/jscl.html
+++ b/jscl.html
 
         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;
             }
index e49e696..9a89a5d 100644 (file)
--- a/jscl.lisp
+++ b/jscl.lisp
@@ -24,6 +24,7 @@
     ("string"    :target)
     ("print"     :target)
     ("package"   :target)
+    ("ffi"       :target)
     ("read"      :both)
     ("compiler"  :both)
     ("toplevel"  :target)))
index aa2f821..7d92b9e 100644 (file)
   #+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)
diff --git a/src/ffi.lisp b/src/ffi.lisp
new file mode 100644 (file)
index 0000000..6dd8418
--- /dev/null
@@ -0,0 +1,36 @@
+;;; 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)
index 5745d07..b16e9bb 100644 (file)
@@ -62,9 +62,6 @@
 (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)))))))
 
index ca5cfdb..6f5feea 100644 (file)
@@ -61,3 +61,38 @@ function make_lisp_string (string){
 
 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;
+}
index bcc5bac..4116bb6 100644 (file)
       (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))