Commit 5462b6ce authored by Erick's avatar Erick

Added the R7RS time related primitives

The functions are:
  - `current-second`
  - `current-jiffy`
  - `jiffies-per-second`
parent 5b18c989
......@@ -18,7 +18,7 @@
;; USA.
;; Author: Erick Gallesio [eg@unice.fr]
;; Creation date: 26-Nov-2000 18:19 (eg)
;; Last file update: 24-Aug-2018 16:32 (eg)
;; Last file update: 11-Sep-2018 10:13 (eg)
;;
;; ======================================================================
......@@ -633,16 +633,103 @@ be accessed as a normal port with the standard Scheme primitives.])
(insertdoc 'flush-output-port)
(insertdoc 'printerr)
(insertdoc 'eprintf))
)
;;;
;;; SYSTEM INTERFACE
;;;
(section :title "System interface"
(subsection :title "System interface"
(subsection :title "Loading code"
(index "STKLOS_LOAD_PATH")
(insertdoc 'load)
(insertdoc 'try-load)
(insertdoc 'find-path)
(insertdoc 'current-loading-file)
(insertdoc 'provided?)
(TODO "Document here autoload functions"))
)
;;; File Primitives.
(subsection :title "File Primitives"
(insertdoc 'temporary-file-name)
(insertdoc 'rename-file)
(insertdoc 'remove-file)
(insertdoc 'copy-file)
(insertdoc 'copy-port)
(insertdoc 'file-exists?)
(insertdoc 'file-is-executable?)
(insertdoc 'file-size)
(insertdoc 'getcwd)
(insertdoc 'chmod)
(insertdoc 'chdir)
(insertdoc 'make-directory)
(insertdoc 'make-directories)
(insertdoc 'ensure-directories-exist)
(insertdoc 'remove-directory)
(insertdoc 'directory-files)
(index "tilde expansion")
(insertdoc 'expand-file-name)
(insertdoc 'canonical-file-name)
(insertdoc 'decompose-file-name)
(insertdoc 'winify-file-name)
(insertdoc 'posixify-file-name)
(insertdoc 'basename)
(insertdoc 'dirname)
(insertdoc 'file-suffix)
(insertdoc 'file-prefix)
(insertdoc 'file-separator)
(insertdoc 'make-path)
(insertdoc 'glob))
;;; Environment.
(subsection :title "Environment"
(insertdoc 'getenv)
(insertdoc 'setenv!)
(insertdoc 'unsetenv!))
;;; Time
(subsection :title "Time"
(insertdoc 'current-second)
(insertdoc 'current-jiffy)
(insert-doc 'jiffies-per-second)
(insertdoc 'clock)
(insertdoc 'sleep)
(insertdoc 'time))
(subsection :title "System Informations"
(insertdoc 'features)
(insertdoc 'running-os)
(insertdoc 'hostname)
(insertdoc 'argc)
(insertdoc 'argv)
(insertdoc 'program-name)
(insertdoc 'version)
(insertdoc 'machine-type)
(insertdoc 'getpid))
(subsection :title "Program Arguments Parsing"
(index "SRFI-22")
(p [,(stklos) provides a simple way to parse program arguments with the
|parse-arguments| special form. This form is generally used into
the |main| function in a Scheme script. See ,(link-srfi 22) on how to
use a |main| function in a Scheme program.])
(insertdoc 'parse-arguments)
(insertdoc 'arg-usage))
(subsection :title "Misc. System Procedures"
(insertdoc 'system)
(insertdoc 'exec-list)
(insertdoc 'address-of)
(insertdoc 'exit)
(insertdoc 'die)
(insertdoc 'get-password)
(insertdoc 'register-exit-function!)))
;;;
......@@ -720,6 +807,8 @@ representation which consists is an integer which represents the
number of seconds elapsed since the ,(emph "Epoch") (00:00:00 on
January 1, 1970, Coordinated Universal Time --UTC). Dates can
also be represented with date structures.])
(insertdoc 'current-second)
(insertdoc 'current-seconds)
(insertdoc 'current-time)
(insertdoc 'time?)
......@@ -816,83 +905,6 @@ applications.])
(insertdoc 'socket-port-number)
(insertdoc 'socket-output))
;;;
;;; SYSTEM PROCEDURES
;;
(section :title "System Procedures"
;;; File Primitives.
(subsection :title "File Primitives"
(insertdoc 'temporary-file-name)
(insertdoc 'rename-file)
(insertdoc 'remove-file)
(insertdoc 'copy-file)
(insertdoc 'copy-port)
(insertdoc 'file-exists?)
(insertdoc 'file-size)
(insertdoc 'getcwd)
(insertdoc 'chmod)
(insertdoc 'chdir)
(insertdoc 'make-directory)
(insertdoc 'make-directories)
(insertdoc 'ensure-directories-exist)
(insertdoc 'remove-directory)
(insertdoc 'directory-files)
(index "tilde expansion")
(insertdoc 'expand-file-name)
(insertdoc 'canonical-file-name)
(insertdoc 'decompose-file-name)
(insertdoc 'winify-file-name)
(insertdoc 'posixify-file-name)
(insertdoc 'basename)
(insertdoc 'dirname)
(insertdoc 'file-suffix)
(insertdoc 'file-prefix)
(insertdoc 'file-separator)
(insertdoc 'make-path)
(insertdoc 'glob))
;;; Environment.
(subsection :title "Environment"
(insertdoc 'getenv)
(insertdoc 'setenv!)
(insertdoc 'unsetenv!))
(subsection :title "System Informations"
(insertdoc 'running-os)
(insertdoc 'hostname)
(insertdoc 'argc)
(insertdoc 'argv)
(insertdoc 'program-name)
(insertdoc 'version)
(insertdoc 'machine-type)
(insertdoc 'clock)
(insertdoc 'sleep)
(insertdoc 'time)
(insertdoc 'getpid))
(subsection :title "Program Arguments Parsing"
(index "SRFI-22")
(p [,(stklos) provides a simple way to parse program arguments with the
|parse-arguments| special form. This form is generally used into
the |main| function in a Scheme script. See ,(link-srfi 22) on how to
use a |main| function in a Scheme program.])
(insertdoc 'parse-arguments)
(insertdoc 'arg-usage))
(subsection :title "Misc. System Procedures"
(insertdoc 'system)
(insertdoc 'exec-list)
(insertdoc 'address-of)
(insertdoc 'exit)
(insertdoc 'die)
(insertdoc 'get-password)
(insertdoc 'register-exit-function!)))
;;;
;;; SIGNALS
;;;
......
;;;;
;;;; date.stk -- Date and Time Operations
;;;; date.stk -- Date and Time Operations
;;;;
;;;; Copyright © 2002-2011 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; Copyright © 2002-2018 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,12 +21,12 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 3-Apr-2002 10:06 (eg)
;;;; Last file update: 27-May-2011 23:01 (eg)
;;;; Last file update: 11-Sep-2018 10:26 (eg)
;;;;
;;;; ======================================================================
;;;;
;;;; TIME functions
;;;; TIME functions
;;;;
;;;; ======================================================================
......@@ -55,7 +55,7 @@ doc>
(define (time->seconds time)
(if (time? time)
(+ (%fast-struct-ref time %time 'second 0)
(/ (%fast-struct-ref time %time 'micro-second 1) 1e6))
(/ (%fast-struct-ref time %time 'nanosecond 1) #e1e9))
(error 'time-seconds "bad time ~S" time)))
......@@ -66,7 +66,7 @@ doc>
* Converts into a time object the real number |x| representing the number
* of seconds elapsed since the Epoch.
* @lisp
* (seconds->time (+ 10 (time->seconds (current-time)))
* (seconds->time (+ 10 (time->seconds (current-time))))
* ==> a time object representing 10 seconds in the future
* @end lisp
doc>
......@@ -74,19 +74,19 @@ doc>
(define (seconds->time x)
(if (and (number? x) (positive? x))
(cond
((real? x)
(let ((n (inexact->exact (round (* x 1e6)))))
(make-struct %time (quotient n 1000000) (remainder n 1000000))))
((integer? x)
(make-struct %time x 0))
(else
(error 'seconds->time "cannot convert ~S to a time" x)))
((real? x)
(let ((n (inexact->exact (round (* x #e1e9)))))
(make-struct %time (quotient n #e1e9) (remainder n #e1e9))))
((integer? x)
(make-struct %time x 0))
(else
(error 'seconds->time "cannot convert ~S to a time" x)))
(error 'seconds->time "bad number ~S" x)))
;;;; ======================================================================
;;;;
;;;; DATE functions
;;;; DATE functions
;;;;
;;;; ======================================================================
#|
......@@ -98,7 +98,7 @@ doc>
doc>
|#
(define (make-date :key (second 0) (minute 0) (hour 0)
(day 1) (month 1) (year 1970))
(day 1) (month 1) (year 1970))
(let ((tmp (make-struct %date second minute hour day month year)))
;; tmp is probably partially initialized convert it to seconds and back
;; to a date
......@@ -120,14 +120,14 @@ doc>
(%seconds->date (if (real? s) (inexact->exact (round s)) s)))
;; ======================================================================
;; date writer
;; date writer
;; ======================================================================
(struct-type-change-writer!
%date
(lambda (s port)
(format port "#[date ~A-~A-~A ~A:~A:~A]"
(struct-ref s 'year) (struct-ref s 'month) (struct-ref s 'day)
(struct-ref s 'hour) (struct-ref s 'minute) (struct-ref s 'second))))
(struct-ref s 'year) (struct-ref s 'month) (struct-ref s 'day)
(struct-ref s 'hour) (struct-ref s 'minute) (struct-ref s 'second))))
#|
......@@ -187,19 +187,19 @@ doc>
* Return the time zone of date |d|.
doc>
|#
(define (date-second d) (%fast-struct-ref d %date 'date-second 0))
(define (date-minute d) (%fast-struct-ref d %date 'date-minute 1))
(define (date-hour d) (%fast-struct-ref d %date 'date-hour 2))
(define (date-second d) (%fast-struct-ref d %date 'date-second 0))
(define (date-minute d) (%fast-struct-ref d %date 'date-minute 1))
(define (date-hour d) (%fast-struct-ref d %date 'date-hour 2))
(define (date-day d) (%fast-struct-ref d %date 'date-day 3))
(define (date-month d) (%fast-struct-ref d %date 'date-month 4))
(define (date-year d) (%fast-struct-ref d %date 'date-year 5))
(define (date-day d) (%fast-struct-ref d %date 'date-day 3))
(define (date-month d) (%fast-struct-ref d %date 'date-month 4))
(define (date-year d) (%fast-struct-ref d %date 'date-year 5))
(define (date-week-day d) (%fast-struct-ref d %date 'date-week-day 6))
(define (date-year-day d) (%fast-struct-ref d %date 'date-year-day 7))
(define (date-week-day d) (%fast-struct-ref d %date 'date-week-day 6))
(define (date-year-day d) (%fast-struct-ref d %date 'date-year-day 7))
(define (date-dst d) (%fast-struct-ref d %date 'date-dst 8))
(define (date-tz d) (%fast-struct-ref d %date 'date-tz 9))
(define (date-dst d) (%fast-struct-ref d %date 'date-dst 8))
(define (date-tz d) (%fast-struct-ref d %date 'date-tz 9))
#|
......@@ -232,8 +232,8 @@ doc>
|#
(define (seconds->list sec)
(apply append (map (lambda (x)
(list (make-keyword (car x)) (cdr x)))
(struct->list (seconds->date sec)))))
(list (make-keyword (car x)) (cdr x)))
(struct->list (seconds->date sec)))))
#|
......@@ -303,25 +303,25 @@ doc>
(error 'seconds->string "bad string ~S" format))
;; Convert the format string for C since conventions are different
(let ((len (string-length format))
(out (open-output-string))
(sec (if (real? seconds) (inexact->exact (round seconds)) seconds)))
(out (open-output-string))
(sec (if (real? seconds) (inexact->exact (round seconds)) seconds)))
(let Loop ((i 0))
(when (< i len)
(let ((cur-char (string-ref format i)))
(case cur-char
((#\%) ;; "%" ==> "%%"
(display "%%" out) (Loop (+ i 1)))
((#\~) (if (and (< i (- len 1)) (eq? (string-ref format (+ i 1)) #\~))
(begin
;; "~~" => "~"
(display #\~ out)
(Loop (+ i 2)))
(begin
;; "~c" => "%c" where c is not a %
(display #\% out)
(Loop (+ i 1)))))
(else (display cur-char out)
(Loop (+ i 1)))))))
(let ((cur-char (string-ref format i)))
(case cur-char
((#\%) ;; "%" ==> "%%"
(display "%%" out) (Loop (+ i 1)))
((#\~) (if (and (< i (- len 1)) (eq? (string-ref format (+ i 1)) #\~))
(begin
;; "~~" => "~"
(display #\~ out)
(Loop (+ i 2)))
(begin
;; "~c" => "%c" where c is not a %
(display #\% out)
(Loop (+ i 1)))))
(else (display cur-char out)
(Loop (+ i 1)))))))
;; String is converted in the "OUT" string port
(%seconds->string (get-output-string out) sec)))
......
;;;;
;;;; obsolete.stk -- Definition of functions which are obsolete.
;;;; Function defined here are candidate to disappear.
;;;; obsolete.stk -- Definition of functions which are obsolete.
;;;; Function defined here are candidate to disappear.
;;;;
;;;; Copyright © 2002-2008 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; Copyright © 2002-2018 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -22,7 +22,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 11-Jun-2002 17:54 (eg)
;;;; Last file update: 4-Jun-2008 12:28 (eg)
;;;; Last file update: 10-Sep-2018 17:18 (eg)
;;;;
......@@ -34,12 +34,12 @@
;;; 29-Aug-2004
(define (set-load-path! new-path)
(format (current-error-port)
"*** Obsolete function set-load-path!. Use load-path instead.\n")
"*** Obsolete function set-load-path!. Use load-path instead.\n")
(load-path new-path))
(define (set-load-suffixes! suffixes)
(format (current-error-port)
"*** Obsolete function set-load-suffixes!. Use load-suffixes instead.\n")
"*** Obsolete function set-load-suffixes!. Use load-suffixes instead.\n")
(load-suffixes suffixes))
;; 23-Sep-2004 (v 0.59)
......@@ -69,7 +69,8 @@
(define delete-directory remove-directory)
;; 05-May-2007 (v0.83)
(define current-second current-seconds)
;; current-second is now R7RS
;(define current-second current-seconds)
;; 04-Jun-2008 (v0.99)
(define %build-path-from-shell-variable build-path-from-shell-variable)
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 19:36 (eg)
;;;; Last file update: 27-Aug-2018 08:10 (eg)
;;;; Last file update: 11-Sep-2018 09:55 (eg)
;;;;
......@@ -864,6 +864,50 @@ doc>
;;;; 6.14 System Interface
;;;; ----------------------------------------------------------------------
#|
<doc R7RS current-jiffy
* (current-jiffy)
*
* Returns the number of ,(emph "jiffies") as an exact integer that
* have elapsed since an arbitrary, implementation-defined
* epoch. A jiffy is an implementation-defined fraction of
* a second which is defined by the return value of the
* |jiffies-per-second| procedure. The starting epoch is
* guaranteed to be constant during a run of the program,
* but may vary between runs.
doc>
|#
(define current-jiffy
;; This implementation probably allocates bignums on 32 bits machines
;; Therefore, the resolution should be lowered on these architectures.
(let ((initial-time (current-time))
(time->jiffy (lambda (t)
(+ (* (struct-ref t 'second) #e1e9)
(struct-ref t 'nanosecond)))))
(lambda ()
(- (time->jiffy (current-time))
(time->jiffy initial-time)))))
#|
<doc R7RS jiffies-per-second
* (jiffies-per-seconds)
*
* Returns an exact integer representing the number of jiffies
* per SI second. This value is an implementation-specified
* constant.
* @lisp
* (define (time-length)
* (let ((list (make-list 100000))
* (start (current-jiffy)))
* (length list)
* (/ (- (current-jiffy) start)
* (jiffies-per-second))))
* @end lisp
doc>
|#
(define (jiffies-per-second) #e1e9)
#|
<doc R7RS features
* (features)
......@@ -888,3 +932,4 @@ doc>
((pair? (car x)) (car x))
(else (list (car x)))))
all))))
/*
*
* s y s t e m . c -- System relative primitives
* s y s t e m . c -- System relative primitives
*
* Copyright © 1994-2012 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright © 1994-2018 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* Permission to use, copy, modify, distribute,and license this
......@@ -16,7 +16,7 @@
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 29-Mar-1994 10:57
* Last file update: 26-Feb-2012 23:14 (eg)
* Last file update: 10-Sep-2018 19:22 (eg)
*/
#include <unistd.h>
......@@ -380,13 +380,12 @@ DEFINE_PRIMITIVE("system", system, subr1, (SCM com))
}
/*
<doc EXT file-is-directory? file-is-regular? file-is-writable? file-is-readable? file-is-executable? file-exists?
<doc EXT file-is-directory? file-is-regular? file-is-writable? file-is-readable? file-is-executable?
* (file-is-directory? string)
* (file-is-regular? string)
* (file-is-readable? string)
* (file-is-writable? string)
* (file-is-executable? string)
* (file-exists? string)
*
* Returns |#t| if the predicate is true for the path name given in
* |string|; returns |#f| otherwise (or if |string| denotes a file
......@@ -429,6 +428,15 @@ DEFINE_PRIMITIVE("file-is-executable?", file_is_executablep, subr1, (SCM f))
}
/*
<doc R7RS file-exists?
* (file-exists? string)
*
* Returns |#t| if the path name given in |string| denotes an existing file;
* returns |#f| otherwise.
doc>
*/
DEFINE_PRIMITIVE("file-exists?", file_existsp, subr1, (SCM f))
{
struct stat info;
......@@ -553,7 +561,7 @@ DEFINE_PRIMITIVE("directory-files", directory_files, subr1, (SCM dirname))
for (d = readdir(dir); d ; d = readdir(dir)) {
if (d->d_name[0] == '.')
if ((d->d_name[1] == '\0') || (d->d_name[1] == '.' && d->d_name[2] == '\0'))
continue;
continue;
res = STk_cons(STk_Cstring2string(d->d_name), res);
}
closedir(dir);
......@@ -622,7 +630,7 @@ DEFINE_PRIMITIVE("temporary-file-name", tmp_file, subr0, (void))
MUT_LOCK(tmpnam_mutex);
for ( ; ; ) {
sprintf(buff, "/tmp/stklos%05d-%05x", pid, cpt++);
if (cpt > 100000) /* arbitrary limit to avoid infinite search */
if (cpt > 100000) /* arbitrary limit to avoid infinite search */
return STk_false;
if (access(buff, F_OK) == -1) break;
}
......@@ -652,7 +660,7 @@ DEFINE_PRIMITIVE("temporary-file-name", tmp_file, subr0, (void))
* @end lisp
doc>
*/
MUT_DECL(at_exit_mutex); /* The exit mutex */
MUT_DECL(at_exit_mutex); /* The exit mutex */
DEFINE_PRIMITIVE("register-exit-function!", at_exit, subr1, (SCM proc))
{
......@@ -740,13 +748,13 @@ DEFINE_PRIMITIVE("machine-type", machine_type, subr0, (void))
//EG: long allocated, used, calls;
//EG:
//EG: /* The result is a vector which contains
//EG: * 0 The total cpu used in ms
//EG: * 1 The number of cells currently in use.
//EG: * 0 The total cpu used in ms
//EG: * 1 The number of cells currently in use.
//EG: * 2 Total number of allocated cells
//EG: * 3 The number of cells used since the last call to get-internal-info
//EG: * 4 Number of gc calls
//EG: * 3 The number of cells used since the last call to get-internal-info
//EG: * 4 Number of gc calls
//EG: * 5 Total time used in the gc
//EG: * 6 A boolean indicating if Tk is initialized
//EG: * 6 A boolean indicating if Tk is initialized
//EG: */
//EG:
//EG: STk_gc_count_cells(&allocated, &used, &calls);
......@@ -798,15 +806,22 @@ doc>
DEFINE_PRIMITIVE("clock", clock, subr0, (void))
{
return STk_double2real((double) clock() /
CLOCKS_PER_SEC * (double) TIME_DIV_CONST);
CLOCKS_PER_SEC * (double) TIME_DIV_CONST);
}
/*
<doc EXT current-seconds
* (current-seconds)
*
* Returns the time since the Epoch (that is 00:00:00 UTC, January 1, 1970),
* measured in seconds.
* @l
* @bold("Note"): This ,(stklos) function should not be confused with
* the ,(rseven) primitive |current-second| which returns an inexact number
* and whose result is expressed using the International Atomic Time
* instead of UTC.
*
doc>
*/
DEFINE_PRIMITIVE("current-seconds", current_seconds, subr0, (void))
......@@ -814,6 +829,36 @@ DEFINE_PRIMITIVE("current-seconds", current_seconds, subr0, (void))
return STk_ulong2integer(time(NULL));
}
/*
<doc R7RS current-second
* (current-second)
*
* Returns an inexact number representing the current time on the
* International Atomic Time (TAI) scale. The value 0.0 represents
* midnight on January 1, 1970 TAI (equivalent to ten seconds before
* midnight Universal Time) and the value 1.0 represents one TAI
* second later.
* doc>
*/
/* Offset: https://fr.wikipedia.org/wiki/Temps_atomique_international */
#define TAI_OFFSET +37.0L
DEFINE_PRIMITIVE("current-second", current_second, subr0, (void))
{
/* R7RS states: Neither high accuracy nor high precision are
* required; in particular, returning Coordinated Universal Time plus
* a suitable constant might be the best an implementation can do.
*/
struct timespec now;
clock_gettime(CLOCK_REALTIME, &now);
return STk_double2real(TAI_OFFSET +
(double) now.tv_sec +
1.0E-9 * (double) now.tv_nsec);
}
/*
<doc current-time
* (current-time)
......@@ -823,14 +868,14 @@ doc>
*/
DEFINE_PRIMITIVE("current-time", current_time, subr0, (void))
{
struct timeval now;
struct timespec now;
SCM argv[3];
gettimeofday(&now, NULL);
clock_gettime(CLOCK_REALTIME, &now);
argv[2] = time_type;
argv[1] = STk_long2integer(now.tv_sec);
argv[0] = STk_long2integer(now.tv_usec);
argv[0] = STk_long2integer(now.tv_nsec);
return STk_make_struct(3, &argv[2]);
}
......@@ -893,7 +938,7 @@ DEFINE_PRIMITIVE("%seconds->date", seconds2date, subr1, (SCM seconds))
argv[2] = MAKE_INT(t->tm_yday + 1);
argv[1] = MAKE_INT(t->tm_isdst);
#ifdef DARWIN
argv[0] = MAKE_INT(0); /* Cannot figure how to find the timezone */
argv[0] = MAKE_INT(0); /* Cannot figure how to find the timezone */
#else
argv[0] = STk_long2integer(timezone);
#endif
......@@ -924,7 +969,7 @@ DEFINE_PRIMITIVE("date->seconds", date2seconds, subr1, (SCM date))
t.tm_mday = STk_integer_value(*p++);
t.tm_mon = STk_integer_value(*p++) - 1;
t.tm_year = STk_integer_value(*p++) - 1900;
t.tm_isdst = -1; /* to ignore DST */
t.tm_isdst = -1; /* to ignore DST */
n = mktime(&t);
if (n == (time_t)(-1)) STk_error("cannot convert date to seconds (~S)", date);
......@@ -1020,12 +1065,12 @@ DEFINE_PRIMITIVE("getenv", getenv, subr01, (SCM str))
{
char *tmp;
if (str) { /* One parameter: find the value of the given variable */
if (str) { /* One parameter: find the value of the given variable */
if (!STRINGP(str)) error_bad_string(str);
tmp = getenv(STRING_CHARS(str));
return tmp ? STk_Cstring2string(tmp) : STk_false;
} else { /* No parameter: give the complete environment */
} else { /* No parameter: give the complete environment */
extern char **environ;
return build_posix_environment(environ);
}
......@@ -1043,12 +1088,12 @@ DEFINE_PRIMITIVE("setenv!", setenv, subr2, (SCM var, SCM value))
{
char *s;
if (!STRINGP(var)) error_bad_string(var);
if (!STRINGP(var)) error_bad_string(var);
if (strchr(STRING_CHARS(var), '=')) STk_error("variable ~S contains a '='", var);
if (!STRINGP(value)) STk_error("value ~S is not a string", value);
if (!STRINGP(value)) STk_error("value ~S is not a string", value);
s = STk_must_malloc(strlen(STRING_CHARS(var)) +
strlen(STRING_CHARS(value)) + 2); /* 2 because of '=' & \0 */
strlen(STRING_CHARS(value)) + 2); /* 2 because of '=' & \0 */
sprintf(s, "%s=%s", STRING_CHARS(var), STRING_CHARS(value));
putenv(s);
return STk_void;
......@@ -1159,30 +1204,31 @@ int STk_init_system(void)
/* Create the system-date structure-type */
date_type = STk_make_struct_type(STk_intern("%date"),
STk_false,
LIST10(STk_intern("second"),
STk_intern("minute"),
STk_intern("hour"),
STk_intern("day"),
STk_intern("month"),
STk_intern("year"),
STk_intern("week-day"),
STk_intern("year-day"),
STk_intern("dst"),
STk_intern("tz")));
STk_false,
LIST10(STk_intern("second"),
STk_intern("minute"),
STk_intern("hour"),
STk_intern("day"),
STk_intern("month"),
STk_intern("year"),
STk_intern("week-day"),
STk_intern("year-day"),
STk_intern("dst"),
STk_intern("tz")));
STk_define_variable(STk_intern("%date"), date_type, current_module);
/* Create the time structure-type */
time_type = STk_make_struct_type(STk_intern("%time"),
STk_false,
LIST2(STk_intern("second"),
STk_intern("microsecond")));
STk_false,
LIST2(STk_intern("second"),
STk_intern("nanosecond")));
STk_define_variable(STk_intern("%time"), time_type, current_module);
/* Declare primitives */
ADD_PRIMITIVE(clock);
ADD_PRIMITIVE(date);
ADD_PRIMITIVE(current_seconds);
ADD_PRIMITIVE(current_second);
ADD_PRIMITIVE(current_time);
ADD_PRIMITIVE(sleep);
ADD_PRIMITIVE(seconds2date);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment