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

17
scsh/syscalls.scm
View File

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

25
scsh/time.scm
View File

@ -95,7 +95,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; TICKS/SEC is defined in OS-dependent code. ; 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 (define-foreign %time+ticks/errno (time_plus_ticks) ; C fun is OS-dependent
desc ; errno or #f desc ; errno or #f
fixnum ; hi secs fixnum ; hi secs
@ -114,8 +114,8 @@
(define-foreign %time/errno (scheme_time) (define-foreign %time/errno (scheme_time)
desc ; errno or #f desc ; errno or #f
fixnum ; hi secs time_t) ; secs
fixnum) ; lo secs
(define-foreign %date->time/error (date2time (fixnum sec) (define-foreign %date->time/error (date2time (fixnum sec)
@ -128,12 +128,12 @@
(desc tz-secs) ; #f or int (desc tz-secs) ; #f or int
(bool summer?)) (bool summer?))
desc ; errno, -1, or #f desc ; errno, -1, or #f
fixnum ; hi secs time_t) ; secs
fixnum) ; lo secs
(define (time . args) ; optional arg [date] (define (time . args) ; optional arg [date]
(let lp () (let lp ()
(receive (err hi-secs lo-secs) (receive (err secs)
(if (pair? args) (if (pair? args)
(if (null? (cdr args)) (if (null? (cdr args))
(let ((date (check-arg date? (car args) time))) (let ((date (check-arg date? (car args) time)))
@ -149,7 +149,7 @@
(error "Too many arguments to TIME procedure" args)) (error "Too many arguments to TIME procedure" args))
(%time/errno)) ; Fast path for (time). (%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. ((= errno/intr err) (lp)) ; Retry.
((= -1 err) (error "Error converting date to time." args)) ; Lose. ((= -1 err) (error "Error converting date to time." args)) ; Lose.
(else (apply errno-error err time args)))))) ; Lose. (else (apply errno-error err time args)))))) ; Lose.
@ -157,8 +157,7 @@
;;; Date ;;; Date
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-foreign %time->date (time2date (fixnum time-hi) (define-foreign %time->date (time2date (time_t time-hi)
(fixnum time-lo)
(desc zone)) (desc zone))
desc ; errno or #f desc ; errno or #f
fixnum ; seconds fixnum ; seconds
@ -181,10 +180,10 @@
(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 () (let lp ()
(receive (err seconds minute hour month-day month (receive (err 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 (hi8 time) (lo24 time) zone) (%time->date time zone)
(cond ((not err) (cond ((not err)
(make-%date seconds minute hour month-day month (make-%date seconds minute hour month-day month
year year
@ -261,10 +260,8 @@
; (if err (errno-error err time-zone summer? tz) ; (if err (errno-error err time-zone summer? tz)
; zone)))))) ; 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) (define (compose-8/24 hi-8 lo-24)
(let ((val (+ (arithmetic-shift hi-8 24) lo-24))) (let ((val (+ (arithmetic-shift hi-8 24) lo-24)))

51
scsh/time1.c
View File

@ -4,6 +4,8 @@
/* WARNING: THIS FILE HAS CODE THAT DEPENDS ON 32-BIT ARCHITECTURES. /* 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: ** The source code is also conditionalised by three #ifdef feature macros:
** HAVE_TZNAME ** HAVE_TZNAME
@ -49,6 +51,8 @@
#include "cstuff.h" #include "cstuff.h"
#include "time1.h" /* Make sure the .h interface agrees with the code. */ #include "time1.h" /* Make sure the .h interface agrees with the code. */
#include <stdio.h> // JMG debug
extern char **environ; extern char **environ;
/* To work in the UTC time zone, do "environ = utc_env;". */ /* 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); int zonelen = S48_STRING_LENGTH(zone);
char **oldenv = environ, char **oldenv = environ,
*tz = Malloc(char, 4+zonelen); *tz = Malloc(char, 4+zonelen);
s48_value temp;
char * extracted_zone = s48_extract_string(zone);
// s48_value temp;
if( !tz ) return NULL; if( !tz ) return NULL;
strcpy(tz, "TZ="); 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'; tz[zonelen+3] = '\0';
newenv[0] = tz; newenv[0] = tz;
newenv[1] = NULL; 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; time_t t;
errno = 0; errno = 0;
t = time(NULL); t = time(NULL);
if( t == -1 && errno ) return s48_enter_fixnum(errno); if( t == -1 && errno ) return s48_enter_fixnum(errno);
*hi_secs = hi8(t); *secs = t;
*lo_secs = lo24(t);
return S48_FALSE; return S48_FALSE;
} }
@ -118,15 +124,14 @@ s48_value scheme_time(int *hi_secs, int *lo_secs)
** 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(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 *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)
{ {
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. */ if( S48_FIXNUM_P(zone) ) { /* Offset from GMT in secs. */
int offset = s48_extract_fixnum(zone); 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; char *newenv[2], **oldenv = NULL;
if( S48_STRING_P(zone) ) { /* Time zone */ if( S48_STRING_P(zone) ) { /* Time zone */
oldenv = make_newenv(zone, newenv); /* Install new TZ. */
if( !oldenv ) return s48_enter_fixnum(errno); /* Error installing. */ oldenv = make_newenv(zone, newenv); /* Install new TZ. */
d = *localtime(&t); /* Do it. */ if( !oldenv ) return s48_enter_fixnum(errno); /* Error installing. */
} d = *localtime(&t); /* Do it. */
}
else /* Local time */ else /* Local time */
d = *localtime(&t); d = *localtime(&t);
/* This little chunk of code copies the calculated time zone into /* 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 ** 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); if( newzone ) strcpy(newzone, zone);
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 ) 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. */ /* Calculate the time-zone offset in seconds from UTC. */
#ifdef HAVE_GMTOFF #ifdef HAVE_GMTOFF
*tz_secs = d.tm_gmtoff; *tz_secs = 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; *tz_secs = mktime(&d) - t;
environ=oldenv; environ=oldenv;
} }
#endif #endif
} }
@ -208,7 +216,7 @@ s48_value date2time(int sec, int min, int hour,
int mday, int month, int year, int mday, int month, int year,
s48_value tz_name, s48_value tz_secs, s48_value tz_name, s48_value tz_secs,
int summer, int summer,
int *hi_secs, int *lo_secs) time_t *secs)
{ {
time_t t; time_t t;
struct tm d; 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); if( t == -1) return s48_enter_fixnum(errno ? errno : -1);
} }
*hi_secs = hi8(t); *secs = t;
*lo_secs = lo24(t);
return S48_FALSE; 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, extern s48_value time_plus_ticks(int *hi_secs, int *lo_secs,
int *hi_ticks, int *lo_ticks); 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 *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,
@ -14,7 +14,7 @@ extern s48_value date2time(int sec, int min, int hour,
int mday, int month, int year, int mday, int month, int year,
s48_value tz_name, s48_value tz_secs, s48_value tz_name, s48_value tz_secs,
int summer, 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, extern s48_value format_date(const char *fmt, int sec, int min, int hour,
int mday, int month, int year, int mday, int month, int year,