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

replaced most of the hi8/lo24-stuff by enter/extract_integer from the new FFI

This commit is contained in:
marting 1999-09-28 23:48:36 +00:00
parent 03d8bfa284
commit 768fc0b2f3
7 changed files with 59 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
scsh/sleep1.c
View File

@ -12,10 +12,6 @@
#include <time.h>
#include "../c/scheme48.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))
/* Sleep until time hisecs/losecs (return #t),
** or until interrupted (return #f).
@ -28,9 +24,8 @@
** and is pretty straightforward.
*/
s48_value sleep_until(int hisecs, int losecs)
s48_value sleep_until(time_t when)
{
time_t when = comp8_24(hisecs, losecs);
time_t now = time(0);
int delta = when - now;
if( delta > 0 ) {

17
scsh/syscalls.scm
View File

@ -399,8 +399,8 @@
(define-foreign %utime/errno (scm_utime (string path)
(integer ac_hi) (integer ac_lo)
(integer m_hi) (integer m_lo))
(time_t ac)
(time_t m))
(to-scheme integer errno_or_false))
(define-foreign %utime-now/errno (scm_utime_now (string path))
@ -416,8 +416,8 @@
(error "Too many arguments to set-file-times/errno"
(cons path maybe-times))
(real->exact-integer (cadr maybe-times)))))
(%utime/errno path (hi8 access-time) (lo24 access-time)
(hi8 mod-time) (lo24 mod-time)))
(%utime/errno path access-time
mod-time ))
(%utime-now/errno path)))
(define-errno-syscall (set-file-times . args) set-file-times/errno)
@ -1016,13 +1016,12 @@
(define (sleep-until when)
(let* ((when (floor when)) ; Painful to do real->int in Scheme.
(when (if (exact? when) when (inexact->exact when)))
(h (hi8 when)) (l (lo24 when)))
(when (if (exact? when) when (inexact->exact when))))
(let lp ()
(or (%sleep-until h l) (lp)))))
(or (%sleep-until when) (lp)))))
(define-foreign %sleep-until (sleep_until (fixnum hi)
(fixnum lo))
;;; JMG: I don't know whether time_t or long is correct...
(define-foreign %sleep-until (sleep_until (time_t secs))
desc)
(define-foreign %gethostname (scm_gethostname)

8
scsh/syscalls1.c
View File

@ -147,13 +147,13 @@ char const *scm_readlink(const char *path)
** Complicated by need to pass real 32-bit quantities.
*/
int scm_utime(char const *path, int ac_hi, int ac_lo, int mod_hi, int mod_lo)
int scm_utime(char const *path, time_t ac, time_t mod)
{
struct utimbuf t;
t.actime = comp8_24(ac_hi, ac_lo);
t.modtime = comp8_24(mod_hi, mod_lo);
t.actime = ac;
t.modtime = mod;
return utime(path, &t);
}
}
int scm_utime_now(char const *path) {return utime(path, 0);}

2
scsh/syscalls1.h
View File

@ -8,7 +8,7 @@ int scheme_pipe(int *r, int *w);
char const *scm_readlink(const char *path);
int scm_utime(char const *path, int ac_hi, int ac_lo, int mod_hi, int mod_lo);
int scm_utime(char const *path, time_t ac, time_t mod);
int scm_utime_now(char const *path);

27
scsh/time.scm
View File

@ -95,7 +95,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; 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
@ -114,8 +114,8 @@
(define-foreign %time/errno (scheme_time)
desc ; errno or #f
fixnum ; hi secs
fixnum) ; lo secs
time_t) ; secs
(define-foreign %date->time/error (date2time (fixnum sec)
@ -127,13 +127,13 @@
(desc tz-name) ; #f or string
(desc tz-secs) ; #f or int
(bool summer?))
desc ; errno, -1, or #f
fixnum ; hi secs
fixnum) ; lo secs
desc ; errno, -1, or #f
time_t) ; secs
(define (time . args) ; optional arg [date]
(let lp ()
(receive (err hi-secs lo-secs)
(receive (err secs)
(if (pair? args)
(if (null? (cdr args))
(let ((date (check-arg date? (car args) time)))
@ -149,7 +149,7 @@
(error "Too many arguments to TIME procedure" args))
(%time/errno)) ; Fast path for (time).
(cond ((not err) (compose-8/24 hi-secs lo-secs)) ; Win.
(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.
@ -157,8 +157,7 @@
;;; Date
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-foreign %time->date (time2date (fixnum time-hi)
(fixnum time-lo)
(define-foreign %time->date (time2date (time_t time-hi)
(desc zone))
desc ; errno or #f
fixnum ; seconds
@ -181,10 +180,10 @@
(zone (check-arg time-zone?
(and (pair? args) (:optional (cdr args) #f))
date)))
(let lp ()
(let lp ()
(receive (err seconds minute hour month-day month
year tz-name tz-secs summer? week-day year-day)
(%time->date (hi8 time) (lo24 time) zone)
(%time->date time zone)
(cond ((not err)
(make-%date seconds minute hour month-day month
year
@ -261,10 +260,8 @@
; (if err (errno-error err time-zone summer? tz)
; zone))))))
;;; 8/24 bit signed integer splitting and recombination.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (hi8 n) (bitwise-and (arithmetic-shift n -24) #xff))
(define (lo24 n) (bitwise-and n #xffffff))
(define (compose-8/24 hi-8 lo-24)
(let ((val (+ (arithmetic-shift hi-8 24) lo-24)))

53
scsh/time1.c
View File

@ -3,7 +3,9 @@
*/
/* WARNING: THIS FILE HAS CODE THAT DEPENDS ON 32-BIT ARCHITECTURES.
** This code is so marked.
** 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
@ -49,6 +51,8 @@
#include "cstuff.h"
#include "time1.h" /* Make sure the .h interface agrees with the code. */
#include <stdio.h> // JMG debug
extern char **environ;
/* To work in the UTC time zone, do "environ = utc_env;". */
@ -74,11 +78,16 @@ static char **make_newenv(s48_value zone, char *newenv[2])
int zonelen = S48_STRING_LENGTH(zone);
char **oldenv = environ,
*tz = Malloc(char, 4+zonelen);
s48_value temp;
char * extracted_zone = s48_extract_string(zone);
// s48_value temp;
if( !tz ) return NULL;
strcpy(tz, "TZ=");
temp = S48_UNSAFE_STRING_REF(zone,0); //JMG
strncpy(tz+3, &temp, zonelen);
// temp = S48_STRING_REF(zone,0); //JMG
// strncpy(tz+3, &temp, zonelen);
strncpy(tz+3, extracted_zone, zonelen);
tz[zonelen+3] = '\0';
newenv[0] = tz;
newenv[1] = NULL;
@ -97,19 +106,16 @@ static void revert_env(char **old_env)
/*****************************************************************************/
/* 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 scheme_time(int *hi_secs, int *lo_secs)
s48_value scheme_time(time_t *secs)
{
time_t t;
errno = 0;
t = time(NULL);
if( t == -1 && errno ) return s48_enter_fixnum(errno);
*hi_secs = hi8(t);
*lo_secs = lo24(t);
*secs = t;
return S48_FALSE;
}
@ -118,15 +124,14 @@ s48_value scheme_time(int *hi_secs, int *lo_secs)
** int Offset from GMT in seconds.
** string Time zone understood by OS.
*/
s48_value time2date(int hi_secs, int lo_secs, s48_value zone,
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)
{
time_t t = comp8_24(hi_secs, lo_secs);
struct tm d;
struct tm d;
if( S48_FIXNUM_P(zone) ) { /* Offset from GMT in secs. */
int offset = s48_extract_fixnum(zone);
@ -139,12 +144,13 @@ s48_value time2date(int hi_secs, int lo_secs, s48_value zone,
char *newenv[2], **oldenv = NULL;
if( S48_STRING_P(zone) ) { /* Time zone */
oldenv = make_newenv(zone, newenv); /* Install new TZ. */
if( !oldenv ) return s48_enter_fixnum(errno); /* Error installing. */
d = *localtime(&t); /* Do it. */
}
oldenv = make_newenv(zone, newenv); /* Install new TZ. */
if( !oldenv ) return s48_enter_fixnum(errno); /* Error installing. */
d = *localtime(&t); /* Do it. */
}
else /* Local time */
d = *localtime(&t);
d = *localtime(&t);
/* This little chunk of code copies the calculated time zone into
** a malloc'd buffer and assigns it to *tz_name. It's a little
@ -167,7 +173,7 @@ s48_value time2date(int hi_secs, int lo_secs, s48_value zone,
if( newzone ) strcpy(newzone, zone);
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);
}
@ -175,12 +181,14 @@ s48_value time2date(int hi_secs, int lo_secs, s48_value zone,
/* Calculate the time-zone offset in seconds from UTC. */
#ifdef HAVE_GMTOFF
*tz_secs = 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;
environ=oldenv;
}
#endif
}
@ -208,7 +216,7 @@ 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,
int *hi_secs, int *lo_secs)
time_t *secs)
{
time_t t;
struct tm d;
@ -248,8 +256,7 @@ s48_value date2time(int sec, int min, int hour,
if( t == -1) return s48_enter_fixnum(errno ? errno : -1);
}
*hi_secs = hi8(t);
*lo_secs = lo24(t);
*secs = t;
return S48_FALSE;
}

6
scsh/time1.h
View File

@ -1,9 +1,9 @@
extern s48_value scheme_time(int *hi_secs, int *lo_secs);
extern s48_value scheme_time(time_t *secs);
extern s48_value time_plus_ticks(int *hi_secs, int *lo_secs,
int *hi_ticks, int *lo_ticks);
extern s48_value time2date(int hi_secs, int lo_secs, s48_value zone,
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,
@ -14,7 +14,7 @@ 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,
int *hi_secs, int *lo_secs);
time_t *secs);
extern s48_value format_date(const char *fmt, int sec, int min, int hour,
int mday, int month, int year,