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
4 changed files:
Changes:
| ... | ... | @@ -42,6 +42,7 @@ |
| 42 | 42 | #+executable
|
| 43 | 43 | (register-lisp-runtime-feature :executable)
|
| 44 | 44 | |
| 45 | +#+nil
|
|
| 45 | 46 | (setq *software-type* #+OpenBSD "OpenBSD"
|
| 46 | 47 | #+NetBSD "NetBSD"
|
| 47 | 48 | #+freebsd "FreeBSD"
|
| ... | ... | @@ -26,7 +26,7 @@ |
| 26 | 26 | (register-lisp-feature :elf)
|
| 27 | 27 | (register-lisp-runtime-feature :executable)
|
| 28 | 28 | |
| 29 | -(setq *software-type* "Linux")
|
|
| 29 | +;;(setq *software-type* "Linux")
|
|
| 30 | 30 | |
| 31 | 31 | (defvar *software-version* nil
|
| 32 | 32 | "Version string for supporting software")
|
| ... | ... | @@ -183,11 +183,25 @@ |
| 183 | 183 | "Returns a string giving the name of the local machine."
|
| 184 | 184 | (unix:unix-gethostname))
|
| 185 | 185 | |
| 186 | -(defvar *software-type* "Unix"
|
|
| 187 | - "The value of SOFTWARE-TYPE. Set in FOO-os.lisp.")
|
|
| 186 | +(defvar *software-type* nil
|
|
| 187 | + _N"The value of SOFTWARE-TYPE.")
|
|
| 188 | 188 | |
| 189 | 189 | (defun software-type ()
|
| 190 | - "Returns a string describing the supporting software."
|
|
| 190 | + _N"Returns a string describing the supporting software."
|
|
| 191 | + (unless *software-type*
|
|
| 192 | + (setf *software-type*
|
|
| 193 | + (let (software-type)
|
|
| 194 | + ;; Get the software-type from the C function os_software_type.
|
|
| 195 | + (unwind-protect
|
|
| 196 | + (progn
|
|
| 197 | + (setf software-type
|
|
| 198 | + (alien:alien-funcall
|
|
| 199 | + (alien:extern-alien "os_software_type"
|
|
| 200 | + (function (alien:* c-call:c-string)))))
|
|
| 201 | + (unless (zerop (sap-int (alien:alien-sap software-type)))
|
|
| 202 | + (alien:cast software-type c-call:c-string)))
|
|
| 203 | + (when software-type
|
|
| 204 | + (alien:free-alien software-type))))))
|
|
| 191 | 205 | *software-type*)
|
| 192 | 206 | |
| 193 | 207 | (defvar *short-site-name* (intl:gettext "Unknown")
|
| ... | ... | @@ -757,3 +757,23 @@ os_software_version() |
| 757 | 757 | |
| 758 | 758 | return version;
|
| 759 | 759 | }
|
| 760 | +#undef UNAME_RELEASE_AND_VERSION
|
|
| 761 | + |
|
| 762 | +char*
|
|
| 763 | +os_software_type()
|
|
| 764 | +{
|
|
| 765 | + int status;
|
|
| 766 | + struct utsname uts;
|
|
| 767 | + char *os_name = NULL;
|
|
| 768 | +
|
|
| 769 | + status = uname(&uts);
|
|
| 770 | + if (status == 0) {
|
|
| 771 | + os_name = malloc(strlen(uts.sysname) + 1);
|
|
| 772 | + if (os_name) {
|
|
| 773 | + strcpy(os_name, uts.sysname);
|
|
| 774 | + }
|
|
| 775 | + }
|
|
| 776 | + |
|
| 777 | + return os_name;
|
|
| 778 | +}
|
|
| 779 | + |