Time related extensions and one small bugfix

From: Frank Ridderbusch <ridderbusch.pad_at_sni.de>
Date: Fri, 26 Aug 94 21:27:14 MET

I've extended STk with three time related functions. These functions
are also found in Scheme interpreter SCM from Aubrey Jaffer. The code
is directly transposed from SCM (why invent new functions?).

The change in tcl-lib.c is a small bugfix. The original code alway
caused segmentation faults, when invoking a button with noexistent
command.

Changes are relativ to 2.1.1.

===================================================================
RCS file: RCS/primitives.c,v
retrieving revision 1.1
diff -u -r1.1 primitives.c
--- 1.1 1994/08/07 20:02:45
+++ primitives.c 1994/08/07 21:20:06
_at_@ -374,6 +374,9 @@
   {"quit", tc_subr_0_or_1, quit_interpreter}, /* + */
   {"exit", tc_subr_0_or_1, quit_interpreter}, /* + */
   {"bye", tc_subr_0_or_1, quit_interpreter}, /* + */
+ {"get-universal-time", tc_subr_0, lget_univ_time}, /* + */
+ {"get-decoded-time", tc_subr_0, ldcdtime}, /* + */
+ {"decode-universal-time", tc_subr_1, ldcdunivtime}, /* + */
 
 #ifdef USE_TK
   {"trace-var", tc_subr_2, ltrace_var}, /* + */
===================================================================
RCS file: RCS/tcl-lib.c,v
retrieving revision 1.1
diff -u -r1.1 tcl-lib.c
--- 1.1 1994/08/17 19:36:31
+++ tcl-lib.c 1994/08/17 19:37:35
_at_@ -362,8 +362,8 @@
       (void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE",
                          TCL_GLOBAL_ONLY);
     }
+ free(p);
   }
- free(p);
 
   p = STk_Stringify(message, 0);
   Tcl_SetVar2(interp,"errorInfo",(char *)NULL,p+1,TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
===================================================================
RCS file: RCS/unix.c,v
retrieving revision 1.1
diff -u -r1.1 unix.c
--- 1.1 1994/08/07 19:59:09
+++ unix.c 1994/08/08 11:49:46
_at_@ -25,6 +25,7 @@
 #include <unistd.h>
 #include <sys/types.h>
 #include <sys/stat.h>
+#include <time.h>
 #include "stk.h"
 
 #ifdef __linux__
_at_@ -178,4 +179,48 @@
   if (NSTRINGP(str)) err("getenv: not a string", str);
   tmp = getenv(CHARS(str));
   return tmp ? makestrg(strlen(tmp), tmp) : ntruth;
+}
+
+PRIMITIVE lget_univ_time(void)
+{
+ time_t timev = time((time_t *) 0);
+ timev = mktime(gmtime(&timev));
+ return makeinteger(timev);
+}
+
+PRIMITIVE ldcdtime(void)
+{
+ int i = sizeof(struct tm)/sizeof(int);
+ SCM ans = makevect(i, NULL);
+ time_t timev = time((time_t *) 0);
+ struct tm *tmpptr = localtime(&timev);
+ while(i--)
+ VECT(ans)[i] = makeinteger(((int *)tmpptr)[i]);
+ return ans;
+}
+
+PRIMITIVE ldcdunivtime(SCM ut)
+{
+ char *s;
+ time_t timev;
+
+ if (NINTEGERP(ut) && NBIGNUMP(ut))
+ err("decode-universal-time: bad time", ut);
+
+ if (BIGNUM(ut)) {
+ s= mpz_get_str(NULL, 10, BIGNUM(ut));
+ timev = atol(s);
+ }
+ else {
+ timev=integer_value(ut);
+ }
+
+ {
+ int i = sizeof(struct tm)/sizeof(int);
+ SCM ans = makevect(i, NULL);
+ struct tm *tmpptr = localtime(&timev);
+ while(i--)
+ VECT(ans)[i] = makeinteger(((int *)tmpptr)[i]);
+ return ans;
+ }
 }
===================================================================
RCS file: RCS/unix.h,v
retrieving revision 1.1
diff -u -r1.1 unix.h
--- 1.1 1994/08/07 20:06:24
+++ unix.h 1994/08/07 21:19:06
_at_@ -32,3 +32,6 @@
 PRIMITIVE lgetpid(void);
 PRIMITIVE lsystem(SCM com);
 PRIMITIVE lgetenv(SCM str);
+PRIMITIVE lget_univ_time(void);
+PRIMITIVE ldcdtime(void);
+PRIMITIVE ldcdunivtime(SCM ut);

-- 
MfG/Regards
     /====                          Siemens Nixdorf Informationssysteme AG
    /    Ridderbusch        / ,    Abt.: SU MR PD 251
   /                       /./    Heinz Nixdorf Ring
  /=== /,== ,===/  /,==,  //     33106 Paderborn, Germany
 /    //   /   /  //   / / \    Tel.: (49) 05251-8-15211
/    /     `==/\ /    / /   \  NERV:ridderbusch.pad
Email: ridderbusch.pad_at_sni-usa.com (America (North & South))
       ridderbusch.pad_at_sni.de      (Rest of world)
       

Received on Fri Aug 26 1994 - 21:29:28 CEST