/* -*-C-*-
$Id: prosenv.c,v 1.17 2000/12/05 21:23:47 cph Exp $
Copyright (c) 1987-1999 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.
This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*/
/* Process-environment primitives. */
#include "scheme.h"
#include "prims.h"
#include "osenv.h"
#include "ostop.h"
#include "limits.h"
DEFINE_PRIMITIVE ("ENCODED-TIME", Prim_encoded_time, 0, 0,
"Return the current time as an integer.")
{
PRIMITIVE_RETURN (ulong_to_integer ((unsigned long) (OS_encoded_time ())));
}
#define DECODE_TIME_BODY(proc) \
{ \
PRIMITIVE_HEADER (2); \
{ \
SCHEME_OBJECT vec = (VECTOR_ARG (1)); \
unsigned int len = (VECTOR_LENGTH (vec)); \
struct time_structure ts; \
if (! (len >= 10)) \
error_bad_range_arg (1); \
proc (((time_t) (arg_ulong_integer (2))), &ts); \
FAST_VECTOR_SET (vec, 1, (ulong_to_integer (ts . second))); \
FAST_VECTOR_SET (vec, 2, (ulong_to_integer (ts . minute))); \
FAST_VECTOR_SET (vec, 3, (ulong_to_integer (ts . hour))); \
FAST_VECTOR_SET (vec, 4, (ulong_to_integer (ts . day))); \
FAST_VECTOR_SET (vec, 5, (ulong_to_integer (ts . month))); \
FAST_VECTOR_SET (vec, 6, (ulong_to_integer (ts . year))); \
FAST_VECTOR_SET (vec, 7, (ulong_to_integer (ts . day_of_week))); \
FAST_VECTOR_SET \
(vec, 8, \
(((ts . daylight_savings_time) < 0) \
? SHARP_F \
: (long_to_integer (ts . daylight_savings_time)))); \
FAST_VECTOR_SET \
(vec, 9, \
(((ts . time_zone) == INT_MAX) \
? SHARP_F \
: (long_to_integer (ts . time_zone)))); \
} \
PRIMITIVE_RETURN (UNSPECIFIC); \
}
DEFINE_PRIMITIVE ("DECODE-TIME", Prim_decode_time, 2, 2,
"Fill a vector with the second argument decoded.\n\
The vector's elements are:\n\
#(TAG second minute hour day month year day-of-week dst zone)")
DECODE_TIME_BODY (OS_decode_time)
DEFINE_PRIMITIVE ("DECODE-UTC", Prim_decode_utc, 2, 2,
"Fill a vector with the second argument decoded.\n\
The vector's elements are:\n\
#(TAG second minute hour day month year day-of-week dst zone)")
DECODE_TIME_BODY (OS_decode_utc)
DEFINE_PRIMITIVE ("ENCODE-TIME", Prim_encode_time, 1, 1,
"Return the file time corresponding to the time structure given.")
{
SCHEME_OBJECT vec;
unsigned int len;
struct time_structure ts;
PRIMITIVE_HEADER (1);
vec = (VECTOR_ARG (1));
len = (VECTOR_LENGTH (vec));
if (! (len >= 8))
error_bad_range_arg (1);
(ts . second) = (integer_to_ulong (FAST_VECTOR_REF (vec, 1)));
(ts . minute) = (integer_to_ulong (FAST_VECTOR_REF (vec, 2)));
(ts . hour) = (integer_to_ulong (FAST_VECTOR_REF (vec, 3)));
(ts . day) = (integer_to_ulong (FAST_VECTOR_REF (vec, 4)));
(ts . month) = (integer_to_ulong (FAST_VECTOR_REF (vec, 5)));
(ts . year) = (integer_to_ulong (FAST_VECTOR_REF (vec, 6)));
(ts . day_of_week) = (integer_to_ulong (FAST_VECTOR_REF (vec, 7)));
(ts . daylight_savings_time)
= (((len > 8) && (INTEGER_P (FAST_VECTOR_REF (vec, 8))))
? (integer_to_long (FAST_VECTOR_REF (vec, 8)))
: (-1));
(ts . time_zone)
= (((len > 9)
&& (INTEGER_P (FAST_VECTOR_REF (vec, 9)))
&& (integer_to_ulong_p (FAST_VECTOR_REF (vec, 9))))
? (integer_to_ulong (FAST_VECTOR_REF (vec, 9)))
: INT_MAX);
PRIMITIVE_RETURN (ulong_to_integer ((unsigned long) (OS_encode_time (&ts))));
}
DEFINE_PRIMITIVE ("SYSTEM-CLOCK", Prim_system_clock, 0, 0,
"Return the current process time in units of milliseconds.")
{
PRIMITIVE_HEADER (0);
PRIMITIVE_RETURN (double_to_integer (OS_process_clock ()));
}
DEFINE_PRIMITIVE ("REAL-TIME-CLOCK", Prim_real_time_clock, 0, 0,
"Return the current real time in units of milliseconds.")
{
PRIMITIVE_HEADER (0);
PRIMITIVE_RETURN (double_to_integer (OS_real_time_clock ()));
}
DEFINE_PRIMITIVE ("PROCESS-TIMER-CLEAR", Prim_process_timer_clear, 0, 0,
"Turn off the process timer.")
{
PRIMITIVE_HEADER (0);
OS_process_timer_clear ();
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("PROCESS-TIMER-SET", Prim_process_timer_set, 2, 2,
"Set the process timer.\n\
First arg FIRST says how long to wait until the first interrupt;\n\
second arg INTERVAL says how long to wait between interrupts after that.\n\
Both arguments are in units of milliseconds.")
{
PRIMITIVE_HEADER (2);
OS_process_timer_set ((arg_nonnegative_integer (1)),
(arg_nonnegative_integer (2)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("REAL-TIMER-CLEAR", Prim_real_timer_clear, 0, 0,
"Turn off the real timer.")
{
PRIMITIVE_HEADER (0);
OS_real_timer_clear ();
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("REAL-TIMER-SET", Prim_real_timer_set, 2, 2,
"Set the real timer.\n\
First arg FIRST says how long to wait until the first interrupt;\n\
second arg INTERVAL says how long to wait between interrupts after that.\n\
Both arguments are in units of milliseconds.")
{
PRIMITIVE_HEADER (2);
OS_real_timer_set ((arg_nonnegative_integer (1)),
(arg_nonnegative_integer (2)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("PROFILE-TIMER-CLEAR", Prim_profile_timer_clear, 0, 0,
"Turn off the profile timer.")
{
PRIMITIVE_HEADER (0);
OS_profile_timer_clear ();
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("PROFILE-TIMER-SET", Prim_profile_timer_set, 2, 2,
"Set the profile timer.\n\
First arg FIRST says how long to wait until the first interrupt;\n\
second arg INTERVAL says how long to wait between interrupts after that.\n\
Both arguments are in units of milliseconds.")
{
PRIMITIVE_HEADER (2);
OS_profile_timer_set ((arg_nonnegative_integer (1)),
(arg_nonnegative_integer (2)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("SETUP-TIMER-INTERRUPT", Prim_setup_timer_interrupt, 2, 2,
"This is an obsolete primitive; use `process-timer-set' instead.")
{
PRIMITIVE_HEADER (2);
if (((ARG_REF (1)) == SHARP_F) && ((ARG_REF (2)) == SHARP_F))
OS_process_timer_clear ();
else
{
unsigned long days = (arg_nonnegative_integer (1));
unsigned long centisec = (arg_nonnegative_integer (2));
OS_process_timer_set
((((days * 24 * 60 * 60 * 100) + centisec) * 10), 0);
}
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("WORKING-DIRECTORY-PATHNAME", Prim_working_dir_pathname, 0, 0,
"Return the current working directory as a string.")
{
PRIMITIVE_HEADER (0);
PRIMITIVE_RETURN (char_pointer_to_string
((unsigned char *) OS_working_dir_pathname ()));
}
DEFINE_PRIMITIVE ("SET-WORKING-DIRECTORY-PATHNAME!", Prim_set_working_dir_pathname, 1, 1,
"Change the current working directory to NAME.")
{
PRIMITIVE_HEADER (1);
OS_set_working_dir_pathname (STRING_ARG (1));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("SYSTEM-CALL-ERROR-MESSAGE", Prim_system_call_error_message, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
{
CONST char * message =
(OS_error_code_to_message (arg_nonnegative_integer (1)));
PRIMITIVE_RETURN
((message == 0) ? SHARP_F
: (char_pointer_to_string ((unsigned char *) message)));
}
}
syntax highlighted by Code2HTML, v. 0.9.1