[Git][cmucl/cmucl][issue-120-software-type-in-c] Implement software-type in C

[Raymond Toy (@rtoy)]

Raymond Toy pushed to branch issue-120-software-type-in-c at cmucl / cmucl


Commits:
3c1f5538 by Raymond Toy at 2022-08-30T06:27:12-07:00
Implement software-type in C

Add function software-type to misc.lisp, and initialize to
*software-type* to NIL so that (software-type) will set it
appropriately.

Add function os_software_type to os-common.c that returns the sysname
slot of struct utsname.   On Linux and macos, this value matches the
value that we previously returned.

In linux-os.lisp and bsd-os.lisp, comment out the code that sets
*software-type*.  (We need to do this for other OSes, still)

- - - - -


4 changed files:

- src/code/bsd-os.lisp
- src/code/linux-os.lisp
- src/code/misc.lisp
- src/lisp/os-common.c


Changes:

=====================================
src/code/bsd-os.lisp
=====================================
@@ -42,6 +42,7 @@
 #+executable
 (register-lisp-runtime-feature :executable)
 
+#+nil
 (setq *software-type* #+OpenBSD "OpenBSD"
                       #+NetBSD "NetBSD"
                       #+freebsd "FreeBSD"


=====================================
src/code/linux-os.lisp
=====================================
@@ -26,7 +26,7 @@
 (register-lisp-feature :elf)
 (register-lisp-runtime-feature :executable)
 
-(setq *software-type* "Linux")
+;;(setq *software-type* "Linux")
 
 (defvar *software-version* nil
   "Version string for supporting software")


=====================================
src/code/misc.lisp
=====================================
@@ -183,11 +183,25 @@
   "Returns a string giving the name of the local machine."
   (unix:unix-gethostname))
 
-(defvar *software-type* "Unix"
-  "The value of SOFTWARE-TYPE.  Set in FOO-os.lisp.")
+(defvar *software-type* nil
+  _N"The value of SOFTWARE-TYPE.")
 
 (defun software-type ()
-  "Returns a string describing the supporting software."
+  _N"Returns a string describing the supporting software."
+  (unless *software-type*
+    (setf *software-type*
+	  (let (software-type)
+	    ;; Get the software-type from the C function os_software_type.
+	    (unwind-protect
+		 (progn
+		   (setf software-type
+			 (alien:alien-funcall
+			  (alien:extern-alien "os_software_type"
+					      (function (alien:* c-call:c-string)))))
+		   (unless (zerop (sap-int (alien:alien-sap software-type)))
+		     (alien:cast software-type c-call:c-string)))
+	      (when software-type
+		(alien:free-alien software-type))))))
   *software-type*)
 
 (defvar *short-site-name* (intl:gettext "Unknown")


=====================================
src/lisp/os-common.c
=====================================
@@ -757,3 +757,23 @@ os_software_version()
 
     return version;
 }
+#undef UNAME_RELEASE_AND_VERSION
+
+char*
+os_software_type()
+{
+    int status;
+    struct utsname uts;
+    char *os_name = NULL;
+    
+    status = uname(&uts);
+    if (status == 0) {
+        os_name = malloc(strlen(uts.sysname) + 1);
+        if (os_name) {
+            strcpy(os_name, uts.sysname);
+        }
+    }
+
+    return os_name;
+}
+    



View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/3c1f5538b09c6256480aac2c82e67f6331f19db5

-- 
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/3c1f5538b09c6256480aac2c82e67f6331f19db5
You're receiving this email because of your account on gitlab.common-lisp.net.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20220830/6a4711e9/attachment-0001.html>