scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Decigged time.

This commit is contained in:
mainzelm 2001-09-07 12:36:30 +00:00
parent 4fbf89f9bb
commit 9f119a5ef7
4 changed files with 127 additions and 196 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
scsh/time.c
View File

@ -1,74 +0,0 @@
/* This is an Scheme48/C interface file,
** automatically generated by a hacked version of cig 3.0.
step 4
*/
#include <stdio.h>
#include <stdlib.h> /* For malloc. */
#include "libcig.h"
#include "time1.h"
s48_value df_time2date(s48_value g1, s48_value g2, s48_value mv_vec)
{
extern s48_value time2date(time_t , s48_value , int *, int *, int *, int *, int *, int *, const char **, int *, int *, int *, int *);
s48_value ret1 = S48_FALSE;
S48_DECLARE_GC_PROTECT(2);
s48_value r1;
int r2 = 0;
int r3 = 0;
int r4 = 0;
int r5 = 0;
int r6 = 0;
int r7 = 0;
const char *r8 = 0;
int r9 = 0;
int r10 = 0;
int r11 = 0;
int r12 = 0;
S48_GC_PROTECT_2(mv_vec,ret1);
r1 = time2date(s48_extract_integer(g1), g2, &r2, &r3, &r4, &r5, &r6, &r7, &r8, &r9, &r10, &r11, &r12);
ret1 = r1;
S48_VECTOR_SET(mv_vec,0,s48_enter_fixnum(r2));
S48_VECTOR_SET(mv_vec,1,s48_enter_fixnum(r3));
S48_VECTOR_SET(mv_vec,2,s48_enter_fixnum(r4));
S48_VECTOR_SET(mv_vec,3,s48_enter_fixnum(r5));
S48_VECTOR_SET(mv_vec,4,s48_enter_fixnum(r6));
S48_VECTOR_SET(mv_vec,5,s48_enter_fixnum(r7));
SetAlienVal(S48_CAR(S48_VECTOR_REF(mv_vec,6)),(long) r8); S48_SET_CDR(S48_VECTOR_REF(mv_vec,6),strlen_or_false(r8));//str-and-len
S48_VECTOR_SET(mv_vec,7,s48_enter_fixnum(r9));
S48_VECTOR_SET(mv_vec,8,ENTER_BOOLEAN(r10));
S48_VECTOR_SET(mv_vec,9,s48_enter_fixnum(r11));
S48_VECTOR_SET(mv_vec,10,s48_enter_fixnum(r12));
S48_GC_UNPROTECT();
return ret1;
}
s48_value df_format_date(s48_value g1, s48_value g2, s48_value g3, s48_value g4, s48_value g5, s48_value g6, s48_value g7, s48_value g8, s48_value g9, s48_value g10, s48_value g11, s48_value mv_vec)
{
extern s48_value format_date(const char *, int , int , int , int , int , int , s48_value , int , int , int , const char **);
s48_value ret1 = S48_FALSE;
S48_DECLARE_GC_PROTECT(2);
s48_value r1;
const char *r2 = 0;
S48_GC_PROTECT_2(mv_vec,ret1);
r1 = format_date(s48_extract_string(g1), s48_extract_fixnum(g2), s48_extract_fixnum(g3), s48_extract_fixnum(g4), s48_extract_fixnum(g5), s48_extract_fixnum(g6), s48_extract_fixnum(g7), g8, EXTRACT_BOOLEAN(g9), s48_extract_fixnum(g10), s48_extract_fixnum(g11), &r2);
ret1 = r1;
SetAlienVal(S48_CAR(S48_VECTOR_REF(mv_vec,0)),(long) r2); S48_SET_CDR(S48_VECTOR_REF(mv_vec,0),strlen_or_false(r2));//str-and-len
S48_GC_UNPROTECT();
return ret1;
}
void s48_init_time(void)
{
S48_EXPORT_FUNCTION(time_plus_ticks);
S48_EXPORT_FUNCTION(scheme_time);
S48_EXPORT_FUNCTION(date2time);
S48_EXPORT_FUNCTION(df_time2date);
S48_EXPORT_FUNCTION(df_format_date);
}

70
scsh/time.scm
View File

@ -10,11 +10,6 @@
;;; - If tz-name not defined, fabbed from tz-secs. ;;; - If tz-name not defined, fabbed from tz-secs.
;;; - If tz-secs not defined, filled in from tz-name. ;;; - If tz-secs not defined, filled in from tz-name.
(foreign-init-name "time")
(foreign-source "#include \"time1.h\"" ; Import the time1.h interface.
"")
;;; A TIME is an instant in the history of the universe; it is location ;;; A TIME is an instant in the history of the universe; it is location
;;; independent, barring relativistic effects. It is measured as the ;;; independent, barring relativistic effects. It is measured as the
;;; number of seconds elapsed since "epoch" -- January 1, 1970 UTC. ;;; number of seconds elapsed since "epoch" -- January 1, 1970 UTC.
@ -98,7 +93,8 @@
; C fun is OS-dependent ; C fun is OS-dependent
; TODO: all C files are identical, so move it to time1.c ; TODO: all C files are identical, so move it to time1.c
; returns (list secs ticks) ; returns (list secs ticks)
(define-stubless-foreign %time+ticks () "time_plus_ticks") (define-stubless-foreign %time+ticks/eintr () "time_plus_ticks")
(define-retrying-syscall %time+ticks %time+ticks/eintr)
(define (time+ticks) (define (time+ticks)
(apply values (%time+ticks))) (apply values (%time+ticks)))
@ -106,12 +102,15 @@
(define (time+ticks->time secs ticks) (define (time+ticks->time secs ticks)
(+ secs (/ ticks (ticks/sec)))) (+ secs (/ ticks (ticks/sec))))
(define-stubless-foreign %time () "scheme_time") (define-stubless-foreign %time/eintr () "scheme_time")
(define-retrying-syscall %time %time/eintr)
(define-stubless-foreign %date->time (sec min hour month-day month year (define-stubless-foreign %date->time/eintr
(sec min hour month-day month year
tz-name ; #f or string tz-name ; #f or string
tz-secs ; #f or int tz-secs ; #f or int
summer?) "date2time") summer?) "date2time")
(define-retrying-syscall %date->time %date->time/eintr)
(define (time . args) ; optional arg [date] (define (time . args) ; optional arg [date]
(if (pair? args) (if (pair? args)
@ -132,21 +131,8 @@
;;; Date ;;; Date
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-foreign %time->date (time2date (time_t time-hi) (define-stubless-foreign %time->date/eintr (time zone) "time2date")
(desc zone)) (define-retrying-syscall %time->date %time->date/eintr)
desc ; errno or #f
fixnum ; seconds
fixnum ; minute
fixnum ; hour
fixnum ; month-day
fixnum ; month
fixnum ; year
string ; tz-name (#f if we need to make it from tz-secs)
fixnum ; tz-secs
bool ; summer?
fixnum ; week-day
fixnum) ; year-day
(define (date . args) ; Optional args [time zone] (define (date . args) ; Optional args [time zone]
(let ((time (if (pair? args) (let ((time (if (pair? args)
@ -155,17 +141,14 @@
(zone (check-arg time-zone? (zone (check-arg time-zone?
(and (pair? args) (:optional (cdr args) #f)) (and (pair? args) (:optional (cdr args) #f))
date))) date)))
(let lp () (apply
(receive (err seconds minute hour month-day month (lambda (seconds minute hour month-day month
year tz-name tz-secs summer? week-day year-day) year tz-name tz-secs summer? week-day year-day)
(%time->date time zone)
(cond ((not err)
(make-%date seconds minute hour month-day month (make-%date seconds minute hour month-day month
year year
(format-time-zone (or tz-name "UTC") tz-secs) (format-time-zone (or tz-name "UTC") tz-secs)
tz-secs summer? week-day year-day)) tz-secs summer? week-day year-day))
((= errno/intr err) (lp)) (%time->date time zone))))
(errno-error err date time zone))))))
;;; Formatting date strings ;;; Formatting date strings
@ -176,8 +159,8 @@
(define (format-date fmt date) (define (format-date fmt date)
(check-arg date? date format-date) (check-arg date? date format-date)
(receive (err result) (let ((result
(%format-date/errno fmt (%format-date fmt
(date:seconds date) (date:seconds date)
(date:minute date) (date:minute date)
(date:hour date) (date:hour date)
@ -189,24 +172,15 @@
(deintegerize-time-zone (date:tz-secs date))) (deintegerize-time-zone (date:tz-secs date)))
(date:summer? date) (date:summer? date)
(date:week-day date) (date:week-day date)
(date:year-day date)) (date:year-day date))))
(cond ((not err) result) (cond ((not result) (error "~ without argument in format-date" fmt))
((= errno/intr err) (format-date fmt date)) (else result))))
(else (errno-error err format-date fmt date)))))
(define-foreign %format-date/errno (format_date (string fmt) (define-stubless-foreign %format-date/eintr
(fixnum seconds) (fmt seconds minute hour month-day month year tz-name summer? week-day
(fixnum minute) year-day)
(fixnum hour) "format_date")
(fixnum month-day) (define-retrying-syscall %format-date %format-date/eintr)
(fixnum month)
(fixnum year)
(desc tz-name)
(bool summer?)
(fixnum week-day)
(fixnum year-day))
desc ; false or errno
string)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

119
scsh/time1.c
View File

@ -2,12 +2,7 @@
** Copyright (c) 1994 by Olin Shivers. ** Copyright (c) 1994 by Olin Shivers.
*/ */
/* WARNING: THIS FILE HAS CODE THAT DEPENDS ON 32-BIT ARCHITECTURES. /* The source code is conditionalised by three #ifdef feature macros:
** This code is so marked.
** JMG: should have disappeard since cig now supports time_t via
** s48_{enter,extract}_integer which is mapped to a bignum by need
**
** The source code is also conditionalised by three #ifdef feature macros:
** HAVE_TZNAME ** HAVE_TZNAME
** The char *tzname[2] global variable is POSIX. Everyone provides ** The char *tzname[2] global variable is POSIX. Everyone provides
** it...except some "classic" versions of SunOS that we still care about ** it...except some "classic" versions of SunOS that we still care about
@ -118,34 +113,51 @@ s48_value scheme_time()
return s48_enter_integer (t); return s48_enter_integer (t);
} }
// should be part of the FFI interface
s48_value s48_list_11 (s48_value e1, s48_value e2, s48_value e3,
s48_value e4, s48_value e5, s48_value e6,
s48_value e7, s48_value e8, s48_value e9,
s48_value e10, s48_value e11)
{
return
s48_cons (e1, s48_cons (e2, s48_cons (e3, s48_cons (e4, s48_cons
(e5, s48_cons (e6, s48_cons (e7, s48_cons (e8, s48_cons (e9,
s48_cons (e10, s48_cons (e11, S48_NULL)))))))))));
}
/* Zone: /* Zone:
** #f Local time ** #f Local time
** int Offset from GMT in seconds. ** int Offset from GMT in seconds.
** string Time zone understood by OS. ** string Time zone understood by OS.
*/ */
s48_value time2date(time_t t, s48_value zone, s48_value time2date(s48_value sch_t, s48_value sch_zone)
int *sec, int *min, int *hour, /* int *sec, int *min, int *hour,
int *mday, int *month, int *year, int *mday, int *month, int *year,
const char **tz_name, int *tz_secs, const char **tz_name, int *tz_secs,
int *summer, int *summer,
int *wday, int *yday) int *wday, int *yday)
*/
{ {
struct tm d; struct tm d;
time_t t = s48_extract_integer(sch_t);
s48_value sch_tz_name = S48_UNSPECIFIC;
s48_value sch_tz_secs = S48_UNSPECIFIC;
if( S48_FIXNUM_P(zone) ) { /* Offset from GMT in secs. */ if( S48_FIXNUM_P(sch_zone) ) { /* Offset from GMT in secs. */
int offset = s48_extract_fixnum(zone); int offset = s48_extract_fixnum(sch_zone);
t += s48_extract_fixnum(zone); t += s48_extract_fixnum(sch_zone);
d = *gmtime(&t); d = *gmtime(&t);
*tz_name = NULL; sch_tz_name = s48_enter_string("");
*tz_secs = offset; sch_tz_secs = s48_enter_fixnum (offset);
} }
else { else {
char *newenv[2], **oldenv = NULL; char *newenv[2], **oldenv = NULL;
if( S48_STRING_P(zone) ) { /* Time zone */ if( S48_STRING_P(sch_zone) ) { /* Time zone */
oldenv = make_newenv(zone, newenv); /* Install new TZ. */ oldenv = make_newenv(sch_zone, newenv); /* Install new TZ. */
if( !oldenv ) return s48_enter_fixnum(errno); /* Error installing. */ if( !oldenv ) s48_raise_os_error_2(errno, sch_t, sch_zone);
d = *localtime(&t); /* Do it. */ d = *localtime(&t); /* Do it. */
} }
else /* Local time */ else /* Local time */
@ -168,37 +180,44 @@ s48_value time2date(time_t t, s48_value zone,
char *zone = tzname[d.tm_isdst]; char *zone = tzname[d.tm_isdst];
#endif #endif
char *newzone = Malloc(char, 1+strlen(zone)); char *newzone = Malloc(char, 1+strlen(zone));
*tz_name = newzone; if( newzone ){
if( newzone ) strcpy(newzone, zone); strcpy(newzone, zone);
sch_tz_name = s48_enter_string (newzone);
}
else error = errno; else error = errno;
if( oldenv ) revert_env(oldenv); /* Revert TZ & env. */ if( oldenv ) revert_env(oldenv); /* Revert TZ & env. */
if( !newzone ) return s48_enter_fixnum(error); if( !newzone ) s48_raise_os_error_2(error, sch_t, sch_zone);
} }
/* Calculate the time-zone offset in seconds from UTC. */ /* Calculate the time-zone offset in seconds from UTC. */
#ifdef HAVE_GMTOFF #ifdef HAVE_GMTOFF
*tz_secs = d.tm_gmtoff; sch_tz_secs = s48_enter_fixnum (d.tm_gmtoff);
#else #else
{ char **oldenv = environ; /* Set TZ to UTC */ { char **oldenv = environ; /* Set TZ to UTC */
environ=utc_env; /* time temporarily. */ environ=utc_env; /* time temporarily. */
tzset(); /* NetBSD, SunOS POSIX-noncompliance requires this. */ tzset(); /* NetBSD, SunOS POSIX-noncompliance requires this. */
*tz_secs = mktime(&d) - t; sch_tz_secs = s48_enter_fixnum (mktime(&d) - t);
environ=oldenv; environ=oldenv;
} }
#endif #endif
} }
return s48_list_11 (s48_enter_fixnum (d.tm_sec),
*sec = d.tm_sec; *min = d.tm_min; *hour = d.tm_hour; s48_enter_fixnum (d.tm_min),
*mday = d.tm_mday; *month = d.tm_mon; *year = d.tm_year; s48_enter_fixnum (d.tm_hour),
*wday = d.tm_wday; *yday = d.tm_yday; *summer = d.tm_isdst; s48_enter_fixnum (d.tm_mday),
return S48_FALSE; s48_enter_fixnum (d.tm_mon),
s48_enter_fixnum (d.tm_year),
sch_tz_name,
sch_tz_secs,
d.tm_isdst ? S48_TRUE : S48_FALSE,
s48_enter_fixnum (d.tm_wday),
s48_enter_fixnum (d.tm_yday));
} }
/* Oops /* Oops
** There's a fundamental problem with the Posix mktime() function used below ** There's a fundamental problem with the Posix mktime() function used below
** -- it's error return value (-1) is also a valid return value, for date ** -- it's error return value (-1) is also a valid return value, for date
@ -300,13 +319,14 @@ s48_value date2time(s48_value sec, s48_value min, s48_value hour,
** Professional programmers sacrifice their pride that others may live. ** Professional programmers sacrifice their pride that others may live.
** Why me? Why Unix? ** Why me? Why Unix?
*/ */
s48_value format_date(const char *fmt, int sec, int min, int hour, s48_value format_date(s48_value sch_fmt, s48_value sch_sec, s48_value sch_min,
int mday, int month, int year, s48_value sch_hour, s48_value sch_mday,
s48_value tz, int summer, s48_value sch_month, s48_value sch_year,
int week_day, int year_day, s48_value tz, s48_value sch_summer,
const char **ans) s48_value sch_week_day, s48_value sch_year_day)
{ {
struct tm d; struct tm d;
char *fmt = s48_extract_string(sch_fmt);
int fmt_len = strlen(fmt); int fmt_len = strlen(fmt);
char *fmt2 = Malloc(char, 2+2*fmt_len); /* 1 extra for prefixed "x" char.*/ char *fmt2 = Malloc(char, 2+2*fmt_len); /* 1 extra for prefixed "x" char.*/
int target_len = 1; /* 1 for the prefixed "x" char. Ugh. */ int target_len = 1; /* 1 for the prefixed "x" char. Ugh. */
@ -315,13 +335,19 @@ s48_value format_date(const char *fmt, int sec, int min, int hour,
const char *p; const char *p;
char *newenv[2], **oldenv = NULL; char *newenv[2], **oldenv = NULL;
int result_len; int result_len;
s48_value sch_ans = S48_UNSPECIFIC;
*ans = NULL; /* In case we error out. */ if( !fmt2 ) s48_raise_os_error_1(errno, sch_fmt);
if( !fmt2 ) return s48_enter_fixnum(errno);
d.tm_sec = sec; d.tm_min = min; d.tm_hour = hour; d.tm_sec = s48_extract_fixnum(sch_sec);
d.tm_mday = mday; d.tm_mon = month; d.tm_year = year; d.tm_min = s48_extract_fixnum(sch_min);
d.tm_wday = week_day; d.tm_yday = year_day; d.tm_isdst = summer; d.tm_hour = s48_extract_fixnum(sch_hour);
d.tm_mday = s48_extract_fixnum(sch_mday);
d.tm_mon = s48_extract_fixnum(sch_month);
d.tm_year = s48_extract_fixnum(sch_year);
d.tm_wday = s48_extract_fixnum(sch_week_day);
d.tm_yday = s48_extract_fixnum(sch_year_day);
d.tm_isdst = (S48_EQ_P (sch_summer, S48_FALSE)) ? 0 : 1;
/* Copy fmt -> fmt2, converting ~ escape codes to % escape codes. /* Copy fmt -> fmt2, converting ~ escape codes to % escape codes.
** Set zone=1 if fmt has a ~Z. ** Set zone=1 if fmt has a ~Z.
@ -338,7 +364,7 @@ s48_value format_date(const char *fmt, int sec, int min, int hour,
char c = *++p; char c = *++p;
if( ! c ) { if( ! c ) {
Free(fmt2); Free(fmt2);
return S48_TRUE; /* % has to be followed by something. */ return S48_FALSE; /* % has to be followed by something. */
} }
else if( c == '~' ) { else if( c == '~' ) {
*q++ = '~'; *q++ = '~';
@ -383,7 +409,7 @@ s48_value format_date(const char *fmt, int sec, int min, int hour,
if( !oldenv ) { if( !oldenv ) {
int err = errno; int err = errno;
Free(fmt); Free(fmt);
return s48_enter_fixnum(err); s48_raise_os_error_1(errno, sch_fmt);
} }
} }
@ -399,17 +425,17 @@ s48_value format_date(const char *fmt, int sec, int min, int hour,
} }
target[result_len-1] = '\0'; /* Flush the trailing "x". */ target[result_len-1] = '\0'; /* Flush the trailing "x". */
#endif #endif
*ans = target; sch_ans = s48_enter_string(target);
Free(fmt2); Free(fmt2);
if( oldenv ) revert_env(oldenv); if( oldenv ) revert_env(oldenv);
return S48_FALSE; return sch_ans;
lose: lose:
/* We lost trying to allocate space for the strftime() target buffer. */ /* We lost trying to allocate space for the strftime() target buffer. */
{int err = errno; {int err = errno;
if( oldenv ) revert_env(oldenv); /* Clean up */ if( oldenv ) revert_env(oldenv); /* Clean up */
Free(fmt2); Free(fmt2);
return s48_enter_fixnum(err); s48_raise_os_error_1(err, sch_fmt);
} }
} }
@ -438,3 +464,12 @@ char *tzname_loser(struct tm *dp)
** gettimeofday() returns -1/errno ** gettimeofday() returns -1/errno
** localtime() & gmtime() don't error. ** localtime() & gmtime() don't error.
*/ */
void s48_init_time(void)
{
S48_EXPORT_FUNCTION(time_plus_ticks);
S48_EXPORT_FUNCTION(scheme_time);
S48_EXPORT_FUNCTION(date2time);
S48_EXPORT_FUNCTION(time2date);
S48_EXPORT_FUNCTION(format_date);
}

18
scsh/time1.h
View File

@ -5,12 +5,7 @@ s48_value scheme_time();
s48_value time_plus_ticks(); s48_value time_plus_ticks();
extern s48_value time2date(time_t t, s48_value zone, extern s48_value time2date(s48_value t, s48_value zone);
int *sec, int *min, int *hour,
int *mday, int *month, int *year,
const char **tz_name, int *tz_secs,
int *summer,
int *wday, int *yday);
s48_value date2time(s48_value sec, s48_value min, s48_value hour, s48_value date2time(s48_value sec, s48_value min, s48_value hour,
s48_value mday, s48_value month, s48_value year, s48_value mday, s48_value month, s48_value year,
@ -18,8 +13,9 @@ s48_value date2time(s48_value sec, s48_value min, s48_value hour,
s48_value summer); s48_value summer);
extern s48_value format_date(const char *fmt, int sec, int min, int hour, extern s48_value format_date(s48_value fmt, s48_value sch_sec,
int mday, int month, int year, s48_value sch_min, s48_value sch_hour,
s48_value tz, int summer, s48_value sch_mday, s48_value sch_month,
int week_day, int year_day, s48_value sch_year,
const char **ans); s48_value tz, s48_value sch_summer,
s48_value sch_week_day, s48_value sch_year_day);