home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / prosenv.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  8KB  |  228 lines
  1. /* -*-C-*-
  2.  
  3. $Id: prosenv.c,v 1.17 2000/12/05 21:23:47 cph Exp $
  4.  
  5. Copyright (c) 1987-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. /* Process-environment primitives. */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26. #include "osenv.h"
  27. #include "ostop.h"
  28. #include "limits.h"
  29.  
  30. DEFINE_PRIMITIVE ("ENCODED-TIME", Prim_encoded_time, 0, 0,
  31.   "Return the current time as an integer.")
  32. {
  33.   PRIMITIVE_RETURN (ulong_to_integer ((unsigned long) (OS_encoded_time ())));
  34. }
  35.  
  36. #define DECODE_TIME_BODY(proc)                        \
  37. {                                    \
  38.   PRIMITIVE_HEADER (2);                            \
  39.   {                                    \
  40.     SCHEME_OBJECT vec = (VECTOR_ARG (1));                \
  41.     unsigned int len = (VECTOR_LENGTH (vec));                \
  42.     struct time_structure ts;                        \
  43.     if (! (len >= 10))                            \
  44.       error_bad_range_arg (1);                        \
  45.     proc (((time_t) (arg_ulong_integer (2))), &ts);            \
  46.     FAST_VECTOR_SET (vec, 1, (ulong_to_integer (ts . second)));        \
  47.     FAST_VECTOR_SET (vec, 2, (ulong_to_integer (ts . minute)));        \
  48.     FAST_VECTOR_SET (vec, 3, (ulong_to_integer (ts . hour)));        \
  49.     FAST_VECTOR_SET (vec, 4, (ulong_to_integer (ts . day)));        \
  50.     FAST_VECTOR_SET (vec, 5, (ulong_to_integer (ts . month)));        \
  51.     FAST_VECTOR_SET (vec, 6, (ulong_to_integer (ts . year)));        \
  52.     FAST_VECTOR_SET (vec, 7, (ulong_to_integer (ts . day_of_week)));    \
  53.     FAST_VECTOR_SET                            \
  54.       (vec, 8,                                \
  55.        (((ts . daylight_savings_time) < 0)                \
  56.     ? SHARP_F                            \
  57.     : (long_to_integer (ts . daylight_savings_time))));        \
  58.     FAST_VECTOR_SET                            \
  59.       (vec, 9,                                \
  60.        (((ts . time_zone) == INT_MAX)                    \
  61.     ? SHARP_F                            \
  62.     : (long_to_integer (ts . time_zone))));                \
  63.   }                                    \
  64.   PRIMITIVE_RETURN (UNSPECIFIC);                    \
  65. }
  66.  
  67. DEFINE_PRIMITIVE ("DECODE-TIME", Prim_decode_time, 2, 2,
  68.   "Fill a vector with the second argument decoded.\n\
  69. The vector's elements are:\n\
  70.   #(TAG second minute hour day month year day-of-week dst zone)")
  71. DECODE_TIME_BODY (OS_decode_time)
  72.  
  73. DEFINE_PRIMITIVE ("DECODE-UTC", Prim_decode_utc, 2, 2,
  74.   "Fill a vector with the second argument decoded.\n\
  75. The vector's elements are:\n\
  76.   #(TAG second minute hour day month year day-of-week dst zone)")
  77. DECODE_TIME_BODY (OS_decode_utc)
  78.  
  79. DEFINE_PRIMITIVE ("ENCODE-TIME", Prim_encode_time, 1, 1,
  80.   "Return the file time corresponding to the time structure given.")
  81. {
  82.   SCHEME_OBJECT vec;
  83.   unsigned int len;
  84.   struct time_structure ts;
  85.   PRIMITIVE_HEADER (1);
  86.  
  87.   vec = (VECTOR_ARG (1));
  88.   len = (VECTOR_LENGTH (vec));
  89.   if (! (len >= 8))
  90.     error_bad_range_arg (1);
  91.   (ts . second) = (integer_to_ulong (FAST_VECTOR_REF (vec, 1)));
  92.   (ts . minute) = (integer_to_ulong (FAST_VECTOR_REF (vec, 2)));
  93.   (ts . hour) = (integer_to_ulong (FAST_VECTOR_REF (vec, 3)));
  94.   (ts . day) = (integer_to_ulong (FAST_VECTOR_REF (vec, 4)));
  95.   (ts . month) = (integer_to_ulong (FAST_VECTOR_REF (vec, 5)));
  96.   (ts . year) = (integer_to_ulong (FAST_VECTOR_REF (vec, 6)));
  97.   (ts . day_of_week) = (integer_to_ulong (FAST_VECTOR_REF (vec, 7)));
  98.   (ts . daylight_savings_time)
  99.     = (((len > 8) && (INTEGER_P (FAST_VECTOR_REF (vec, 8))))
  100.        ? (integer_to_long (FAST_VECTOR_REF (vec, 8)))
  101.        : (-1));
  102.   (ts . time_zone)
  103.     = (((len > 9)
  104.     && (INTEGER_P (FAST_VECTOR_REF (vec, 9)))
  105.     && (integer_to_ulong_p (FAST_VECTOR_REF (vec, 9))))
  106.        ? (integer_to_ulong (FAST_VECTOR_REF (vec, 9)))
  107.        : INT_MAX);
  108.   PRIMITIVE_RETURN (ulong_to_integer ((unsigned long) (OS_encode_time (&ts))));
  109. }
  110.  
  111. DEFINE_PRIMITIVE ("SYSTEM-CLOCK", Prim_system_clock, 0, 0,
  112.   "Return the current process time in units of milliseconds.")
  113. {
  114.   PRIMITIVE_HEADER (0);
  115.   PRIMITIVE_RETURN (double_to_integer (OS_process_clock ()));
  116. }
  117.  
  118. DEFINE_PRIMITIVE ("REAL-TIME-CLOCK", Prim_real_time_clock, 0, 0,
  119.   "Return the current real time in units of milliseconds.")
  120. {
  121.   PRIMITIVE_HEADER (0);
  122.   PRIMITIVE_RETURN (double_to_integer (OS_real_time_clock ()));
  123. }
  124.  
  125. DEFINE_PRIMITIVE ("PROCESS-TIMER-CLEAR", Prim_process_timer_clear, 0, 0,
  126.   "Turn off the process timer.")
  127. {
  128.   PRIMITIVE_HEADER (0);
  129.   OS_process_timer_clear ();
  130.   PRIMITIVE_RETURN (UNSPECIFIC);
  131. }
  132.  
  133. DEFINE_PRIMITIVE ("PROCESS-TIMER-SET", Prim_process_timer_set, 2, 2,
  134.   "Set the process timer.\n\
  135. First arg FIRST says how long to wait until the first interrupt;\n\
  136. second arg INTERVAL says how long to wait between interrupts after that.\n\
  137. Both arguments are in units of milliseconds.")
  138. {
  139.   PRIMITIVE_HEADER (2);
  140.   OS_process_timer_set ((arg_nonnegative_integer (1)),
  141.             (arg_nonnegative_integer (2)));
  142.   PRIMITIVE_RETURN (UNSPECIFIC);
  143. }
  144.  
  145. DEFINE_PRIMITIVE ("REAL-TIMER-CLEAR", Prim_real_timer_clear, 0, 0,
  146.   "Turn off the real timer.")
  147. {
  148.   PRIMITIVE_HEADER (0);
  149.   OS_real_timer_clear ();
  150.   PRIMITIVE_RETURN (UNSPECIFIC);
  151. }
  152.  
  153. DEFINE_PRIMITIVE ("REAL-TIMER-SET", Prim_real_timer_set, 2, 2,
  154.   "Set the real timer.\n\
  155. First arg FIRST says how long to wait until the first interrupt;\n\
  156. second arg INTERVAL says how long to wait between interrupts after that.\n\
  157. Both arguments are in units of milliseconds.")
  158. {
  159.   PRIMITIVE_HEADER (2);
  160.   OS_real_timer_set ((arg_nonnegative_integer (1)),
  161.              (arg_nonnegative_integer (2)));
  162.   PRIMITIVE_RETURN (UNSPECIFIC);
  163. }
  164.  
  165. DEFINE_PRIMITIVE ("PROFILE-TIMER-CLEAR", Prim_profile_timer_clear, 0, 0,
  166.   "Turn off the profile timer.")
  167. {
  168.   PRIMITIVE_HEADER (0);
  169.   OS_profile_timer_clear ();
  170.   PRIMITIVE_RETURN (UNSPECIFIC);
  171. }
  172.  
  173. DEFINE_PRIMITIVE ("PROFILE-TIMER-SET", Prim_profile_timer_set, 2, 2,
  174.   "Set the profile timer.\n\
  175. First arg FIRST says how long to wait until the first interrupt;\n\
  176. second arg INTERVAL says how long to wait between interrupts after that.\n\
  177. Both arguments are in units of milliseconds.")
  178. {
  179.   PRIMITIVE_HEADER (2);
  180.   OS_profile_timer_set ((arg_nonnegative_integer (1)),
  181.             (arg_nonnegative_integer (2)));
  182.   PRIMITIVE_RETURN (UNSPECIFIC);
  183. }
  184.  
  185. DEFINE_PRIMITIVE ("SETUP-TIMER-INTERRUPT", Prim_setup_timer_interrupt, 2, 2,
  186.   "This is an obsolete primitive; use `process-timer-set' instead.")
  187. {
  188.   PRIMITIVE_HEADER (2);
  189.   if (((ARG_REF (1)) == SHARP_F) && ((ARG_REF (2)) == SHARP_F))
  190.     OS_process_timer_clear ();
  191.   else
  192.     {
  193.       unsigned long days = (arg_nonnegative_integer (1));
  194.       unsigned long centisec = (arg_nonnegative_integer (2));
  195.       OS_process_timer_set
  196.     ((((days * 24 * 60 * 60 * 100) + centisec) * 10), 0);
  197.     }
  198.   PRIMITIVE_RETURN (UNSPECIFIC);
  199. }
  200.  
  201. DEFINE_PRIMITIVE ("WORKING-DIRECTORY-PATHNAME", Prim_working_dir_pathname, 0, 0,
  202.   "Return the current working directory as a string.")
  203. {
  204.   PRIMITIVE_HEADER (0);
  205.   PRIMITIVE_RETURN (char_pointer_to_string
  206.             ((unsigned char *) OS_working_dir_pathname ()));
  207. }
  208.  
  209. DEFINE_PRIMITIVE ("SET-WORKING-DIRECTORY-PATHNAME!", Prim_set_working_dir_pathname, 1, 1,
  210.   "Change the current working directory to NAME.")
  211. {
  212.   PRIMITIVE_HEADER (1);
  213.   OS_set_working_dir_pathname (STRING_ARG (1));
  214.   PRIMITIVE_RETURN (UNSPECIFIC);
  215. }
  216.  
  217. DEFINE_PRIMITIVE ("SYSTEM-CALL-ERROR-MESSAGE", Prim_system_call_error_message, 1, 1, 0)
  218. {
  219.   PRIMITIVE_HEADER (1);
  220.   {
  221.     CONST char * message =
  222.       (OS_error_code_to_message (arg_nonnegative_integer (1)));
  223.     PRIMITIVE_RETURN
  224.       ((message == 0) ? SHARP_F
  225.        : (char_pointer_to_string ((unsigned char *) message)));
  226.   }
  227. }
  228.