home *** CD-ROM | disk | FTP | other *** search
/ Il CD di internet / CD.iso / SOURCE / D / CLISP / CLISPSRC.TAR / clisp-1995-01-01 / src / misc.d < prev    next >
Encoding:
Text File  |  1994-12-12  |  25.6 KB  |  707 lines
  1. # Diverse Funktionen fⁿr CLISP
  2. # Bruno Haible 12.12.1994
  3.  
  4. #include "lispbibl.c"
  5. #include "arilev0.c"  # fⁿr high16, low16 in %%TIME,
  6.                       # fⁿr divu in GET-UNIVERSAL-TIME,
  7.                       # fⁿr mulu32 in GET-INTERNAL-RUN-TIME, GET-INTERNAL-REAL-TIME
  8.  
  9.  
  10. # Eigenwissen:
  11.  
  12. LISPFUNN(lisp_implementation_type,0)
  13. # (LISP-IMPLEMENTATION-TYPE), CLTL S. 447
  14.   { value1 = O(lisp_implementation_type_string); mv_count=1; }
  15.  
  16. LISPFUNN(lisp_implementation_version,0)
  17. # (LISP-IMPLEMENTATION-VERSION), CLTL S. 447
  18.   { value1 = OL(lisp_implementation_version_string); mv_count=1; }
  19.  
  20. LISPFUN(version,0,1,norest,nokey,0,NIL)
  21. # (SYSTEM::VERSION) liefert die Version des Runtime-Systems,
  22. # (SYSTEM::VERSION version) ⁿberprⁿft (am Anfang eines FAS-Files),
  23. # ob die Versionen des Runtime-Systems ⁿbereinstimmen.
  24.   { var reg1 object arg = popSTACK();
  25.     if (eq(arg,unbound))
  26.       { value1 = O(version); mv_count=1; }
  27.       else
  28.       { if (equal(arg,O(version)))
  29.           { value1 = NIL; mv_count=0; }
  30.           else
  31.           { fehler(error,
  32.                    DEUTSCH ? "Dieses File stammt von einer anderen Lisp-Version, mu▀ neu compiliert werden." :
  33.                    ENGLISH ? "This file was produced by another lisp version, must be recompiled." :
  34.                    FRANCAIS ? "Ce fichier provient d'une autre version de LISP et doit Ωtre recompilΘ." :
  35.                    ""
  36.                   );
  37.   }   }   }
  38.  
  39. #ifdef MACHINE_KNOWN
  40.  
  41. LISPFUNN(machinetype,0)
  42. # (MACHINE-TYPE), CLTL S. 447
  43.   { var reg1 object erg = O(machine_type_string);
  44.     if (nullp(erg)) # noch unbekannt?
  45.       { # ja -> holen
  46.         #ifdef HAVE_SYS_UTSNAME_H
  47.         var struct utsname utsname;
  48.         begin_system_call();
  49.         if ( uname(&utsname) <0) { OS_error(); }
  50.         end_system_call();
  51.         pushSTACK(asciz_to_string(&!utsname.machine));
  52.         funcall(L(nstring_upcase),1); # in Gro▀buchstaben umwandeln
  53.         erg = value1;
  54.         #else
  55.         # Betriebssystem-Kommando 'arch' ausfⁿhren und dessen Output
  56.         # in einen String umleiten:
  57.         # (string-upcase
  58.         #   (with-open-stream (stream (make-pipe-input-stream "/bin/arch"))
  59.         #     (read-line stream nil nil)
  60.         # ) )
  61.         pushSTACK(asciz_to_string("/bin/arch"));
  62.         funcall(L(make_pipe_input_stream),1); # (MAKE-PIPE-INPUT-STREAM "/bin/arch")
  63.         pushSTACK(value1); # Stream retten
  64.         pushSTACK(value1); pushSTACK(NIL); pushSTACK(NIL);
  65.         funcall(L(read_line),3); # (READ-LINE stream NIL NIL)
  66.         pushSTACK(value1); # Ergebnis (kann auch NIL sein) retten
  67.         stream_close(&STACK_1); # Stream schlie▀en
  68.         if (!nullp(STACK_0))
  69.           { erg = string_upcase(STACK_0); } # in Gro▀buchstaben umwandeln
  70.           else
  71.           { erg = NIL; }
  72.         skipSTACK(2);
  73.         #endif
  74.         # Das Ergebnis merken wir uns fⁿr's nΣchste Mal:
  75.         O(machine_type_string) = erg;
  76.       }
  77.     value1 = erg; mv_count=1;
  78.   }
  79.  
  80. LISPFUNN(machine_version,0)
  81. # (MACHINE-VERSION), CLTL S. 447
  82.   { var reg1 object erg = O(machine_version_string);
  83.     if (nullp(erg)) # noch unbekannt?
  84.       { # ja -> holen
  85.         #ifdef HAVE_SYS_UTSNAME_H
  86.         var struct utsname utsname;
  87.         begin_system_call();
  88.         if ( uname(&utsname) <0) { OS_error(); }
  89.         end_system_call();
  90.         pushSTACK(asciz_to_string(&!utsname.machine));
  91.         funcall(L(nstring_upcase),1); # in Gro▀buchstaben umwandeln
  92.         erg = value1;
  93.         #else
  94.         # Betriebssystem-Kommando 'arch -k' ausfⁿhren und dessen Output
  95.         # in einen String umleiten:
  96.         # (string-upcase
  97.         #   (with-open-stream (stream (make-pipe-input-stream "/bin/arch -k"))
  98.         #     (read-line stream nil nil)
  99.         # ) )
  100.         pushSTACK(asciz_to_string("/bin/arch -k"));
  101.         funcall(L(make_pipe_input_stream),1); # (MAKE-PIPE-INPUT-STREAM "/bin/arch -k")
  102.         pushSTACK(value1); # Stream retten
  103.         pushSTACK(value1); pushSTACK(NIL); pushSTACK(NIL);
  104.         funcall(L(read_line),3); # (READ-LINE stream NIL NIL)
  105.         pushSTACK(value1); # Ergebnis (kann auch NIL sein) retten
  106.         stream_close(&STACK_1); # Stream schlie▀en
  107.         funcall(L(string_upcase),1); skipSTACK(1); # in Gro▀buchstaben umwandeln
  108.         #endif
  109.         # Das Ergebnis merken wir uns fⁿr's nΣchste Mal:
  110.         O(machine_version_string) = erg = value1;
  111.       }
  112.     value1 = erg; mv_count=1;
  113.   }
  114.  
  115. LISPFUNN(machine_instance,0)
  116. # (MACHINE-INSTANCE), CLTL S. 447
  117.   { var reg1 object erg = O(machine_instance_string);
  118.     if (nullp(erg)) # noch unbekannt?
  119.       { # ja -> Hostname abfragen und dessen Internet-Adresse holen:
  120.         # (let* ((hostname (unix:gethostname))
  121.         #        (address (unix:gethostbyname hostname)))
  122.         #   (if (or (null address) (zerop (length address)))
  123.         #     hostname
  124.         #     (apply #'string-concat hostname " ["
  125.         #       (let ((l nil))
  126.         #         (dotimes (i (length address))
  127.         #           (push (sys::decimal-string (aref address i)) l)
  128.         #           (push "." l)
  129.         #         )
  130.         #         (setf (car l) "]") ; statt (pop l) (push "]" l)
  131.         #         (nreverse l)
  132.         # ) ) ) )
  133.         #if defined(HAVE_GETHOSTNAME)
  134.         var char hostname[MAXHOSTNAMELEN+1];
  135.         # Hostname holen:
  136.         begin_system_call();
  137.         if ( gethostname(&!hostname,MAXHOSTNAMELEN) <0) { OS_error(); }
  138.         end_system_call();
  139.         hostname[MAXHOSTNAMELEN] = '\0'; # und durch ein Nullbyte abschlie▀en
  140.         #elif defined(HAVE_SYS_UTSNAME_H)
  141.         # Hostname u.a. holen:
  142.         var struct utsname utsname;
  143.         begin_system_call();
  144.         if ( uname(&utsname) <0) { OS_error(); }
  145.         end_system_call();
  146.         #define hostname utsname.nodename
  147.         #else
  148.         ??
  149.         #endif
  150.         erg = asciz_to_string(&!hostname); # Hostname als Ergebnis
  151.         #ifdef HAVE_GETHOSTBYNAME
  152.         pushSTACK(erg); # Hostname als 1. String
  153.         { var reg5 uintC stringcount = 1;
  154.           # Internet-Information holen:
  155.           var reg4 struct hostent * h = gethostbyname(&!hostname);
  156.           if ((!(h == (struct hostent *)NULL)) && (!(h->h_addr == (char*)NULL))
  157.               && (h->h_length > 0)
  158.              )
  159.             { pushSTACK(asciz_to_string(" ["));
  160.              {var reg2 uintB* ptr = (uintB*)h->h_addr;
  161.               var reg3 uintC count;
  162.               dotimesC(count,h->h_length,
  163.                 pushSTACK(fixnum(*ptr++));
  164.                 funcall(L(decimal_string),1); # nΣchstes Byte in dezimal
  165.                 pushSTACK(value1);
  166.                 pushSTACK(asciz_to_string(".")); # und ein Punkt als Trennung
  167.                 );
  168.               STACK_0 = asciz_to_string("]"); # kein Punkt am Schlu▀
  169.               stringcount += (2*h->h_length + 1);
  170.             }}
  171.           # Strings zusammenhΣngen:
  172.           erg = string_concat(stringcount);
  173.         }
  174.         #endif
  175.         #undef hostname
  176.         # Das Ergebnis merken wir uns fⁿr's nΣchste Mal:
  177.         O(machine_instance_string) = erg;
  178.       }
  179.     value1 = erg; mv_count=1;
  180.   }
  181.  
  182. #endif # MACHINE_KNOWN
  183.  
  184. #ifdef HAVE_ENVIRONMENT
  185.  
  186. LISPFUNN(get_env,1)
  187. # (SYSTEM::GETENV string) liefert den zu string im Betriebssystem-Environment
  188. # assoziierten String oder NIL.
  189.   { var reg2 object arg = popSTACK();
  190.     if (stringp(arg))
  191.       { var reg1 const char* found;
  192.         begin_system_call();
  193.         found = getenv(TheAsciz(string_to_asciz(arg)));
  194.         end_system_call();
  195.         if (!(found==NULL))
  196.           { value1 = asciz_to_string(found); } # gefunden -> String als Wert
  197.           else
  198.           { value1 = NIL; } # nicht gefunden -> Wert NIL
  199.       }
  200.       else
  201.       { value1 = NIL; } # Kein String -> Wert NIL
  202.     mv_count=1;
  203.   }
  204.  
  205. #endif
  206.  
  207. LISPFUNN(software_type,0)
  208. # (SOFTWARE-TYPE), CLTL S. 448
  209.   { value1 = OL(software_type_string); mv_count=1; }
  210.  
  211. LISPFUNN(software_version,0)
  212. # (SOFTWARE-VERSION), CLTL S. 448
  213.   { value1 = OL(software_version_string); mv_count=1; }
  214.  
  215. LISPFUNN(language,3)
  216. # (SYS::LANGUAGE english deutsch francais) liefert je nach der aktuellen
  217. # Sprache das entsprechende Argument.
  218.   { value1 = (ENGLISH ? STACK_2 :
  219.               DEUTSCH ? STACK_1 :
  220.               FRANCAIS ? STACK_0 :
  221.               NIL
  222.               );
  223.     mv_count=1;
  224.     skipSTACK(3);
  225.   }
  226.  
  227. LISPFUNN(identity,1)
  228. # (IDENTITY object), CLTL S. 448
  229.   { value1 = popSTACK(); mv_count=1; }
  230.  
  231. LISPFUNN(address_of,1)
  232. # (SYS::ADDRESS-OF object) liefert die Adresse von object
  233.   { var reg1 object arg = popSTACK();
  234.     #if defined(WIDE_HARD)
  235.       value1 = UQ_to_I(untype(arg));
  236.     #elif defined(WIDE_SOFT)
  237.       value1 = UL_to_I(untype(arg));
  238.     #else
  239.       value1 = UL_to_I(as_oint(arg));
  240.     #endif
  241.     mv_count=1;
  242.   }
  243.  
  244.  
  245. # Zeitfunktionen:
  246.  
  247. #ifdef TIME_ATARI
  248.   # Zwei kleinere Bugs:
  249.   # - Wrap-Around der Uhrzeit nach 248 Tagen,
  250.   # - LISP-Uhr geht um +/- 1 Sekunde falsch gegenⁿber der Atari-Uhr
  251.   #   (weil die beim LISP-System-Start abgefragte Atari-Uhr 0 bis 2 Sekunden
  252.   #    nachgeht).
  253.   # Decoded Time =
  254.   #   Sekunde, Minute, Stunde, Tag, Monat, Jahr, Wochentag, Sommerzeit, Zeitzone
  255.   # Universal Time =
  256.   #   Sekunden seit 1.1.1900
  257.   # Internal Time =
  258.   #   200stel Sekunden seit LISP-System-Start
  259. #endif
  260. #ifdef TIME_AMIGAOS
  261.   # Ein kleineres Bug:
  262.   # - Wrap-Around der Uhrzeit nach 2.7 Jahren.
  263.   # Decoded Time =
  264.   #   Sekunde, Minute, Stunde, Tag, Monat, Jahr, Wochentag, Sommerzeit, Zeitzone
  265.   # Universal Time =
  266.   #   Sekunden seit 1.1.1900
  267.   # Internal Time =
  268.   #   50stel Sekunden seit LISP-System-Start
  269. #endif
  270. #ifdef TIME_MSDOS
  271.   # Ein kleineres Bug:
  272.   # - Wrap-Around der Uhrzeit nach 1.36 Jahren.
  273.   # Decoded Time =
  274.   #   Sekunde, Minute, Stunde, Tag, Monat, Jahr, Wochentag, Sommerzeit, Zeitzone
  275.   # Universal Time =
  276.   #   Sekunden seit 1.1.1900
  277.   # Internal Time =
  278.   #   100stel Sekunden seit LISP-System-Start
  279. #endif
  280. #if defined(TIME_UNIX_TIMES) || defined(TIME_RISCOS)
  281.   # Zwei kleinere Bugs:
  282.   # - Wrap-Around der Uhrzeit nach vielen Tagen,
  283.   # - LISP-Uhr geht um max. 1 Sekunde nach gegenⁿber der wahren Uhr.
  284.   # Decoded Time =
  285.   #   Sekunde, Minute, Stunde, Tag, Monat, Jahr, Wochentag, Sommerzeit, Zeitzone
  286.   # Universal Time =
  287.   #   Sekunden seit 1.1.1900
  288.   # Internal Time =
  289.   #   CLK_TCK-stel Sekunden seit LISP-System-Start
  290. #endif
  291. #ifdef TIME_UNIX
  292.   # Ein kleineres Bug:
  293.   # - %%TIME funktioniert nur fⁿr Zeitdifferenzen <= 194 Tagen.
  294.   # Decoded Time =
  295.   #   Sekunde, Minute, Stunde, Tag, Monat, Jahr, Wochentag, Sommerzeit, Zeitzone
  296.   # Universal Time =
  297.   #   Sekunden seit 1.1.1900
  298.   # Internal Time =
  299.   #   Mikrosekunden seit LISP-System-Start
  300. #endif
  301.  
  302. #ifdef TIME_RELATIVE
  303.  
  304. # Uhrzeit und Datum beim LISP-Start:
  305.   local decoded_time realstart_datetime;
  306.  
  307. # UP: Berechnet die Uhrzeit beim LISP-System-Start als Universal Time.
  308. # calc_start_UT(&timepoint)
  309. # > decoded_time timepoint: Zeit beim LISP-System-Start
  310. # < ergebnis: Universal Time
  311. # kann GC ausl÷sen
  312.   local object calc_start_UT (decoded_time* timepoint);
  313.   local object calc_start_UT(timepoint)
  314.     var reg1 decoded_time* timepoint;
  315.     { # (ENCODE-UNIVERSAL-TIME Sekunden Minuten Stunden Tag Monat Jahr) ausfⁿhren:
  316.       pushSTACK(timepoint->Sekunden);
  317.       pushSTACK(timepoint->Minuten);
  318.       pushSTACK(timepoint->Stunden);
  319.       pushSTACK(timepoint->Tag);
  320.       pushSTACK(timepoint->Monat);
  321.       pushSTACK(timepoint->Jahr);
  322.       funcall(S(encode_universal_time),6);
  323.       # als Start-Universal-Time abspeichern:
  324.       return O(start_UT) = value1;
  325.     }
  326.  
  327. # UP: Merkt sich die Uhrzeit beim LISP-System-Start.
  328. # set_start_time(&timepoint);
  329. # > timepoint: Zeit beim LISP-System-Start
  330. # >   timepoint.Sekunden in {0,...,59},
  331. # >   timepoint.Minuten in {0,...,59},
  332. # >   timepoint.Stunden in {0,...,23},
  333. # >   timepoint.Tag in {1,...,31},
  334. # >   timepoint.Monat in {1,...,12},
  335. # >   timepoint.Jahr in {1980,...,2999},
  336. # >   jeweils als Fixnums.
  337. # kann GC ausl÷sen
  338.   global void set_start_time (decoded_time* timepoint);
  339.   global void set_start_time(timepoint)
  340.     var reg1 decoded_time* timepoint;
  341.     { # Start-Zeit merken:
  342.       realstart_datetime = *timepoint;
  343.       # und, wenn m÷glich, gleich in Universal Time umwandeln:
  344.       if (!eq(Symbol_function(S(encode_universal_time)),unbound))
  345.         # Ist ENCODE-UNIVERSAL-TIME definiert -> sofort in UT umwandeln:
  346.         { calc_start_UT(timepoint); }
  347.     }
  348.  
  349. #endif
  350.  
  351. # Liefert die Uhrzeit in Sekunden (seit Systemstart bzw. 1.1.1900) als uintL.
  352.   local uintL real_time_sec (void);
  353.   local uintL real_time_sec()
  354.     {
  355.      #ifdef TIME_1
  356.       var reg2 uintL real_time = get_real_time();
  357.       # real_time := floor(real_time,ticks_per_second) :
  358.       #if (ticks_per_second == 1000000UL)
  359.         divu_3216_3216(real_time>>6,ticks_per_second>>6,real_time=,);
  360.       #elif (ticks_per_second < bit(16))
  361.         divu_3216_3216(real_time,ticks_per_second,real_time=,);
  362.       #else
  363.         divu_3232_3232(real_time,ticks_per_second,real_time=,);
  364.       #endif
  365.      #endif
  366.      #ifdef TIME_2
  367.       var reg2 uintL real_time = (get_real_time())->tv_sec; # Sekunden
  368.       #ifdef TIME_UNIX
  369.       # real_time sind Sekunden seit 1.1.1970
  370.       real_time = 2208988800UL+real_time; # 25567*24*60*60 Sekunden zwischen 1.1.1900 und 1.1.1970
  371.       #endif
  372.      #endif
  373.      return real_time;
  374.     }
  375.  
  376. LISPFUNN(get_universal_time,0)
  377. # (get-universal-time), CLTL S. 445
  378. #ifdef TIME_RELATIVE
  379.   # (defun get-universal-time ()
  380.   #   (+ (sys::get-start-time)
  381.   #      (floor (get-internal-real-time) internal-time-units-per-second)
  382.   # ) )
  383.   { var reg1 object start_time = O(start_UT);
  384.     if (nullp(start_time)) # Start-Universal-Time noch NIL ?
  385.       # nein -> schon berechnet.
  386.       # ja -> jetzt erst berechnen:
  387.       { start_time = calc_start_UT(&realstart_datetime); }
  388.     # start_time = die Uhrzeit des LISP-System-Starts in Universal Time.
  389.     pushSTACK(start_time);
  390.     pushSTACK(UL_to_I(real_time_sec())); # Sekunden seit Systemstart
  391.     funcall(L(plus),2); # addieren
  392.   }
  393. #endif
  394. #ifdef TIME_ABSOLUTE
  395.   { value1 = UL_to_I(real_time_sec()); mv_count=1; }
  396. #endif
  397.  
  398. #ifdef UNIX
  399. LISPFUN(default_time_zone,0,1,norest,nokey,0,NIL)
  400. # (sys::default-time-zone) liefert die aktuelle Zeitzone.
  401. # (sys::default-time-zone UTstunde) liefert die aktuelle Zeitzone zu einem
  402. # bestimmten Zeitpunkt.
  403. # 1. Wert: Zeitzone mit Sommerzeit-Berⁿcksichtigung.
  404. # 2. Wert: Sommerzeit-p.
  405.   { # Da die Zeitzone oft per TZ-Environment-Variable einstellbar ist, wird
  406.     # sie hΣufig au▀erhalb des Kernels verwaltet. Man hat nur per localtime()
  407.     # und gmtime() Zugriff auf sie.
  408.     # Methode:
  409.     #   Zeitzone = (gmtime(t) - localtime(t))/3600.
  410.     #   Sommerzeit-p wird dem Ergebnis von localtime(t) entnommen.
  411.     var reg4 object arg = popSTACK();
  412.     var time_t now;
  413.     if (posfixnump(arg)
  414.         && (posfixnum_to_L(arg) > 613608) # arg > 1.1.1970
  415.         && (posfixnum_to_L(arg) < 1314888) # arg < 1.1.2050
  416.        )
  417.       # bestimmter Zeitpunkt
  418.       # Annahme: time_t ist die Anzahl der Sekunden seit 1.1.1970. ??
  419.       { now = (posfixnum_to_L(arg) - 613606) * 3600; }
  420.       else
  421.       # jetzt
  422.       { begin_system_call(); time(&now); end_system_call(); }
  423.     { var struct tm now_local;
  424.       var struct tm now_gm;
  425.       begin_system_call();
  426.       now_local = *(localtime(&now));
  427.       now_gm = *(gmtime(&now));
  428.       end_system_call();
  429.       # secondswest = mktime(now_gm) - mktime(now_local); wΣre sch÷n.
  430.       # mktime() ist allerdings nicht weit verbreitet. Unter SunOS4 mⁿ▀te man
  431.       # timegm() nehmen. Daher tun wir's selber:
  432.      {var reg5 sintL dayswest = # Tage-Differenz, kann als 0,1,-1 angenommen werden
  433.         (now_gm.tm_year < now_local.tm_year ? -1 :
  434.          now_gm.tm_year > now_local.tm_year ? 1 :
  435.          (now_gm.tm_mon < now_local.tm_mon ? -1 :
  436.           now_gm.tm_mon > now_local.tm_mon ? 1 :
  437.           (now_gm.tm_mday < now_local.tm_mday ? -1 :
  438.            now_gm.tm_mday > now_local.tm_mday ? 1 :
  439.            0
  440.         )));
  441.       var reg3 sintL hourswest = 24*dayswest + (sintL)(now_gm.tm_hour - now_local.tm_hour);
  442.       var reg2 sintL minuteswest = 60*hourswest + (sintL)(now_gm.tm_min - now_local.tm_min);
  443.       var reg1 sintL secondswest = 60*minuteswest + (sintL)(now_gm.tm_sec - now_local.tm_sec);
  444.       # Zeitzone in Stunden = (Zeitzone in Sekunden / 3600) :
  445.       pushSTACK(L_to_I(secondswest));
  446.       pushSTACK(fixnum(3600));
  447.       funcall(L(durch),2);
  448.       # Sommerzeit-p entnehmen:
  449.       # tm_isdst < 0 bedeutet "unbekannt"; wir nehmen an, keine Sommerzeit.
  450.       value2 = (now_local.tm_isdst > 0 ? T : NIL);
  451.       mv_count=2;
  452.   } }}
  453. #endif
  454.  
  455. LISPFUNN(get_internal_run_time,0)
  456. # (GET-INTERNAL-RUN-TIME), CLTL S. 446
  457.   { var timescore tm;
  458.     get_running_times(&tm); # Run-Time seit LISP-System-Start abfragen
  459.    #ifdef TIME_1
  460.     value1 = UL_to_I(tm.runtime); mv_count=1; # in Integer umwandeln
  461.    #endif
  462.    #ifdef TIME_2
  463.     { var reg1 internal_time* tp = &tm.runtime; # Run-Time
  464.       # in Mikrosekunden umwandeln: tp->tv_sec * ticks_per_second + tp->tv_usec
  465.       #ifdef intQsize
  466.       value1 = UQ_to_I((uintQ)(tp->tv_sec) * ticks_per_second + (uintQ)(tp->tv_usec));
  467.       #else
  468.       {var reg3 uintL run_time_hi;
  469.        var reg2 uintL run_time_lo;
  470.        mulu32(tp->tv_sec,ticks_per_second, run_time_hi=,run_time_lo=);
  471.        if ((run_time_lo += tp->tv_usec) < tp->tv_usec) { run_time_hi += 1; }
  472.        value1 = L2_to_I(run_time_hi,run_time_lo);
  473.       }
  474.       #endif
  475.       mv_count=1;
  476.     }
  477.    #endif
  478.   }
  479.  
  480. LISPFUNN(get_internal_real_time,0)
  481. # (GET-INTERNAL-REAL-TIME), CLTL S. 446
  482. #ifdef TIME_1
  483.   { value1 = UL_to_I(get_real_time()); # Real-Time seit LISP-System-Start, als Integer
  484.     mv_count=1;
  485.   }
  486. #endif
  487. #ifdef TIME_2
  488.   { var reg1 internal_time* tp = get_real_time(); # Real-Time absolut
  489.     # in Mikrosekunden umwandeln: tp->tv_sec * ticks_per_second + tp->tv_usec
  490.     #ifdef intQsize
  491.     value1 = UQ_to_I((uintQ)(tp->tv_sec) * ticks_per_second + (uintQ)(tp->tv_usec));
  492.     #else
  493.     {var reg3 uintL real_time_hi;
  494.      var reg2 uintL real_time_lo;
  495.      mulu32(tp->tv_sec,ticks_per_second, real_time_hi=,real_time_lo=);
  496.      if ((real_time_lo += tp->tv_usec) < tp->tv_usec) { real_time_hi += 1; }
  497.      value1 = L2_to_I(real_time_hi,real_time_lo);
  498.     }
  499.     #endif
  500.     mv_count=1;
  501.   }
  502. #endif
  503.  
  504. #ifdef SLEEP_1
  505. LISPFUNN(sleep,1)
  506. #if defined(TIME_ATARI) || defined(TIME_MSDOS) || defined(RISCOS)
  507. # (SYSTEM::%SLEEP delay) wartet delay/200 bzw. delay/100 Sekunden.
  508. # Argument delay mu▀ ein Integer >=0, <2^32 (TIME_MSDOS: sogar <2^31) sein.
  509.   { var reg2 uintL delay = I_to_UL(popSTACK()); # PausenlΣnge
  510.     #ifdef EMUNIX_PORTABEL
  511.     #ifdef EMUNIX_OLD_8e
  512.     if (!(_osmode == DOS_MODE))
  513.     #else
  514.     if (TRUE)
  515.     #endif
  516.       # Unter OS/2 (Multitasking!) nicht CPU-Zeit verbraten!
  517.       # select erlaubt eine wundersch÷ne Implementation von usleep():
  518.       { loop
  519.           { var reg4 uintL start_time = get_real_time();
  520.             { var struct timeval timeout; # Zeitintervall
  521.               divu_3216_3216(delay,ticks_per_second, timeout.tv_sec =, timeout.tv_usec = 1000000/ticks_per_second * (uintL) );
  522.               begin_system_call();
  523.              {var reg1 int ergebnis = select(FD_SETSIZE,NULL,NULL,NULL,&timeout);
  524.               end_system_call();
  525.               if ((ergebnis<0) && !(errno==EINTR)) { OS_error(); }
  526.             }}
  527.             interruptp( { pushSTACK(S(sleep)); tast_break(); } ); # evtl. Break-Schleife aufrufen
  528.            {var reg3 uintL end_time = get_real_time();
  529.             var reg1 uintL slept = end_time - start_time; # so lang haben wir geschlafen
  530.             # Haben wir genug geschlafen?
  531.             if (slept >= delay) break;
  532.             # Wie lange mⁿssen wir noch schlafen?
  533.             delay -= slept;
  534.           }}
  535.       }
  536.       else
  537.     #endif
  538.     { var reg1 uintL endtime = get_real_time() + delay; # zur momentanen Real-Time addieren,
  539.       # ergibt Zeit, bis zu der zu warten ist.
  540.       # warten, bis die Real-Time bei endtime angelangt ist:
  541.       #ifdef TIME_ATARI
  542.       do {} until (get_real_time() == endtime);
  543.       #else # MSDOS rⁿckt die Uhr jedesmal um 5 oder 6 Ticks auf einmal weiter.
  544.       do {} until ((sintL)(get_real_time()-endtime) >= 0);
  545.       #endif
  546.     }
  547.     value1 = NIL; mv_count=1; # 1 Wert NIL
  548.   }
  549. #endif
  550. #ifdef TIME_AMIGAOS
  551. # (SYSTEM::%SLEEP delay) wartet delay/50 Sekunden.
  552. # Argument delay mu▀ ein Integer >=0, <2^32 sein.
  553.   { var reg2 uintL delay = I_to_UL(popSTACK()); # PausenlΣnge
  554.     if (delay>0) { begin_system_call(); Delay(delay); end_system_call(); }
  555.     value1 = NIL; mv_count=1; # 1 Wert NIL
  556.   }
  557. #endif
  558. #endif
  559. #ifdef SLEEP_2
  560. #ifdef TIME_UNIX_TIMES
  561. # Ein sehr unvollkommener Ersatz fⁿr die gettimeofday-Funktion.
  562. # Taugt nur fⁿr die Messung von Zeitdifferenzen!
  563.   local int gettimeofday (struct timeval * tp, void* tzp);
  564.   local int gettimeofday(tp,tzp)
  565.     var reg2 struct timeval * tp;
  566.     var void* tzp;
  567.     { if (!(tp==NULL))
  568.         { var reg1 uintL realtime = get_real_time();
  569.           # in Sekunden und Mikrosekunden umwandeln:
  570.           tp->tv_sec = floor(realtime,ticks_per_second);
  571.           tp->tv_usec = (realtime % ticks_per_second) * floor(2*1000000+ticks_per_second,2*ticks_per_second);
  572.         }
  573.       return 0;
  574.     }
  575. #endif
  576. LISPFUNN(sleep,2)
  577. #if defined(TIME_UNIX) || defined(TIME_UNIX_TIMES)
  578. # (SYSTEM::%SLEEP delay-seconds delay-useconds) wartet
  579. # delay-seconds Sekunden und delay-useconds Mikrosekunden.
  580. # Argument delay-seconds mu▀ ein Fixnum >=0, <=16700000 sein,
  581. # Argument delay-useconds mu▀ ein Fixnum >=0, <=1000000 sein.
  582.   { var reg3 uintL useconds = posfixnum_to_L(popSTACK());
  583.     var reg2 uintL seconds = posfixnum_to_L(popSTACK());
  584.     begin_system_call();
  585.     loop
  586.       { var struct timeval start_time;
  587.         var struct timeval end_time;
  588.         if (!( gettimeofday(&start_time,NULL) ==0)) { OS_error(); }
  589.         #ifdef HAVE_SELECT
  590.           # select erlaubt eine wundersch÷ne Implementation von usleep():
  591.           { var struct timeval timeout; # Zeitintervall
  592.             timeout.tv_sec = seconds; timeout.tv_usec = useconds;
  593.            {var reg1 int ergebnis;
  594.             ergebnis = select(FD_SETSIZE,NULL,NULL,NULL,&timeout);
  595.             if ((ergebnis<0) && !(errno==EINTR)) { OS_error(); }
  596.           }}
  597.         #else
  598.           if (seconds>0) { sleep(seconds); }
  599.           #ifdef HAVE_USLEEP
  600.           if (useconds>0) { usleep(useconds); }
  601.           #endif
  602.         #endif
  603.         interruptp(
  604.           { end_system_call();
  605.             pushSTACK(S(sleep)); tast_break(); # evtl. Break-Schleife aufrufen
  606.             begin_system_call();
  607.           });
  608.         if (!( gettimeofday(&end_time,NULL) ==0)) { OS_error(); }
  609.        {# ▄berprⁿfen, ob wir genⁿgend lang geschlafen haben, oder ob
  610.         # wir wegen eines Signals zu frⁿh aufgeweckt wurden:
  611.         var struct timeval slept; # so lang haben wir geschlafen
  612.         # sozusagen sub_internal_time(end_time,start_time, slept);
  613.         slept.tv_sec = end_time.tv_sec - start_time.tv_sec;
  614.         if (end_time.tv_usec < start_time.tv_usec)
  615.           { end_time.tv_usec += 1000000; slept.tv_sec -= 1; }
  616.         slept.tv_usec = end_time.tv_usec - start_time.tv_usec;
  617.         # Haben wir genug geschlafen?
  618.         if ((slept.tv_sec > seconds)
  619.             || ((slept.tv_sec == seconds) && (slept.tv_usec >= useconds))
  620.            )
  621.           break;
  622.         # Wie lange mⁿssen wir noch schlafen?
  623.         seconds -= slept.tv_sec;
  624.         if (useconds < slept.tv_usec) { seconds -= 1; useconds += 1000000; }
  625.         useconds -= slept.tv_usec;
  626.         #if !defined(HAVE_SELECT) && !defined(HAVE_USLEEP)
  627.         if (seconds==0) break; # CPU-Zeit fressende Warteschleife vermeiden
  628.         #endif
  629.       }}
  630.     end_system_call();
  631.     value1 = NIL; mv_count=1; # 1 Wert NIL
  632.   }
  633. #endif
  634. #endif
  635.  
  636. LISPFUNN(time,0)
  637. # (SYSTEM::%%TIME) liefert den bisherigen Time/Space-Verbrauch, ohne selbst
  638. # Platz anzufordern (und damit eventuell selbst eine GC zu verursachen).
  639. # 9 Werte:
  640. #   Real-Time (Zeit seit Systemstart) in 2 Werten,
  641. #   Run-Time (verbrauchte Zeit seit Systemstart) in 2 Werten,
  642. #   GC-Time (durch GC verbrauchte Zeit seit Systemstart) in 2 Werten,
  643. #   #ifdef TIME_ATARI
  644. #     jeweils in 200stel Sekunden,
  645. #     jeweils (ldb (byte 16 16) time) und (ldb (byte 16 0) time).
  646. #   #endif
  647. #   #ifdef TIME_AMIGAOS
  648. #     jeweils in 50stel Sekunden,
  649. #     jeweils (ldb (byte 16 16) time) und (ldb (byte 16 0) time).
  650. #   #endif
  651. #   #ifdef TIME_MSDOS
  652. #     jeweils in 100stel Sekunden,
  653. #     jeweils (ldb (byte 16 16) time) und (ldb (byte 16 0) time).
  654. #   #endif
  655. #   #if defined(TIME_UNIX_TIMES) || defined(TIME_RISCOS)
  656. #     jeweils in CLK_TCK-stel Sekunden,
  657. #     jeweils (ldb (byte 16 16) time) und (ldb (byte 16 0) time).
  658. #   #endif
  659. #   #ifdef TIME_UNIX
  660. #     jeweils in Mikrosekunden, jeweils ganze Sekunden und Mikrosekunden.
  661. #   #endif
  662. #   Space (seit Systemstart verbrauchter Platz, in Bytes)
  663. #     in 2 Werten: (ldb (byte 24 24) Space), (ldb (byte 24 0) Space).
  664. #   GC-Count (Anzahl der durchgefⁿhrten Garbage Collections).
  665.   { var timescore tm;
  666.     get_running_times(&tm); # Run-Time abfragen
  667.     #ifdef TIME_1
  668.       #define as_2_values(time)  \
  669.         pushSTACK(fixnum(high16(time))); \
  670.         pushSTACK(fixnum(low16(time)));
  671.     #endif
  672.     #ifdef TIME_2
  673.       #define as_2_values(time)  \
  674.         pushSTACK(fixnum(time.tv_sec)); \
  675.         pushSTACK(fixnum(time.tv_usec));
  676.     #endif
  677.     as_2_values(tm.realtime); # erste zwei Werte: Real-Time
  678.     as_2_values(tm.runtime); # nΣchste zwei Werte: Run-Time
  679.     as_2_values(tm.gctime); # nΣchste zwei Werte: GC-Time
  680.     # nΣchste zwei Werte: Space
  681.     # tm.gcfreed = von der GC bisher wieder verfⁿgbar gemachter Platz
  682.     {var reg1 uintL used = used_space(); # momentan belegter Platz
  683.      # beides addieren:
  684.      #ifdef intQsize
  685.      tm.gcfreed += used;
  686.      #else
  687.      if ((tm.gcfreed.lo += used) < used) { tm.gcfreed.hi += 1; }
  688.      #endif
  689.     }
  690.     # Jetzt ist tm.gcfreed = bisher insgesamt verbrauchter Platz
  691.     #if (oint_data_len<24)
  692.       #error "Funktion SYS::%%TIME anpassen!"
  693.     #endif
  694.     # In 24-Bit-Stⁿcke zerhacken:
  695.     #ifdef intQsize
  696.     pushSTACK(fixnum( (tm.gcfreed>>24) & (bit(24)-1) ));
  697.     pushSTACK(fixnum( tm.gcfreed & (bit(24)-1) ));
  698.     #else
  699.     pushSTACK(fixnum( ((tm.gcfreed.hi << 8) + (tm.gcfreed.lo >> 24)) & (bit(24)-1) ));
  700.     pushSTACK(fixnum( tm.gcfreed.lo & (bit(24)-1) ));
  701.     #endif
  702.     # letzter Wert: GC-Count
  703.     pushSTACK(fixnum(tm.gccount));
  704.     funcall(L(values),9); # 9 Werte produzieren
  705.   }
  706.  
  707.