Simplify literal object dumping

[jscl.git] / src / boot.lisp

diff --git a/src/boot.lisp b/src/boot.lisp
index 2dca3a8..2149308 100644 (file)
--- a/src/boot.lisp
+++ b/src/boot.lisp
@@ -16,11 +16,11 @@
 ;; You should have received a copy of the GNU General Public License
 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 
-;;; This code is executed when ecmalisp compiles this file
-;;; itself. The compiler provides compilation of some special forms,
-;;; as well as funcalls and macroexpansion, but no functions. So, we
-;;; define the Lisp world from scratch. This code has to define enough
-;;; language to the compiler to be able to run.
+;;; This code is executed when JSCL compiles this file itself. The
+;;; compiler provides compilation of some special forms, as well as
+;;; funcalls and macroexpansion, but no functions. So, we define the
+;;; Lisp world from scratch. This code has to define enough language
+;;; to the compiler to be able to run.
 
 (eval-when-compile
   (%compile-defmacro 'defmacro
@@ -120,7 +120,9 @@
 (defun 1+ (x) (+ x 1))
 (defun 1- (x) (- x 1))
 (defun zerop (x) (= x 0))
-(defun truncate (x y) (floor (/ x y)))
+
+(defun truncate (x &optional (y 1))
+  (floor (/ x y)))
 
 (defun eql (x y) (eq x y))
 
@@ -154,11 +156,25 @@
 
 ;; Basic macros
 
-(defmacro incf (x &optional (delta 1))
-  `(setq ,x (+ ,x ,delta)))
+(defmacro incf (place &optional (delta 1))
+  (multiple-value-bind (dummies vals newval setter getter)
+      (get-setf-expansion place)
+    (let ((d (gensym)))
+      `(let* (,@(mapcar #'list dummies vals)
+              (,d ,delta)
+                (,(car newval) (+ ,getter ,d))
+                ,@(cdr newval))
+         ,setter))))
 
-(defmacro decf (x &optional (delta 1))
-  `(setq ,x (- ,x ,delta)))
+(defmacro decf (place &optional (delta 1))
+  (multiple-value-bind (dummies vals newval setter getter)
+      (get-setf-expansion place)
+    (let ((d (gensym)))
+      `(let* (,@(mapcar #'list dummies vals)
+              (,d ,delta)
+              (,(car newval) (- ,getter ,d))
+              ,@(cdr newval))
+         ,setter))))
 
 (defmacro push (x place)
   (multiple-value-bind (dummies vals newval setter getter)
@@ -197,12 +213,16 @@
 
 (defmacro cond (&rest clausules)
   (if (null clausules)
-      nil
-      (if (eq (caar clausules) t)
-          `(progn ,@(cdar clausules))
-          `(if ,(caar clausules)
-               (progn ,@(cdar clausules))
-               (cond ,@(cdr clausules))))))
+    nil
+    (if (eq (caar clausules) t)
+      `(progn ,@(cdar clausules))
+      (let ((test-symbol (gensym)))
+        `(let ((,test-symbol ,(caar clausules)))
+           (if ,test-symbol
+             ,(if (null (cdar clausules))
+                test-symbol
+                `(progn ,@(cdar clausules)))
+             (cond ,@(cdr clausules))))))))
 
 (defmacro case (form &rest clausules)
   (let ((!form (gensym)))
@@ -659,7 +679,9 @@
                          `((,(ecase (car c)
                                     (integer 'integerp)
                                     (cons 'consp)
+                                    (symbol 'symbolp)
                                     (string 'stringp)
+                                    (array 'arrayp)
                                     (atom 'atom)
                                     (null 'null))
                              ,value)
@@ -845,6 +867,15 @@
     (dolist (symb symbols t)
       (oset exports (symbol-name symb) symb))))
 
+
+(defconstant internal-time-units-per-second 1000) 
+
+(defun get-internal-real-time ()
+  (get-internal-real-time))
+
+(defun get-unix-time ()
+  (truncate (/ (get-internal-real-time) 1000)))
+
 (defun get-universal-time ()
   (+ (get-unix-time) 2208988800))