Fix spacing in !parse-integer

[jscl.git] / ecmalisp.lisp

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 8b1dcd5..21ef044 100644 (file)
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -163,7 +163,14 @@
     `(setq ,x (- ,x ,delta)))
 
   (defmacro push (x place)
     `(setq ,x (- ,x ,delta)))
 
   (defmacro push (x place)

-    `(setq ,place (cons ,x ,place)))
+    (multiple-value-bind (dummies vals newval setter getter)
+        (get-setf-expansion place)
+      (let ((g (gensym)))
+        `(let* ((,g ,x)
+                ,@(mapcar #'list dummies vals)
+                (,(car newval) (cons ,g ,getter))
+                ,@(cdr newval))
+           ,setter))))

 
   (defmacro dolist (iter &body body)
     (let ((var (first iter))
 
   (defmacro dolist (iter &body body)
     (let ((var (first iter))

@@ -466,6 +473,7 @@
       ((funcall func (car list))
        (remove-if func (cdr list)))
       (t
       ((funcall func (car list))
        (remove-if func (cdr list)))
       (t

+       ;;

        (cons (car list) (remove-if func (cdr list))))))
 
   (defun remove-if-not (func list)
        (cons (car list) (remove-if func (cdr list))))))
 
   (defun remove-if-not (func list)

@@ -495,39 +503,43 @@
       (t
        (error "Unsupported argument."))))
 
       (t
        (error "Unsupported argument."))))
 

+  (defmacro do-sequence (iteration &body body)
+    (let ((seq (gensym))
+          (index (gensym)))
+      `(let ((,seq ,(second iteration)))
+         (cond
+           ;; Strings
+           ((stringp ,seq)
+            (let ((,index 0))
+              (dotimes (,index (length ,seq))
+                (let ((,(first iteration)
+                       (char ,seq ,index)))
+                  ,@body))))
+           ;; Lists
+           ((listp ,seq)
+            (dolist (,(first iteration) ,seq)
+              ,@body))
+           (t
+            (error "type-error!"))))))
+

   (defun some (function seq)
   (defun some (function seq)

-    (cond
-      ((stringp seq)
-       (let ((index 0)
-             (size (length seq)))
-         (while (< index size)
-           (when (funcall function (char seq index))
-             (return-from some t))
-           (incf index))
-         nil))
-      ((listp seq)
-       (dolist (x seq nil)
-         (when (funcall function x)
-           (return t))))
-      (t
-       (error "Unknown sequence."))))
+    (do-sequence (elt seq)
+      (when (funcall function elt)
+        (return-from some t))))

 
   (defun every (function seq)
 
   (defun every (function seq)

-    (cond
-      ((stringp seq)
-       (let ((index 0)
-             (size (length seq)))
-         (while (< index size)
-           (unless (funcall function (char seq index))
-             (return-from every nil))
-           (incf index))
-         t))
-      ((listp seq)
-       (dolist (x seq t)
-         (unless (funcall function x)
-           (return))))
-      (t
-       (error "Unknown sequence."))))
+    (do-sequence (elt seq)
+      (unless (funcall function elt)
+        (return-from every nil)))
+    t)
+
+  (defun position (elt sequence)
+    (let ((pos 0))
+      (do-sequence (x seq)
+        (when (eq elt x)
+          (return))
+        (incf pos))
+      pos))

 
   (defun assoc (x alist)
     (while alist
 
   (defun assoc (x alist)
     (while alist

@@ -645,17 +657,6 @@
               `(progn (rplacd ,cons ,new-value) ,new-value)
               `(car ,cons))))
 
               `(progn (rplacd ,cons ,new-value) ,new-value)
               `(car ,cons))))
 

-<<<<<<< HEAD
-  (defmacro push (x place)
-    (multiple-value-bind (dummies vals newval setter getter)
-        (get-setf-expansion place)
-      (let ((g (gensym)))
-        `(let* ((,g ,x)
-                ,@(mapcar #'list dummies vals)
-                (,(car newval) (cons ,g ,getter))
-                ,@(cdr newval))
-           ,setter))))
-=======

   ;; Incorrect typecase, but used in NCONC.
   (defmacro typecase (x &rest clausules)
     (let ((value (gensym)))
   ;; Incorrect typecase, but used in NCONC.
   (defmacro typecase (x &rest clausules)
     (let ((value (gensym)))

@@ -705,15 +706,14 @@
 
   (defun nreconc (x y)
     (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))
 
   (defun nreconc (x y)
     (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))

-         (2nd x 1st) ; 2nd follows first down the list.
-         (3rd y 2nd)) ;3rd follows 2nd down the list.
+         (2nd x 1st)                ; 2nd follows first down the list.
+         (3rd y 2nd))               ;3rd follows 2nd down the list.

         ((atom 2nd) 3rd)
       (rplacd 2nd 3rd)))
 
   (defun notany (fn seq)
     (not (some fn seq)))
 
         ((atom 2nd) 3rd)
       (rplacd 2nd 3rd)))
 
   (defun notany (fn seq)
     (not (some fn seq)))
 

->>>>>>> backquote

 
   ;; Packages
 
 
   ;; Packages
 

@@ -962,9 +962,13 @@
                      (concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last)))))
                ")"))
       ((arrayp form)
                      (concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last)))))
                ")"))
       ((arrayp form)

-       (concat "#" (prin1-to-string (vector-to-list form))))
+       (concat "#" (if (zerop (length form))
+                       "()"
+                       (prin1-to-string (vector-to-list form)))))

       ((packagep form)
       ((packagep form)

-       (concat "#<PACKAGE " (package-name form) ">"))))
+       (concat "#<PACKAGE " (package-name form) ">"))
+      (t
+       (concat "#<javascript object>"))))

 
   (defun write-line (x)
     (write-string x)
 
   (defun write-line (x)
     (write-string x)

@@ -1128,31 +1132,31 @@
 (defun !parse-integer (string junk-allow)
   (block nil
     (let ((value 0)
 (defun !parse-integer (string junk-allow)
   (block nil
     (let ((value 0)

-         (index 0)
-         (size (length string))
-         (sign 1))
+          (index 0)
+          (size (length string))
+          (sign 1))

       (when (zerop size) (return (values nil 0)))
       ;; Optional sign
       (case (char string 0)
       (when (zerop size) (return (values nil 0)))
       ;; Optional sign
       (case (char string 0)

-       (#\+ (incf index))
-       (#\- (setq sign -1)
-            (incf index)))
+        (#\+ (incf index))
+        (#\- (setq sign -1)
+             (incf index)))

       ;; First digit
       (unless (and (< index size)
       ;; First digit
       (unless (and (< index size)

-                  (setq value (digit-char-p (char string index))))
-       (return (values nil index)))
+                   (setq value (digit-char-p (char string index))))
+        (return (values nil index)))

       (incf index)
       ;; Other digits
       (while (< index size)
       (incf index)
       ;; Other digits
       (while (< index size)

-       (let ((digit (digit-char-p (char string index))))
-         (unless digit (return))
-         (setq value (+ (* value 10) digit))
-         (incf index)))
+        (let ((digit (digit-char-p (char string index))))
+          (unless digit (return))
+          (setq value (+ (* value 10) digit))
+          (incf index)))

       (if (or junk-allow
       (if (or junk-allow

-             (= index size)
-             (char= (char string index) #\space))
-         (values (* sign value) index)
-         (values nil index)))))
+              (= index size)
+              (char= (char string index) #\space))
+          (values (* sign value) index)
+          (values nil index)))))

 
 #+ecmalisp
 (defun parse-integer (string)
 
 #+ecmalisp
 (defun parse-integer (string)

@@ -2718,6 +2722,15 @@
       (t
        (error (concat "How should I compile " (prin1-to-string sexp) "?"))))))
 
       (t
        (error (concat "How should I compile " (prin1-to-string sexp) "?"))))))
 

+
+(defvar *compile-print-toplevels* nil)
+
+(defun truncate-string (string &optional (width 60))
+    (let ((size (length string))
+          (n (or (position #\newline string)
+                 (min width (length string)))))
+      (subseq string 0 n)))
+

 (defun ls-compile-toplevel (sexp &optional multiple-value-p)
   (let ((*toplevel-compilations* nil))
     (cond
 (defun ls-compile-toplevel (sexp &optional multiple-value-p)
   (let ((*toplevel-compilations* nil))
     (cond

@@ -2727,6 +2740,12 @@
                            (cdr sexp))))
          (join (remove-if #'null-or-empty-p subs))))
       (t
                            (cdr sexp))))
          (join (remove-if #'null-or-empty-p subs))))
       (t

+       (when *compile-print-toplevels*
+         (let ((form-string (prin1-to-string sexp)))
+           (write-string "Compiling ")
+           (write-string (truncate-string form-string))
+           (write-line "...")))
+       

        (let ((code (ls-compile sexp multiple-value-p)))
          (code (join-trailing (get-toplevel-compilations)
                               (code ";" *newline*))
        (let ((code (ls-compile sexp multiple-value-p)))
          (code (join-trailing (get-toplevel-compilations)
                               (code ";" *newline*))

@@ -2810,8 +2829,9 @@
         (read-sequence seq in)
         seq)))
 
         (read-sequence seq in)
         seq)))
 

-  (defun ls-compile-file (filename output)
-    (let ((*compiling-file* t))
+  (defun ls-compile-file (filename output &key print)
+    (let ((*compiling-file* t)
+          (*compile-print-toplevels* print))

       (with-open-file (out output :direction :output :if-exists :supersede)
         (write-string (read-whole-file "prelude.js") out)
         (let* ((source (read-whole-file filename))
       (with-open-file (out output :direction :output :if-exists :supersede)
         (write-string (read-whole-file "prelude.js") out)
         (let* ((source (read-whole-file filename))

@@ -2830,4 +2850,4 @@
           *gensym-counter* 0
           *literal-counter* 0
           *block-counter* 0)
           *gensym-counter* 0
           *literal-counter* 0
           *block-counter* 0)

-    (ls-compile-file "ecmalisp.lisp" "ecmalisp.js")))
+    (ls-compile-file "ecmalisp.lisp" "ecmalisp.js" :print t)))