diff --git a/scsh/time.c b/scsh/time.c deleted file mode 100644 index b0e64ea..0000000 --- a/scsh/time.c +++ /dev/null @@ -1,74 +0,0 @@ -/* This is an Scheme48/C interface file, -** automatically generated by a hacked version of cig 3.0. -step 4 -*/ - -#include -#include /* 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); -} diff --git a/scsh/time.scm b/scsh/time.scm index 049e94c..f0c7935 100644 --- a/scsh/time.scm +++ b/scsh/time.scm @@ -10,11 +10,6 @@ ;;; - If tz-name not defined, fabbed from tz-secs. ;;; - 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 ;;; independent, barring relativistic effects. It is measured as the ;;; number of seconds elapsed since "epoch" -- January 1, 1970 UTC. @@ -98,7 +93,8 @@ ; C fun is OS-dependent ; TODO: all C files are identical, so move it to time1.c ; 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) (apply values (%time+ticks))) @@ -106,12 +102,15 @@ (define (time+ticks->time secs ticks) (+ 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 - tz-name ; #f or string - tz-secs ; #f or int - summer?) "date2time") +(define-stubless-foreign %date->time/eintr + (sec min hour month-day month year + tz-name ; #f or string + tz-secs ; #f or int + summer?) "date2time") +(define-retrying-syscall %date->time %date->time/eintr) (define (time . args) ; optional arg [date] (if (pair? args) @@ -132,21 +131,8 @@ ;;; Date ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-foreign %time->date (time2date (time_t time-hi) - (desc zone)) - 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-stubless-foreign %time->date/eintr (time zone) "time2date") +(define-retrying-syscall %time->date %time->date/eintr) (define (date . args) ; Optional args [time zone] (let ((time (if (pair? args) @@ -155,17 +141,14 @@ (zone (check-arg time-zone? (and (pair? args) (:optional (cdr args) #f)) date))) - (let lp () - (receive (err seconds minute hour month-day month - 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 - year - (format-time-zone (or tz-name "UTC") tz-secs) - tz-secs summer? week-day year-day)) - ((= errno/intr err) (lp)) - (errno-error err date time zone)))))) + (apply + (lambda (seconds minute hour month-day month + year tz-name tz-secs summer? week-day year-day) + (make-%date seconds minute hour month-day month + year + (format-time-zone (or tz-name "UTC") tz-secs) + tz-secs summer? week-day year-day)) + (%time->date time zone)))) ;;; Formatting date strings @@ -176,37 +159,28 @@ (define (format-date fmt date) (check-arg date? date format-date) - (receive (err result) - (%format-date/errno fmt - (date:seconds date) - (date:minute date) - (date:hour date) - (date:month-day date) - (date:month date) - (date:year date) - (if (string? (date:tz-name date)) - (date:tz-name date) - (deintegerize-time-zone (date:tz-secs date))) - (date:summer? date) - (date:week-day date) - (date:year-day date)) - (cond ((not err) result) - ((= errno/intr err) (format-date fmt date)) - (else (errno-error err format-date fmt date))))) + (let ((result + (%format-date fmt + (date:seconds date) + (date:minute date) + (date:hour date) + (date:month-day date) + (date:month date) + (date:year date) + (if (string? (date:tz-name date)) + (date:tz-name date) + (deintegerize-time-zone (date:tz-secs date))) + (date:summer? date) + (date:week-day date) + (date:year-day date)))) + (cond ((not result) (error "~ without argument in format-date" fmt)) + (else result)))) -(define-foreign %format-date/errno (format_date (string fmt) - (fixnum seconds) - (fixnum minute) - (fixnum hour) - (fixnum month-day) - (fixnum month) - (fixnum year) - (desc tz-name) - (bool summer?) - (fixnum week-day) - (fixnum year-day)) - desc ; false or errno - string) +(define-stubless-foreign %format-date/eintr + (fmt seconds minute hour month-day month year tz-name summer? week-day + year-day) + "format_date") +(define-retrying-syscall %format-date %format-date/eintr) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/scsh/time1.c b/scsh/time1.c index ffa3123..0621207 100644 --- a/scsh/time1.c +++ b/scsh/time1.c @@ -2,12 +2,7 @@ ** Copyright (c) 1994 by Olin Shivers. */ -/* WARNING: THIS FILE HAS CODE THAT DEPENDS ON 32-BIT ARCHITECTURES. -** 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: +/* The source code is conditionalised by three #ifdef feature macros: ** HAVE_TZNAME ** The char *tzname[2] global variable is POSIX. Everyone provides ** 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); } +// 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: ** #f Local time ** int Offset from GMT in seconds. ** string Time zone understood by OS. */ -s48_value time2date(time_t t, s48_value zone, - int *sec, int *min, int *hour, +s48_value time2date(s48_value sch_t, s48_value sch_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) + */ { - 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. */ - int offset = s48_extract_fixnum(zone); - t += s48_extract_fixnum(zone); + if( S48_FIXNUM_P(sch_zone) ) { /* Offset from GMT in secs. */ + int offset = s48_extract_fixnum(sch_zone); + t += s48_extract_fixnum(sch_zone); d = *gmtime(&t); - *tz_name = NULL; - *tz_secs = offset; + sch_tz_name = s48_enter_string(""); + sch_tz_secs = s48_enter_fixnum (offset); } else { 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. */ - if( !oldenv ) return s48_enter_fixnum(errno); /* Error installing. */ + oldenv = make_newenv(sch_zone, newenv); /* Install new TZ. */ + if( !oldenv ) s48_raise_os_error_2(errno, sch_t, sch_zone); d = *localtime(&t); /* Do it. */ } else /* Local time */ @@ -168,37 +180,44 @@ s48_value time2date(time_t t, s48_value zone, char *zone = tzname[d.tm_isdst]; #endif char *newzone = Malloc(char, 1+strlen(zone)); - *tz_name = newzone; - if( newzone ) strcpy(newzone, zone); + if( newzone ){ + strcpy(newzone, zone); + sch_tz_name = s48_enter_string (newzone); + } else error = errno; 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. */ #ifdef HAVE_GMTOFF - *tz_secs = d.tm_gmtoff; + sch_tz_secs = s48_enter_fixnum (d.tm_gmtoff); #else { char **oldenv = environ; /* Set TZ to UTC */ environ=utc_env; /* time temporarily. */ tzset(); /* NetBSD, SunOS POSIX-noncompliance requires this. */ - *tz_secs = mktime(&d) - t; + sch_tz_secs = s48_enter_fixnum (mktime(&d) - t); environ=oldenv; } #endif } - - *sec = d.tm_sec; *min = d.tm_min; *hour = d.tm_hour; - *mday = d.tm_mday; *month = d.tm_mon; *year = d.tm_year; - *wday = d.tm_wday; *yday = d.tm_yday; *summer = d.tm_isdst; - return S48_FALSE; + return s48_list_11 (s48_enter_fixnum (d.tm_sec), + s48_enter_fixnum (d.tm_min), + s48_enter_fixnum (d.tm_hour), + s48_enter_fixnum (d.tm_mday), + 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 ** 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 @@ -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. ** Why me? Why Unix? */ -s48_value format_date(const char *fmt, int sec, int min, int hour, - int mday, int month, int year, - s48_value tz, int summer, - int week_day, int year_day, - const char **ans) +s48_value format_date(s48_value sch_fmt, s48_value sch_sec, s48_value sch_min, + s48_value sch_hour, s48_value sch_mday, + s48_value sch_month, s48_value sch_year, + s48_value tz, s48_value sch_summer, + s48_value sch_week_day, s48_value sch_year_day) { struct tm d; + char *fmt = s48_extract_string(sch_fmt); int fmt_len = strlen(fmt); 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. */ @@ -315,13 +335,19 @@ s48_value format_date(const char *fmt, int sec, int min, int hour, const char *p; char *newenv[2], **oldenv = NULL; int result_len; - - *ans = NULL; /* In case we error out. */ - if( !fmt2 ) return s48_enter_fixnum(errno); + s48_value sch_ans = S48_UNSPECIFIC; - d.tm_sec = sec; d.tm_min = min; d.tm_hour = hour; - d.tm_mday = mday; d.tm_mon = month; d.tm_year = year; - d.tm_wday = week_day; d.tm_yday = year_day; d.tm_isdst = summer; + if( !fmt2 ) s48_raise_os_error_1(errno, sch_fmt); + + d.tm_sec = s48_extract_fixnum(sch_sec); + d.tm_min = s48_extract_fixnum(sch_min); + 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. ** 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; if( ! c ) { Free(fmt2); - return S48_TRUE; /* % has to be followed by something. */ + return S48_FALSE; /* % has to be followed by something. */ } else if( c == '~' ) { *q++ = '~'; @@ -383,7 +409,7 @@ s48_value format_date(const char *fmt, int sec, int min, int hour, if( !oldenv ) { int err = errno; 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". */ #endif - *ans = target; + sch_ans = s48_enter_string(target); Free(fmt2); if( oldenv ) revert_env(oldenv); - return S48_FALSE; + return sch_ans; lose: /* We lost trying to allocate space for the strftime() target buffer. */ {int err = errno; if( oldenv ) revert_env(oldenv); /* Clean up */ 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 ** 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); +} diff --git a/scsh/time1.h b/scsh/time1.h index 36f4bd2..a73683a 100644 --- a/scsh/time1.h +++ b/scsh/time1.h @@ -5,12 +5,7 @@ s48_value scheme_time(); s48_value time_plus_ticks(); -extern s48_value time2date(time_t 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); +extern s48_value time2date(s48_value t, s48_value zone); s48_value date2time(s48_value sec, s48_value min, s48_value hour, 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); -extern s48_value format_date(const char *fmt, int sec, int min, int hour, - int mday, int month, int year, - s48_value tz, int summer, - int week_day, int year_day, - const char **ans); +extern s48_value format_date(s48_value fmt, s48_value sch_sec, + s48_value sch_min, s48_value sch_hour, + s48_value sch_mday, s48_value sch_month, + s48_value sch_year, + s48_value tz, s48_value sch_summer, + s48_value sch_week_day, s48_value sch_year_day);