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

port to new FFI

This commit is contained in:
mainzelm 2001-01-01 16:45:32 +00:00
parent f0ffc6acaf
commit d75baf1985
12 changed files with 102 additions and 248 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
scsh/aix/time_dep1.c
View File

@ -12,27 +12,13 @@
#include "scheme48.h"
#include "../time1.h"
/* Sux because it's dependent on 32-bitness. */
#define hi8(i) (((i)>>24) & 0xff)
#define lo24(i) ((i) & 0xffffff)
#define comp8_24(hi, lo) (((hi)<<24) + (lo))
s48_value time_plus_ticks(int *hi_secs, int *lo_secs,
int *hi_ticks, int *lo_ticks)
s48_value time_plus_ticks()
{
struct timeval t;
struct timezone tz;
if( gettimeofday(&t, &tz) ) return s48_enter_fixnum(errno);
if( gettimeofday(&t, &tz) ) s48_raise_os_error (errno);
{ long int secs = t.tv_sec;
long int ticks = t.tv_usec;
*hi_secs = hi8(secs);
*lo_secs = lo24(secs);
*hi_ticks = hi8(ticks);
*lo_ticks = lo24(ticks);
}
return S48_FALSE;
}
return s48_cons (s48_enter_integer (t.tv_sec),
s48_cons (s48_enter_integer (t.tv_usec), S48_NULL));
}

24
scsh/cygwin32/time_dep1.c
View File

@ -12,27 +12,13 @@
#include "scheme48.h"
#include "../time1.h"
/* Sux because it's dependent on 32-bitness. */
#define hi8(i) (((i)>>24) & 0xff)
#define lo24(i) ((i) & 0xffffff)
#define comp8_24(hi, lo) (((hi)<<24) + (lo))
s48_value time_plus_ticks(int *hi_secs, int *lo_secs,
int *hi_ticks, int *lo_ticks)
s48_value time_plus_ticks()
{
struct timeval t;
struct timezone tz;
if( gettimeofday(&t, &tz) ) return s48_enter_fixnum(errno);
if( gettimeofday(&t, &tz) ) s48_raise_os_error (errno);
{ long int secs = t.tv_sec;
long int ticks = t.tv_usec;
*hi_secs = hi8(secs);
*lo_secs = lo24(secs);
*hi_ticks = hi8(ticks);
*lo_ticks = lo24(ticks);
}
return S48_FALSE;
}
return s48_cons (s48_enter_integer (t.tv_sec),
s48_cons (s48_enter_integer (t.tv_usec), S48_NULL));
}

24
scsh/hpux/time_dep1.c
View File

@ -12,27 +12,13 @@
#include "scheme48.h"
#include "../time1.h"
/* Sux because it's dependent on 32-bitness. */
#define hi8(i) (((i)>>24) & 0xff)
#define lo24(i) ((i) & 0xffffff)
#define comp8_24(hi, lo) (((hi)<<24) + (lo))
s48_value time_plus_ticks(int *hi_secs, int *lo_secs,
int *hi_ticks, int *lo_ticks)
s48_value time_plus_ticks()
{
struct timeval t;
struct timezone tz;
if( gettimeofday(&t, &tz) ) return s48_enter_fixnum(errno);
if( gettimeofday(&t, &tz) ) s48_raise_os_error (errno);
{ long int secs = t.tv_sec;
long int ticks = t.tv_usec;
*hi_secs = hi8(secs);
*lo_secs = lo24(secs);
*hi_ticks = hi8(ticks);
*lo_ticks = lo24(ticks);
}
return S48_FALSE;
}
return s48_cons (s48_enter_integer (t.tv_sec),
s48_cons (s48_enter_integer (t.tv_usec), S48_NULL));
}

24
scsh/irix/time_dep1.c
View File

@ -12,27 +12,13 @@
#include "scheme48.h"
#include "../time1.h"
/* Sux because it's dependent on 32-bitness. */
#define hi8(i) (((i)>>24) & 0xff)
#define lo24(i) ((i) & 0xffffff)
#define comp8_24(hi, lo) (((hi)<<24) + (lo))
s48_value time_plus_ticks(int *hi_secs, int *lo_secs,
int *hi_ticks, int *lo_ticks)
s48_value time_plus_ticks()
{
struct timeval t;
struct timezone tz;
if( gettimeofday(&t, &tz) ) return s48_enter_fixnum(errno);
if( gettimeofday(&t, &tz) ) s48_raise_os_error (errno);
{ long int secs = t.tv_sec;
long int ticks = t.tv_usec;
*hi_secs = hi8(secs);
*lo_secs = lo24(secs);
*hi_ticks = hi8(ticks);
*lo_ticks = lo24(ticks);
}
return S48_FALSE;
}
return s48_cons (s48_enter_integer (t.tv_sec),
s48_cons (s48_enter_integer (t.tv_usec), S48_NULL));
}

24
scsh/linux/time_dep1.c
View File

@ -12,27 +12,13 @@
#include "scheme48.h"
#include "../time1.h"
/* Sux because it's dependent on 32-bitness. */
#define hi8(i) (((i)>>24) & 0xff)
#define lo24(i) ((i) & 0xffffff)
#define comp8_24(hi, lo) (((hi)<<24) + (lo))
s48_value time_plus_ticks(int *hi_secs, int *lo_secs,
int *hi_ticks, int *lo_ticks)
s48_value time_plus_ticks()
{
struct timeval t;
struct timezone tz;
if( gettimeofday(&t, &tz) ) return s48_enter_fixnum(errno);
if( gettimeofday(&t, &tz) ) s48_raise_os_error (errno);
{ long int secs = t.tv_sec;
long int ticks = t.tv_usec;
*hi_secs = hi8(secs);
*lo_secs = lo24(secs);
*hi_ticks = hi8(ticks);
*lo_ticks = lo24(ticks);
}
return S48_FALSE;
}
return s48_cons (s48_enter_integer (t.tv_sec),
s48_cons (s48_enter_integer (t.tv_usec), S48_NULL));
}

24
scsh/next/time_dep1.c
View File

@ -12,27 +12,13 @@
#include "scheme48.h"
#include "../time1.h"
/* Sux because it's dependent on 32-bitness. */
#define hi8(i) (((i)>>24) & 0xff)
#define lo24(i) ((i) & 0xffffff)
#define comp8_24(hi, lo) (((hi)<<24) + (lo))
s48_value time_plus_ticks(int *hi_secs, int *lo_secs,
int *hi_ticks, int *lo_ticks)
s48_value time_plus_ticks()
{
struct timeval t;
struct timezone tz;
if( gettimeofday(&t, &tz) ) return s48_enter_fixnum(errno);
if( gettimeofday(&t, &tz) ) s48_raise_os_error (errno);
{ long int secs = t.tv_sec;
long int ticks = t.tv_usec;
*hi_secs = hi8(secs);
*lo_secs = lo24(secs);
*hi_ticks = hi8(ticks);
*lo_ticks = lo24(ticks);
}
return S48_FALSE;
}
return s48_cons (s48_enter_integer (t.tv_sec),
s48_cons (s48_enter_integer (t.tv_usec), S48_NULL));
}

24
scsh/solaris/time_dep1.c
View File

@ -12,27 +12,13 @@
#include "scheme48.h"
#include "../time1.h"
/* Sux because it's dependent on 32-bitness. */
#define hi8(i) (((i)>>24) & 0xff)
#define lo24(i) ((i) & 0xffffff)
#define comp8_24(hi, lo) (((hi)<<24) + (lo))
s48_value time_plus_ticks(int *hi_secs, int *lo_secs,
int *hi_ticks, int *lo_ticks)
s48_value time_plus_ticks()
{
struct timeval t;
struct timezone tz;
if( gettimeofday(&t, &tz) ) return s48_enter_fixnum(errno);
if( gettimeofday(&t, &tz) ) s48_raise_os_error (errno);
{ long int secs = t.tv_sec;
long int ticks = t.tv_usec;
*hi_secs = hi8(secs);
*lo_secs = lo24(secs);
*hi_ticks = hi8(ticks);
*lo_ticks = lo24(ticks);
}
return S48_FALSE;
}
return s48_cons (s48_enter_integer (t.tv_sec),
s48_cons (s48_enter_integer (t.tv_usec), S48_NULL));
}

24
scsh/sunos/time_dep1.c
View File

@ -12,27 +12,13 @@
#include "scheme48.h"
#include "../time1.h"
/* Sux because it's dependent on 32-bitness. */
#define hi8(i) (((i)>>24) & 0xff)
#define lo24(i) ((i) & 0xffffff)
#define comp8_24(hi, lo) (((hi)<<24) + (lo))
s48_value time_plus_ticks(int *hi_secs, int *lo_secs,
int *hi_ticks, int *lo_ticks)
s48_value time_plus_ticks()
{
struct timeval t;
struct timezone tz;
if( gettimeofday(&t, &tz) ) return s48_enter_fixnum(errno);
if( gettimeofday(&t, &tz) ) s48_raise_os_error (errno);
{ long int secs = t.tv_sec;
long int ticks = t.tv_usec;
*hi_secs = hi8(secs);
*lo_secs = lo24(secs);
*hi_ticks = hi8(ticks);
*lo_ticks = lo24(ticks);
}
return S48_FALSE;
}
return s48_cons (s48_enter_integer (t.tv_sec),
s48_cons (s48_enter_integer (t.tv_usec), S48_NULL));
}

73
scsh/time.scm
View File

@ -95,64 +95,39 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; TICKS/SEC is defined in OS-dependent code.
;;; JMG: not yet converted to the new FFI since it is OS-dependent
(define-foreign %time+ticks/errno (time_plus_ticks) ; C fun is OS-dependent
desc ; errno or #f
fixnum ; hi secs
fixnum ; lo secs
fixnum ; hi ticks
fixnum) ; lo ticks
; 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 (time+ticks)
(receive (err hi-secs lo-secs hi-ticks lo-ticks) (%time+ticks/errno)
(if err (errno-error err time+ticks)
(values (compose-8/24 hi-secs lo-secs)
(compose-8/24 hi-ticks lo-ticks)))))
(apply values (%time+ticks)))
(define (time+ticks->time secs ticks)
(+ secs (/ ticks (ticks/sec))))
(define-foreign %time/errno (scheme_time)
desc ; errno or #f
time_t) ; secs
(define-foreign %date->time/error (date2time (fixnum sec)
(fixnum min)
(fixnum hour)
(fixnum month-day)
(fixnum month)
(fixnum year)
(desc tz-name) ; #f or string
(desc tz-secs) ; #f or int
(bool summer?))
desc ; errno, -1, or #f
time_t) ; secs
(define-stubless-foreign %time () "scheme_time")
(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 (time . args) ; optional arg [date]
(let lp ()
(receive (err secs)
(if (pair? args)
(if (null? (cdr args))
(let ((date (check-arg date? (car args) time)))
(%date->time/error (date:seconds date)
(date:minute date)
(date:hour date)
(date:month-day date)
(date:month date)
(date:year date)
(date:tz-name date) ; #f or string
(date:tz-secs date) ; #f or int
(date:summer? date)))
(error "Too many arguments to TIME procedure" args))
(%time/errno)) ; Fast path for (time).
(cond ((not err) secs) ; Win.
((= errno/intr err) (lp)) ; Retry.
((= -1 err) (error "Error converting date to time." args)) ; Lose.
(else (apply errno-error err time args)))))) ; Lose.
(if (pair? args)
(if (null? (cdr args))
(let ((date (check-arg date? (car args) time)))
(%date->time (date:seconds date)
(date:minute date)
(date:hour date)
(date:month-day date)
(date:month date)
(date:year date)
(date:tz-name date) ; #f or string
(date:tz-secs date) ; #f or int
(date:summer? date)))
(error "Too many arguments to TIME procedure" args))
(%time))) ; Fast path for (time).
;;; Date

46
scsh/time1.c
View File

@ -109,15 +109,14 @@ static void revert_env(char **old_env)
s48_value scheme_time(time_t *secs)
s48_value scheme_time()
{
time_t t;
errno = 0;
t = time(NULL);
if( t == -1 && errno ) return s48_enter_fixnum(errno);
*secs = t;
return S48_FALSE;
}
if( t == -1 && errno ) s48_raise_os_error (errno);
return s48_enter_integer (t);
}
/* Zone:
** #f Local time
@ -212,18 +211,22 @@ s48_value time2date(time_t t, s48_value zone,
** Who designed this interface?
*/
s48_value date2time(int sec, int min, int hour,
int mday, int month, int year,
s48_value tz_name, s48_value tz_secs,
int summer,
time_t *secs)
s48_value date2time(s48_value sec, s48_value min, s48_value hour,
s48_value mday, s48_value month, s48_value year,
s48_value tz_name, s48_value tz_secs,
s48_value summer)
{
time_t t;
struct tm d;
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 = 0; d.tm_yday = 0; d.tm_isdst = summer;
d.tm_sec = s48_extract_fixnum (sec);
d.tm_min = s48_extract_fixnum (min);
d.tm_hour = s48_extract_fixnum (hour);
d.tm_mday = s48_extract_fixnum (mday);
d.tm_mon = s48_extract_fixnum (month);
d.tm_year = s48_extract_fixnum (year);
d.tm_wday = 0; d.tm_yday = 0;
d.tm_isdst = (summer == S48_FALSE) ? 0 : 1;
if( S48_FIXNUM_P(tz_secs) ) { /* Offset from GMT in seconds. */
char **oldenv = environ; /* Set TZ to UTC */
@ -233,7 +236,9 @@ s48_value date2time(int sec, int min, int hour,
errno = 0;
t = mktime(&d);
/* t == -1 => you probably have an error. */
if( t == -1 ) return s48_enter_fixnum(errno ? errno : -1);
if ((t == -1) && (errno != 0))
// Sorry, we only have a version with 5 arguments...
s48_raise_os_error_5 (errno, sec, min, hour, mday, month);
t -= s48_extract_fixnum(tz_secs);
environ = oldenv;
}
@ -245,7 +250,8 @@ s48_value date2time(int sec, int min, int hour,
tzset(); /* NetBSD, SunOS POSIX-noncompliance requires this. */
errno = 0;
t = mktime(&d);
if( t == -1 ) return s48_enter_fixnum(errno ? errno : -1);
if ((t == -1) && (errno != 0))
s48_raise_os_error_5 (errno, sec, min, hour, mday, month);
revert_env(oldenv);
}
@ -253,13 +259,13 @@ s48_value date2time(int sec, int min, int hour,
tzset(); /* NetBSD, SunOS POSIX-noncompliance requires this. */
errno = 0;
t = mktime(&d);
if( t == -1) return s48_enter_fixnum(errno ? errno : -1);
}
*secs = t;
return S48_FALSE;
if ((t == -1) && (errno != 0))
s48_raise_os_error_5 (errno, sec, min, hour, mday, month);
}
return s48_enter_integer(t);
}
/* WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING
**

15
scsh/time1.h
View File

@ -1,10 +1,9 @@
#include <sys/types.h>
#include <time.h>
extern s48_value scheme_time(time_t *secs);
s48_value scheme_time();
extern s48_value time_plus_ticks(int *hi_secs, int *lo_secs,
int *hi_ticks, int *lo_ticks);
s48_value time_plus_ticks();
extern s48_value time2date(time_t t, s48_value zone,
int *sec, int *min, int *hour,
@ -13,11 +12,11 @@ extern s48_value time2date(time_t t, s48_value zone,
int *summer,
int *wday, int *yday);
extern s48_value date2time(int sec, int min, int hour,
int mday, int month, int year,
s48_value tz_name, s48_value tz_secs,
int summer,
time_t *secs);
s48_value date2time(s48_value sec, s48_value min, s48_value hour,
s48_value mday, s48_value month, s48_value year,
s48_value tz_name, s48_value tz_secs,
s48_value summer);
extern s48_value format_date(const char *fmt, int sec, int min, int hour,
int mday, int month, int year,

24
scsh/ultrix/time_dep1.c
View File

@ -12,27 +12,13 @@
#include "scheme48.h"
#include "../time1.h"
/* Sux because it's dependent on 32-bitness. */
#define hi8(i) (((i)>>24) & 0xff)
#define lo24(i) ((i) & 0xffffff)
#define comp8_24(hi, lo) (((hi)<<24) + (lo))
s48_value time_plus_ticks(int *hi_secs, int *lo_secs,
int *hi_ticks, int *lo_ticks)
s48_value time_plus_ticks()
{
struct timeval t;
struct timezone tz;
if( gettimeofday(&t, &tz) ) return s48_enter_fixnum(errno);
if( gettimeofday(&t, &tz) ) s48_raise_os_error (errno);
{ long int secs = t.tv_sec;
long int ticks = t.tv_usec;
*hi_secs = hi8(secs);
*lo_secs = lo24(secs);
*hi_ticks = hi8(ticks);
*lo_ticks = lo24(ticks);
}
return S48_FALSE;
}
return s48_cons (s48_enter_integer (t.tv_sec),
s48_cons (s48_enter_integer (t.tv_usec), S48_NULL));
}