home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / sunos-os.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  2.7 KB  |  83 lines
  1. ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: sunos-os.lisp,v 1.5 92/03/26 03:35:02 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; OS interface functions for CMU CL under Mach.  From Miles Bader and David
  15. ;;; Axmark.
  16. ;;;
  17. (in-package "SYSTEM")
  18. (use-package "EXTENSIONS")
  19. (export '(get-system-info get-page-size os-init))
  20.  
  21. (pushnew :sunos *features*)
  22. (setq *software-type* "SunOS")
  23.  
  24. (defconstant foreign-segment-start #x00C00000) ; ### Not right???
  25. (defconstant foreign-segment-size  #x00400000)
  26.  
  27. (defvar *software-version* nil "Version string for supporting software")
  28. (defun software-version ()
  29.   "Returns a string describing version of the supporting software."
  30.   (unless *software-version*
  31.     (setf *software-version*
  32.       (let ((version-line
  33.          (with-output-to-string (stream)
  34.            (run-program
  35.             "/bin/sh"
  36.             '("-c" "strings /vmunix|grep -i 'sunos release'")
  37.             :output stream
  38.             :pty nil
  39.             :error nil))))
  40.         (let* ((first-space (position #\Space version-line))
  41.            (second-space (position #\Space version-line
  42.                        :start (1+ first-space)))
  43.            (third-space (position #\Space version-line
  44.                       :start (1+ second-space))))
  45.           (subseq version-line (1+ second-space) third-space)))))
  46.   *software-version*)
  47.  
  48.  
  49. ;;; OS-INIT -- interface.
  50. ;;;
  51. ;;; Other OS dependent initializations.
  52. ;;; 
  53. (defun os-init ()
  54.   ;; Decache version on save, because it might not be the same when we restart.
  55.   (setq *software-version* nil))
  56.  
  57. ;;; GET-SYSTEM-INFO  --  Interface
  58. ;;;
  59. ;;;    Return system time, user time and number of page faults.
  60. ;;;
  61. (defun get-system-info ()
  62.   (let (run-utime run-stime page-faults)
  63.     (multiple-value-bind (err? utime stime maxrss ixrss idrss
  64.                                isrss minflt majflt)
  65.         (unix:unix-getrusage unix:rusage_self)
  66.       (declare (ignore maxrss ixrss idrss isrss minflt))
  67.       (cond ((null err?)
  68.              (error "Unix system call getrusage failed: ~A."
  69.                     (unix:get-unix-error-msg utime)))
  70.             (T (values utime stime majflt))))))
  71.  
  72.  
  73. ;;; GET-PAGE-SIZE  --  Interface
  74. ;;;
  75. ;;;    Return the system page size.
  76. ;;;
  77. (defun get-page-size ()
  78.   (multiple-value-bind (val err)
  79.                (unix:unix-getpagesize)
  80.     (unless val
  81.       (error "Getpagesize failed: ~A" (unix:get-unix-error-msg err)))
  82.     val))
  83.