concat-two primitive function offered

[jscl.git] / lispstrack.lisp

diff --git a/lispstrack.lisp b/lispstrack.lisp
index 8620bf3..98f7bc0 100644 (file)
--- a/lispstrack.lisp
+++ b/lispstrack.lisp
@@ -29,12 +29,15 @@
                         `(eval-when-compile
                            (%compile-defmacro ',name '(lambda ,args ,@body))))))
 
- (defmacro defvar (name value)
+ (defmacro %defvar (name value)
    `(progn
       (eval-when-compile
         (%compile-defvar ',name))
       (setq ,name ,value)))
 
+  (defmacro defvar (name value)
+    `(%defvar ,name ,value))
+
  (defmacro %defun (name args &rest body)
    `(progn
       (eval-when-compile
@@ -135,6 +138,11 @@
        (%defun ,name ,args ,@body)
        ',name))
 
+  (defmacro defvar (name value)
+    `(progn
+       (%defvar ,name ,value)
+       ',name))
+
   (defun append-two (list1 list2)
     (if (null list1)
         list2
@@ -170,6 +178,9 @@
         (string-length seq)
         (list-length seq)))
 
+  (defun concat-two (s1 s2)
+    (concat-two s1 s2))
+
   (defun mapcar (func list)
     (if (null list)
         '()
@@ -241,6 +252,9 @@
   (defun <= (x y) (or (< x y) (= x y)))
   (defun >= (x y) (not (< x y)))
 
+  (defun plusp (x) (< 0 x))
+  (defun minusp (x) (< x 0))
+
   (defun listp (x)
     (or (consp x) (null x)))
 
@@ -365,9 +379,7 @@
 (defvar *newline* (string (code-char 10)))
 
 (defun concat (&rest strs)
-  (!reduce (lambda (s1 s2) (concat-two s1 s2))
-           strs
-           ""))
+  (!reduce #'concat-two strs ""))
 
 ;;; Concatenate a list of strings, with a separator
 (defun join (list separator)
@@ -397,6 +409,17 @@
                       digits)
               ""))))
 
+(defun print-to-string (form)
+  (cond
+    ((symbolp form) (symbol-name form))
+    ((integerp form) (integer-to-string form))
+    ((stringp form) (concat "\"" (escape-string form) "\""))
+    ((functionp form) (concat "#<FUNCTION>"))
+    ((listp form)
+     (concat "("
+             (join (mapcar #'print-to-string form)
+                   " ")
+             ")"))))
 
 ;;;; Reader
 
@@ -623,11 +646,13 @@
 
 (defun ls-compile-block (sexps env fenv)
   (join-trailing
-   (remove nil (mapcar (lambda (x)
-                         (ls-compile x env fenv))
-                       sexps))
-                 ";
-"))
+   (remove (lambda (x)
+             (or (null x)
+                 (and (stringp x)
+                      (zerop (length x)))))
+           (mapcar (lambda (x) (ls-compile x env fenv))  sexps))
+   (concat ";" *newline*)))
+
 (defmacro define-compilation (name args &rest body)
   ;; Creates a new primitive `name' with parameters args and
   ;; @body. The body can access to the local environment through the
@@ -746,7 +771,7 @@
 
 (define-compilation eval-when-compile (&rest body)
   (eval (cons 'progn body))
-  nil)
+  "")
 
 (defmacro define-transformation (name args form)
   `(define-compilation ,name ,args
@@ -963,6 +988,11 @@
   (compile-bool
    (concat "(" (ls-compile key env fenv) " in " (ls-compile object env fenv) ")")))
 
+(define-compilation functionp (x)
+  (compile-bool
+   (concat "(typeof " (ls-compile x env fenv) " == 'function')")))
+
+
 (defun macrop (x)
   (and (symbolp x) (eq (binding-type (lookup-function x *fenv*)) 'macro)))
 
@@ -1007,8 +1037,7 @@
   (setq *toplevel-compilations* nil)
   (let ((code (ls-compile sexp nil nil)))
     (prog1
-        (concat  #+common-lisp (concat "/* " (princ-to-string sexp) " */")
-                (join (mapcar (lambda (x) (concat x ";" *newline*))
+        (concat (join (mapcar (lambda (x) (concat x ";" *newline*))
                               *toplevel-compilations*)
                "")
                 code)
@@ -1051,6 +1080,7 @@
  (js-eval
   (concat "var lisp = {};"
           "lisp.read = " (lookup-function-translation 'ls-read-from-string nil) ";" *newline*
+          "lisp.print = " (lookup-function-translation 'print-to-string nil) ";" *newline*
           "lisp.eval = " (lookup-function-translation 'eval nil) ";" *newline*
           "lisp.compile = " (lookup-function-translation 'ls-compile-toplevel nil) ";" *newline*
           "lisp.evalString = function(str){" *newline*