X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fbsd-os.lisp;h=1b1633dd582cfbe89123241f38da1c70bc0d6f4e;hb=18dc0069cd514c976042766ab9a785c970fe1603;hp=4152ae2d951e9bffe9975b91b5b6905a2a9b41c8;hpb=fdf07da187cb31fd5bdd872c73245fd72877b1a1;p=sbcl.git

diff --git a/src/code/bsd-os.lisp b/src/code/bsd-os.lisp
index 4152ae2..1b1633d 100644
--- a/src/code/bsd-os.lisp
+++ b/src/code/bsd-os.lisp
@@ -1,53 +1,107 @@
-;;;; OS interface functions for CMU CL under BSD Unix.
+;;;; OS interface functions for SBCL under BSD Unix.
 
 ;;;; This code was written as part of the CMU Common Lisp project at
 ;;;; Carnegie Mellon University, and has been placed in the public
 ;;;; domain.
 
-(in-package "SB!SYS")
+(in-package "SB!IMPL")
 
 ;;;; Check that target machine features are set up consistently with
 ;;;; this file.
-#!-bsd (eval-when (:compile-toplevel :load-toplevel :execute)
-	 (error "The :BSD feature is missing, we shouldn't be doing this code."))
+#!-bsd
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (error "The :BSD feature is missing, we shouldn't be doing this code."))
+
+(define-alien-routine ("sysctl" %sysctl) int
+  (name (* int))
+  (namelen unsigned-int)
+  (oldp (* t))
+  (oldlenp (* sb!unix:size-t))
+  (newp (* t))
+  (newlen sb!unix:size-t))
+
+#!+darwin
+(define-alien-routine ("sysctlbyname" %sysctlbyname) int
+  (name c-string)
+  (oldp (* t))
+  (oldlenp (* sb!unix:size-t))
+  (newp (* t))
+  (newlen sb!unix:size-t))
+
+(defun sysctl (type &rest name)
+  #!+sb-doc
+  "Retrieves an integer or string value with the given name."
+  (let ((name-len (length name)))
+    (when (> name-len ctl-maxname)
+      (error "sysctl name ~S is too long" name))
+    (with-alien ((name-array (array int #.ctl-maxname))
+                 (result-len sb!unix:size-t))
+      (dotimes (off name-len)
+        (setf (deref name-array off) (elt name off)))
+      (ecase type
+        (:int
+         (with-alien ((result int))
+           (setf result-len (alien-size int :bytes))
+           (unless (minusp (%sysctl (cast name-array (* int)) name-len
+                                    (addr result) (addr result-len) nil 0))
+             result)))
+        (:str
+         (unless (minusp (%sysctl (cast name-array (* int)) name-len
+                                  nil (addr result-len) nil 0))
+           (with-alien ((result (* char) (make-alien char result-len)))
+             (if (minusp (%sysctl (cast name-array (* int)) name-len
+                                  result (addr result-len) nil 0))
+                 (free-alien result)
+                 (sb!unix::newcharstar-string result)))))))))
+
+#!+darwin
+(defun sysctlbyname (type name)
+  #!+sb-doc
+  "Retrieves an integer or string value with the given name."
+  (with-alien ((result-len sb!unix:size-t))
+    (ecase type
+      (:int
+       (with-alien ((result int))
+         (setf result-len (alien-size int :bytes))
+         (unless (minusp (%sysctlbyname name (addr result)
+                                        (addr result-len) nil 0))
+           result)))
+      (:str
+       (unless (minusp (%sysctlbyname name nil (addr result-len) nil 0))
+         (with-alien ((result (* char) (make-alien char result-len)))
+           (if (minusp (%sysctlbyname name result (addr result-len) nil 0))
+               (free-alien result)
+               (sb!unix::newcharstar-string result))))))))
 
 (defun software-type ()
   #!+sb-doc
   "Return a string describing the supporting software."
-  (the string ; (to force error in case of unsupported BSD variant)
-       #!+FreeBSD "FreeBSD"
-       #!+OpenBSD "OpenBSD"))
-
-(defvar *software-version* nil)
+  (sysctl :str ctl-kern kern-ostype))
 
 (defun software-version ()
   #!+sb-doc
   "Return a string describing version of the supporting software, or NIL
    if not available."
-  (or *software-version*
-      (setf *software-version*
-	    (string-trim '(#\newline)
-			 (with-output-to-string (stream)
-			   (sb!ext:run-program "/usr/bin/uname" `("-r")
-					       :output stream))))))
+  (or sb!sys::*software-version*
+      (setf sb!sys::*software-version*
+            (sysctl :str ctl-kern kern-osrelease))))
 
-(defun os-cold-init-or-reinit ()
-  (setf *software-version* nil)
-  (setf *default-pathname-defaults*
-	(pathname (sb!unix:posix-getcwd/))))
-
 ;;; Return system time, user time and number of page faults.
 (defun get-system-info ()
   (multiple-value-bind (err? utime stime maxrss ixrss idrss
-			     isrss minflt majflt)
-		       (sb!unix:unix-getrusage sb!unix:rusage_self)
+                             isrss minflt majflt)
+                       (sb!unix:unix-getrusage sb!unix:rusage_self)
     (declare (ignore maxrss ixrss idrss isrss minflt))
     (unless err?
       (simple-perror "Unix system call getrusage() failed" :errno utime))
-    
+
     (values utime stime majflt)))
 
 ;;; Return the system page size.
 (defun get-page-size ()
-  ;; FIXME: probably should call getpagesize()
-  4096)
+  (sysctl :int ctl-hw hw-pagesize))
+
+;;; support for CL:MACHINE-VERSION defined OAOO elsewhere
+(defun get-machine-version ()
+  (or #!+darwin (sysctlbyname :str "machdep.cpu.brand_string")
+      (sysctl :str ctl-hw hw-model)))