home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-1.LHA / CLISP960530-sr.lha / src / misc.d < prev    next >
Encoding:
Text File  |  1996-04-15  |  10.7 KB  |  333 lines
  1. # Diverse Funktionen für CLISP
  2. # Bruno Haible 24.5.1995
  3.  
  4. #include "lispbibl.c"
  5.  
  6. # Eigenwissen:
  7.  
  8. LISPFUNN(lisp_implementation_type,0)
  9. # (LISP-IMPLEMENTATION-TYPE), CLTL S. 447
  10.   { value1 = O(lisp_implementation_type_string); mv_count=1; }
  11.  
  12. LISPFUNN(lisp_implementation_version,0)
  13. # (LISP-IMPLEMENTATION-VERSION), CLTL S. 447
  14.   { value1 = Symbol_value(S(lisp_implementation_version_string)); mv_count=1; }
  15.  
  16. LISPFUN(version,0,1,norest,nokey,0,NIL)
  17. # (SYSTEM::VERSION) liefert die Version des Runtime-Systems,
  18. # (SYSTEM::VERSION version) überprüft (am Anfang eines FAS-Files),
  19. # ob die Versionen des Runtime-Systems übereinstimmen.
  20.   { var reg1 object arg = popSTACK();
  21.     if (eq(arg,unbound))
  22.       { value1 = O(version); mv_count=1; }
  23.       else
  24.       { if (equal(arg,O(version)))
  25.           { value1 = NIL; mv_count=0; }
  26.           else
  27.           { 
  28.             //: DEUTSCH "Dieses File stammt von einer anderen Lisp-Version, muß neu compiliert werden."
  29.             //: ENGLISH "This file was produced by another lisp version, must be recompiled."
  30.             //: FRANCAIS "Ce fichier provient d'une autre version de LISP et doit être recompilé."
  31.             fehler(error, GETTEXT("This file was produced by another lisp version, must be recompiled."));
  32.   }   }   }
  33.  
  34. #ifdef MACHINE_KNOWN
  35.  
  36. LISPFUNN(machinetype,0)
  37. # (MACHINE-TYPE), CLTL S. 447
  38.   { var reg1 object erg = O(machine_type_string);
  39.     if (nullp(erg)) # noch unbekannt?
  40.       { # ja -> holen
  41.         #ifdef HAVE_SYS_UTSNAME_H
  42.         var struct utsname utsname;
  43.         begin_system_call();
  44.         if ( uname(&utsname) <0) { OS_error(); }
  45.         end_system_call();
  46.         pushSTACK(asciz_to_string(&!utsname.machine));
  47.         funcall(L(nstring_upcase),1); # in Großbuchstaben umwandeln
  48.         erg = value1;
  49.         #else
  50.         # Betriebssystem-Kommando 'uname -m' bzw. 'arch' ausführen und
  51.         # dessen Output in einen String umleiten:
  52.         # (string-upcase
  53.         #   (with-open-stream (stream (make-pipe-input-stream "/bin/arch"))
  54.         #     (read-line stream nil nil)
  55.         # ) )
  56.         #if defined(UNIX_SUNOS4)
  57.         pushSTACK(asciz_to_string("/bin/arch"));
  58.         #elif defined(UNIX_NEXTSTEP)
  59.         pushSTACK(asciz_to_string("/usr/bin/arch"));
  60.         #else
  61.         pushSTACK(asciz_to_string("uname -m"));
  62.         #endif
  63.         funcall(L(make_pipe_input_stream),1); # (MAKE-PIPE-INPUT-STREAM "/bin/arch")
  64.         pushSTACK(value1); # Stream retten
  65.         pushSTACK(value1); pushSTACK(NIL); pushSTACK(NIL);
  66.         funcall(L(read_line),3); # (READ-LINE stream NIL NIL)
  67.         pushSTACK(value1); # Ergebnis (kann auch NIL sein) retten
  68.         stream_close(&STACK_1); # Stream schließen
  69.         if (!nullp(STACK_0))
  70.           { erg = string_upcase(STACK_0); } # in Großbuchstaben umwandeln
  71.           else
  72.           { erg = NIL; }
  73.         skipSTACK(2);
  74.         #endif
  75.         # Das Ergebnis merken wir uns für's nächste Mal:
  76.         O(machine_type_string) = erg;
  77.       }
  78.     value1 = erg; mv_count=1;
  79.   }
  80.  
  81. LISPFUNN(machine_version,0)
  82. # (MACHINE-VERSION), CLTL S. 447
  83.   { var reg1 object erg = O(machine_version_string);
  84.     if (nullp(erg)) # noch unbekannt?
  85.       { # ja -> holen
  86.         #ifdef HAVE_SYS_UTSNAME_H
  87.         var struct utsname utsname;
  88.         begin_system_call();
  89.         if ( uname(&utsname) <0) { OS_error(); }
  90.         end_system_call();
  91.         pushSTACK(asciz_to_string(&!utsname.machine));
  92.         funcall(L(nstring_upcase),1); # in Großbuchstaben umwandeln
  93.         erg = value1;
  94.         #else
  95.         # Betriebssystem-Kommando 'uname -m' bzw. 'arch -k' ausführen und
  96.         # dessen Output in einen String umleiten:
  97.         # (string-upcase
  98.         #   (with-open-stream (stream (make-pipe-input-stream "/bin/arch -k"))
  99.         #     (read-line stream nil nil)
  100.         # ) )
  101.         #if defined(UNIX_SUNOS4)
  102.         pushSTACK(asciz_to_string("/bin/arch -k"));
  103.         #else
  104.         pushSTACK(asciz_to_string("uname -m"));
  105.         #endif
  106.         funcall(L(make_pipe_input_stream),1); # (MAKE-PIPE-INPUT-STREAM "/bin/arch -k")
  107.         pushSTACK(value1); # Stream retten
  108.         pushSTACK(value1); pushSTACK(NIL); pushSTACK(NIL);
  109.         funcall(L(read_line),3); # (READ-LINE stream NIL NIL)
  110.         pushSTACK(value1); # Ergebnis (kann auch NIL sein) retten
  111.         stream_close(&STACK_1); # Stream schließen
  112.         funcall(L(string_upcase),1); skipSTACK(1); # in Großbuchstaben umwandeln
  113.         #endif
  114.         # Das Ergebnis merken wir uns für's nächste Mal:
  115.         O(machine_version_string) = erg = value1;
  116.       }
  117.     value1 = erg; mv_count=1;
  118.   }
  119.  
  120. LISPFUNN(machine_instance,0)
  121. # (MACHINE-INSTANCE), CLTL S. 447
  122.   { var reg1 object erg = O(machine_instance_string);
  123.     if (nullp(erg)) # noch unbekannt?
  124.       { # ja -> Hostname abfragen und dessen Internet-Adresse holen:
  125.         # (let* ((hostname (unix:gethostname))
  126.         #        (address (unix:gethostbyname hostname)))
  127.         #   (if (or (null address) (zerop (length address)))
  128.         #     hostname
  129.         #     (apply #'string-concat hostname " ["
  130.         #       (let ((l nil))
  131.         #         (dotimes (i (length address))
  132.         #           (push (sys::decimal-string (aref address i)) l)
  133.         #           (push "." l)
  134.         #         )
  135.         #         (setf (car l) "]") ; statt (pop l) (push "]" l)
  136.         #         (nreverse l)
  137.         # ) ) ) )
  138.         #if defined(HAVE_GETHOSTNAME)
  139.         var char hostname[MAXHOSTNAMELEN+1];
  140.         # Hostname holen:
  141.         begin_system_call();
  142.         if ( gethostname(&!hostname,MAXHOSTNAMELEN) <0) { OS_error(); }
  143.         end_system_call();
  144.         hostname[MAXHOSTNAMELEN] = '\0'; # und durch ein Nullbyte abschließen
  145.         #elif defined(HAVE_SYS_UTSNAME_H)
  146.         # Hostname u.a. holen:
  147.         var struct utsname utsname;
  148.         begin_system_call();
  149.         if ( uname(&utsname) <0) { OS_error(); }
  150.         end_system_call();
  151.         #define hostname utsname.nodename
  152.         #else
  153.         ??
  154.         #endif
  155.         erg = asciz_to_string(&!hostname); # Hostname als Ergebnis
  156.         #ifdef HAVE_GETHOSTBYNAME
  157.         pushSTACK(erg); # Hostname als 1. String
  158.         { var reg5 uintC stringcount = 1;
  159.           # Internet-Information holen:
  160.           var reg4 struct hostent * h = gethostbyname(&!hostname);
  161.           if ((!(h == (struct hostent *)NULL)) && (!(h->h_addr == (char*)NULL))
  162.               && (h->h_length > 0)
  163.              )
  164.             { pushSTACK(asciz_to_string(" ["));
  165.              {var reg2 uintB* ptr = (uintB*)h->h_addr;
  166.               var reg3 uintC count;
  167.               dotimesC(count,h->h_length,
  168.                 pushSTACK(fixnum(*ptr++));
  169.                 funcall(L(decimal_string),1); # nächstes Byte in dezimal
  170.                 pushSTACK(value1);
  171.                 pushSTACK(asciz_to_string(".")); # und ein Punkt als Trennung
  172.                 );
  173.               STACK_0 = asciz_to_string("]"); # kein Punkt am Schluß
  174.               stringcount += (2*h->h_length + 1);
  175.             }}
  176.           # Strings zusammenhängen:
  177.           erg = string_concat(stringcount);
  178.         }
  179.         #endif
  180.         #undef hostname
  181.         # Das Ergebnis merken wir uns für's nächste Mal:
  182.         O(machine_instance_string) = erg;
  183.       }
  184.     value1 = erg; mv_count=1;
  185.   }
  186.  
  187. #endif # MACHINE_KNOWN
  188.  
  189. #ifdef HAVE_ENVIRONMENT
  190.  
  191. LISPFUNN(get_env,1)
  192. # (SYSTEM::GETENV string) liefert den zu string im Betriebssystem-Environment
  193. # assoziierten String oder NIL.
  194.   { var reg2 object arg = popSTACK();
  195.     if (stringp(arg))
  196.       { var reg1 const char* found;
  197.         with_string_0(arg,envvar,
  198.           { begin_system_call();
  199.             found = getenv(envvar);
  200.             end_system_call();
  201.           });
  202.         if (!(found==NULL))
  203.           { value1 = asciz_to_string(found); } # gefunden -> String als Wert
  204.           else
  205.           { value1 = NIL; } # nicht gefunden -> Wert NIL
  206.       }
  207.       else
  208.       { value1 = NIL; } # Kein String -> Wert NIL
  209.     mv_count=1;
  210.   }
  211.  
  212. #endif
  213.  
  214. LISPFUNN(software_type,0)
  215. # (SOFTWARE-TYPE), CLTL S. 448
  216.   { value1 = OL(software_type_string); mv_count=1; }
  217.  
  218. LISPFUNN(software_version,0)
  219. # (SOFTWARE-VERSION), CLTL S. 448
  220.   { value1 = Symbol_value(S(software_version_string)); mv_count=1; }
  221.  
  222. #ifdef ENABLE_NLS
  223.  
  224.   global const char *__GETTEXT (const char *msg);
  225.   global const char *__GETTEXT(msg)
  226.     var const char *msg;
  227.     {
  228.       const char *translated_msg;
  229.  
  230.       begin_system_call();
  231.       translated_msg = gettext(msg);
  232.       end_system_call();  
  233.       #if 0
  234.         # empty strings are treated like NULLs by gettext -- a workaround
  235.         return (msg == translated_msg) ? "" : translated_msg;
  236.       #else
  237.         return translated_msg;
  238.       #endif
  239.     }
  240.  
  241.  
  242. LISPFUNN(gettext,1)
  243. # (SYS::GETTEXT object)
  244.   {
  245.     if (mstringp(STACK_0))
  246.       { 
  247. #if 1
  248.         with_string_0(STACK_0,asciz,
  249.           { value1 = asciz_to_string(__GETTEXT(asciz)); });
  250. #else
  251.         value1 = asciz_to_string(__GETTEXT(TheAsciz(string_to_asciz(STACK_0))));
  252. #endif
  253.         skipSTACK(1);
  254.       }
  255.     elif (mconsp(STACK_0))
  256.       {
  257.         pushSTACK(L(gettext));
  258.         pushSTACK(STACK_(0+1));
  259.         funcall(L(mapcar),2);
  260.         skipSTACK(1);
  261.       }
  262.     else value1 = popSTACK();
  263.     mv_count = 1;
  264.   }
  265. #endif
  266.  
  267. LISPFUNN(language,3)
  268. # (SYS::LANGUAGE english deutsch francais) liefert je nach der aktuellen
  269. # Sprache das entsprechende Argument.
  270.   { 
  271.     #ifdef ENABLE_NLS
  272.     pushSTACK(STACK_2);
  273.     funcall(S(gettext),1);  # S() for debugging
  274.     #else
  275.     value1 = (ENGLISH ? STACK_2 :
  276.               DEUTSCH ? STACK_1 :
  277.               FRANCAIS ? STACK_0 :
  278.               NIL
  279.               );
  280.     #endif
  281.     mv_count=1;
  282.     skipSTACK(3);
  283.   }
  284.  
  285. LISPFUNN(identity,1)
  286. # (IDENTITY object), CLTL S. 448
  287.   { value1 = popSTACK(); mv_count=1; }
  288.  
  289. LISPFUNN(address_of,1)
  290. # (SYS::ADDRESS-OF object) liefert die Adresse von object
  291.   { var reg1 object arg = popSTACK();
  292.     #if defined(WIDE_HARD)
  293.       value1 = UQ_to_I(untype(arg));
  294.     #elif defined(WIDE_SOFT)
  295.       value1 = UL_to_I(untype(arg));
  296.     #else
  297.       value1 = UL_to_I(as_oint(arg));
  298.     #endif
  299.     mv_count=1;
  300.   }
  301.  
  302. #ifdef HAVE_DISASSEMBLER
  303.  
  304. LISPFUNN(code_address_of,1)
  305. # (SYS::CODE-ADDRESS-OF object) liefert die Adresse des Maschinencodes von object
  306.   { var reg1 object obj = popSTACK();
  307.     if (ulong_p(obj)) # Zahl im Bereich eines aint == ulong -> Zahl selbst
  308.       { value1 = obj; }
  309.     elif (subrp(obj)) # SUBR -> seine Adresse
  310.       { value1 = ulong_to_I((aint)(TheSubr(obj)->function)); }
  311.     elif (fsubrp(obj)) # FSUBR -> seine Adresse
  312.       { value1 = ulong_to_I((aint)TheMachine(TheFsubr(obj)->function)); }
  313.     #ifdef DYNAMIC_FFI
  314.     elif (ffunctionp(obj))
  315.       { value1 = ulong_to_I((uintP)Faddress_value(TheFfunction(obj)->ff_address)); }
  316.     #endif
  317.     else
  318.       { value1 = NIL; }
  319.     mv_count=1;
  320.   }
  321.  
  322. LISPFUNN(program_id,0)
  323. # (SYS::PROGRAM-ID) returns the pid
  324.   { begin_system_call();
  325.    {var reg1 int pid = getpid();
  326.     end_system_call();
  327.     value1 = L_to_I((sint32)pid);
  328.     mv_count=1;
  329.   }}
  330.  
  331. #endif
  332.  
  333.