Define get-internal-real-time

diff --git a/src/boot.lisp b/src/boot.lisp
index 0fc7a40..40ae705 100644 (file)
--- a/src/boot.lisp
+++ b/src/boot.lisp
@@ -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))
 
@@ -859,6 +861,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))
 

diff --git a/src/compiler.lisp b/src/compiler.lisp
index 171e0c8..961d3a0 100644 (file)
--- a/src/compiler.lisp
+++ b/src/compiler.lisp
@@ -1536,8 +1536,8 @@
     "if (i < 0 || i >= x.length) throw 'Out of range';" *newline*
     "return x[i] = " value ";" *newline*))
 
-(define-builtin get-unix-time ()
-  (code "(Math.round(new Date() / 1000))"))
+(define-builtin get-internal-real-time ()
+  "(new Date()).getTime()")
 
 (define-builtin values-array (array)
   (if *multiple-value-p*

diff --git a/src/toplevel.lisp b/src/toplevel.lisp
index 1167cfb..82e02c5 100644 (file)
--- a/src/toplevel.lisp
+++ b/src/toplevel.lisp
@@ -55,9 +55,9 @@
           digit-char digit-char-p disassemble do do* documentation
           dolist dotimes ecase eq eql equal error eval every export expt
           fdefinition find-package find-symbol first flet fourth fset
-          funcall function functionp gensym get-setf-expansion
-          get-universal-time go identity if in-package incf integerp
-          intern keywordp labels lambda last length let let* list
+          funcall function functionp gensym get-internal-real-time
+          get-setf-expansion get-universal-time go identity if in-package
+          incf integerp intern keywordp labels lambda last length let let* list
           list* list-all-packages listp loop make-array make-package
           make-symbol mapcar member minusp mod multiple-value-bind
           multiple-value-call multiple-value-list multiple-value-prog1