InfoMagic Source Code 1993 July/THE_SOURCE_CODE_CD_ROM.iso/X/mit/lib/CLX/excldep.l

Text File | 1991-07-07 | 14.3 KB | 450 lines

;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*-
;;;
;;; CLX -- excldep.cl
;;;
;;; Copyright (c) 1987, 1988, 1989 Franz Inc, Berkeley, Ca.
;;;
;;; Permission is granted to any individual or institution to use, copy,
;;; modify, and distribute this software, provided that this complete
;;; copyright and permission notice is maintained, intact, in all copies and
;;; supporting documentation.
;;;
;;; Franz Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;

(in-package :xlib)

(eval-when (compile load eval)
  (require :foreign)
  (require :process)            ; Needed even if scheduler is not
                    ; running.  (Must be able to make
                    ; a process-lock.)
  )

(eval-when (load)
  (provide :clx))


#-(or little-endian big-endian)
(eval-when (eval compile load)
  (let ((x '#(1)))
    (if (not (eq 0 (sys::memref x
                #.(comp::mdparam 'comp::md-svector-data0-adj)
                0 :unsigned-byte)))
    (pushnew :little-endian *features*)
      (pushnew :big-endian *features*))))


(defmacro correct-case (string)
  ;; This macro converts the given string to the
  ;; current preferred case, or leaves it alone in a case-sensitive mode.
  (let ((str (gensym)))
    `(let ((,str ,string))
       (case excl::*current-case-mode*
     (:case-insensitive-lower
      (string-downcase ,str))
     (:case-insensitive-upper
      (string-upcase ,str))
     ((:case-sensitive-lower :case-sensitive-upper)
      ,str)))))


(defconstant type-pred-alist
    '(#-(version>= 4 1 devel 16)
      (card8  . card8p)
      #-(version>= 4 1 devel 16)
      (card16 . card16p)
      #-(version>= 4 1 devel 16)
      (card29 . card29p)
      #-(version>= 4 1 devel 16)
      (card32 . card32p)
      #-(version>= 4 1 devel 16)
      (int8   . int8p)
      #-(version>= 4 1 devel 16)
      (int16  . int16p)
      #-(version>= 4 1 devel 16)
      (int32  . int32p)
      #-(version>= 4 1 devel 16)
      (mask16 . card16p)
      #-(version>= 4 1 devel 16)
      (mask32 . card32p)
      #-(version>= 4 1 devel 16)
      (pixel  . card32p)
      #-(version>= 4 1 devel 16)
      (resource-id . card29p)
      #-(version>= 4 1 devel 16)
      (keysym . card32p)
      (angle  . anglep)
      (color  . color-p)
      (bitmap-format . bitmap-format-p)
      (pixmap-format . pixmap-format-p)
      (display  . display-p)
      (drawable . drawable-p)
      (window   . window-p)
      (pixmap   . pixmap-p)
      (visual-info . visual-info-p)
      (colormap . colormap-p)
      (cursor . cursor-p)
      (gcontext .  gcontext-p)
      (screen . screen-p)
      (font . font-p)
      (image-x . image-x-p)
      (image-xy . image-xy-p)
      (image-z . image-z-p)
      (wm-hints . wm-hints-p)
      (wm-size-hints . wm-size-hints-p)
      ))

;; This (if (and ...) t nil) stuff has a purpose -- it lets the old
;; sun4 compiler opencode the `and'.

#-(version>= 4 1 devel 16)
(defun card8p (x)
  (declare (optimize (speed 3) (safety 0))
       (fixnum x))
  (if (and (excl:fixnump x) (> #.(expt 2 8) x) (>= x 0))
      t
    nil))

#-(version>= 4 1 devel 16)
(defun card16p (x)
  (declare (optimize (speed 3) (safety 0))
       (fixnum x))
  (if (and (excl:fixnump x) (> #.(expt 2 16) x) (>= x 0))
      t
    nil))

#-(version>= 4 1 devel 16)
(defun card29p (x)
  (declare (optimize (speed 3) (safety 0)))
  (if (or (and (excl:fixnump x) (>= (the fixnum x) 0))
      (and (excl:bignump x) (> #.(expt 2 29) (the bignum x))
           (>= (the bignum x) 0)))
      t
    nil))

#-(version>= 4 1 devel 16)
(defun card32p (x)
  (declare (optimize (speed 3) (safety 0)))
  (if (or (and (excl:fixnump x) (>= (the fixnum x) 0))
      (and (excl:bignump x) (> #.(expt 2 32) (the bignum x))
           (>= (the bignum x) 0)))
      t
    nil))

#-(version>= 4 1 devel 16)
(defun int8p (x)
  (declare (optimize (speed 3) (safety 0))
       (fixnum x))
  (if (and (excl:fixnump x) (> #.(expt 2 7) x) (>= x #.(expt -2 7)))
      t
    nil))

#-(version>= 4 1 devel 16)
(defun int16p (x)
  (declare (optimize (speed 3) (safety 0))
       (fixnum x))
  (if (and (excl:fixnump x) (> #.(expt 2 15) x) (>= x #.(expt -2 15)))
      t
    nil))

#-(version>= 4 1 devel 16)
(defun int32p (x)
  (declare (optimize (speed 3) (safety 0)))
  (if (or (excl:fixnump x)
      (and (excl:bignump x) (> #.(expt 2 31) (the bignum x))
           (>= (the bignum x) #.(expt -2 31))))
      t
    nil))

;; This one can be handled better by knowing a little about what we're
;; testing for.  Plus this version can handle (single-float pi), which
;; is otherwise larger than pi!
(defun anglep (x)
  (declare (optimize (speed 3) (safety 0)))
  (if (or (and (excl::fixnump x) (>= (the fixnum x) #.(truncate (* -2 pi)))
           (<= (the fixnum x) #.(truncate (* 2 pi))))
      (and (excl::single-float-p x)
           (>= (the single-float x) #.(float (* -2 pi) 0.0s0))
           (<= (the single-float x) #.(float (* 2 pi) 0.0s0)))
      (and (excl::double-float-p x)
           (>= (the double-float x) #.(float (* -2 pi) 0.0d0))
           (<= (the double-float x) #.(float (* 2 pi) 0.0d0))))
      t
    nil))

(eval-when (load eval)
  #+(version>= 4 1 devel 16)
  (mapcar #'(lambda (elt) (excl:add-typep-transformer (car elt) (cdr elt)))
      type-pred-alist)
  #-(version>= 4 1 devel 16)
  (nconc excl::type-pred-alist type-pred-alist))


;; Return t if there is a character available for reading or on error,
;; otherwise return nil.
(defun fd-char-avail-p (fd)
  (multiple-value-bind (available-p errcode)
      (comp::.primcall-sargs 'sys::filesys excl::fs-char-avail fd)
    (excl:if* errcode
       then t
       else available-p)))

(defmacro with-interrupt-checking-on (&body body)
  `(locally (declare (optimize (safety 1)))
     ,@body))

;; Read from the given fd into 'vector', which has element type card8.
;; Start storing at index 'start-index' and read exactly 'length' bytes.
;; Return t if an error or eof occurred, nil otherwise.
(defun fd-read-bytes (fd vector start-index length)
  (declare (fixnum fd start-index length)
       (type (simple-array (unsigned-byte 8) (*)) vector))
  (with-interrupt-checking-on
   (do ((rest length))
       ((eq 0 rest) nil)
     (declare (fixnum rest))
     (multiple-value-bind (numread errcode)
     (comp::.primcall-sargs 'sys::filesys excl::fs-read-bytes fd vector
                start-index rest)
       (declare (fixnum numread))
       (excl:if* errcode
      then (if (not (eq errcode
                excl::*error-code-interrupted-system-call*))
           (return t))
    elseif (eq 0 numread)
      then (return t)
      else (decf rest numread)
           (incf start-index numread))))))


(when (plusp (ff:get-entry-points
          (make-array 1 :initial-contents
              (list (ff:convert-to-lang "fd_wait_for_input")))
          (make-array 1 :element-type '(unsigned-byte 32))))
  (ff:remove-entry-point (ff:convert-to-lang "fd_wait_for_input"))
  (load "excldep.o"))

(when (plusp (ff:get-entry-points
          (make-array 1 :initial-contents
              (list (ff:convert-to-lang "connect_to_server")))
          (make-array 1 :element-type '(unsigned-byte 32))))
  (ff:remove-entry-point (ff:convert-to-lang "connect_to_server" :language :c))
  (load "socket.o"))

(ff:defforeign-list `((connect-to-server
               :entry-point
               ,(ff:convert-to-lang "connect_to_server")
               :return-type :fixnum
               :arg-checking nil
               :arguments (string fixnum))
              (fd-wait-for-input
               :entry-point ,(ff:convert-to-lang "fd_wait_for_input")
               :return-type :fixnum
               :arg-checking nil
               :call-direct t
               :callback nil
               :allow-other-keys t
               :arguments (fixnum fixnum))))


;; special patch for CLX (various process fixes)
;; patch1000.2

(eval-when (compile load eval)
  (unless (find-package :patch)
    (make-package :patch :use '(:lisp :excl))))

(in-package :patch)

(defvar *patches* nil)

#+allegro
(eval-when (compile eval load)
  (when (and (= excl::cl-major-version-number 3)
         (or (= excl::cl-minor-version-number 0)
         (and (= excl::cl-minor-version-number 1)
              excl::cl-generation-number
              (< excl::cl-generation-number 9))))
    (push :clx-r4-process-patches *features*)))

#+clx-r4-process-patches
(push (cons 1000.2 "special patch for CLX (various process fixes)")
      *patches*)


(in-package :mp)

#+clx-r4-process-patches
(export 'wait-for-input-available)


#+clx-r4-process-patches
(defun with-timeout-event (seconds fnc args)
  (unless *scheduler-stack-group* (start-scheduler)) ;[spr670]
  (let ((clock-event (make-clock-event)))
    (when (<= seconds 0) (setq seconds 0))
    (multiple-value-bind (secs msecs) (truncate seconds)
      ;; secs is now a nonegative integer, and msecs is either fixnum zero
      ;; or else something interesting.
      (unless (eq 0 msecs)
    (setq msecs (truncate (* 1000.0 msecs))))
      ;; Now msecs is also a nonnegative fixnum.
      (multiple-value-bind (now mnow) (excl::cl-internal-real-time)
    (incf secs now)
    (incf msecs mnow)
    (when (>= msecs 1000)
      (decf msecs 1000)
      (incf secs))
    (unless (excl:fixnump secs) (setq secs most-positive-fixnum))
    (setf (clock-event-secs clock-event) secs
          (clock-event-msecs clock-event) msecs
          (clock-event-function clock-event) fnc
          (clock-event-args clock-event) args)))
    clock-event))


#+clx-r4-process-patches
(defmacro with-timeout ((seconds &body timeout-body) &body body)
  `(let* ((clock-event (with-timeout-event ,seconds
                       #'process-interrupt
                       (cons *current-process*
                         '(with-timeout-internal))))
      (excl::*without-interrupts* t)
      ret)
     (unwind-protect
     ;; Warning: Branch tensioner better not reorder this code!
     (setq ret (catch 'with-timeout-internal
             (add-to-clock-queue clock-event)
             (let ((excl::*without-interrupts* nil))
               (multiple-value-list (progn ,@body)))))
       (excl:if* (eq ret 'with-timeout-internal)
      then (let ((excl::*without-interrupts* nil))
         (setq ret (multiple-value-list (progn ,@timeout-body))))
      else (remove-from-clock-queue clock-event)))
     (values-list ret)))


#+clx-r4-process-patches
(defun process-lock (lock &optional (lock-value *current-process*)
                    (whostate "Lock") timeout)
  (declare (optimize (speed 3)))
  (unless (process-lock-p lock)
    (error "First argument to PROCESS-LOCK must be a process-lock: ~s" lock))
  (without-interrupts
   (excl:if* (null (process-lock-locker lock))
      then (setf (process-lock-locker lock) lock-value)
      else (excl:if* timeout
          then (excl:if* (or (eq 0 timeout) ;for speed
                 (zerop timeout))
              then nil
              else (with-timeout (timeout)
                 (process-lock-1 lock lock-value whostate)))
          else (process-lock-1 lock lock-value whostate)))))


#+clx-r4-process-patches
(defun process-lock-1 (lock lock-value whostate)
  (declare (type process-lock lock)
       (optimize (speed 3)))
  (let ((process *current-process*))
    (declare (type process process))
    (unless process
      (error
       "PROCESS-LOCK may not be called on the scheduler's stack group."))
    (loop (unless (process-lock-locker lock)
        (return (setf (process-lock-locker lock) lock-value)))
      (push process (process-lock-waiting lock))
      (let ((saved-whostate (process-whostate process)))
    (unwind-protect
        (progn (setf (process-whostate process) whostate)
           (process-add-arrest-reason process lock))
      (setf (process-whostate process) saved-whostate))))))


#+clx-r4-process-patches
(defun process-wait (whostate function &rest args)
  (declare (optimize (speed 3)))
  ;; Run the wait function once here both for efficiency and as a
  ;; first line check for errors in the function.
  (unless (apply function args)
    (process-wait-1 whostate function args)))


#+clx-r4-process-patches
(defun process-wait-1 (whostate function args)
  (declare (optimize (speed 3)))
  (let ((process *current-process*))
    (declare (type process process))
    (unless process
      (error
       "Process-wait may not be called within the scheduler's stack group."))
    (let ((saved-whostate (process-whostate process)))
      (unwind-protect
      (without-scheduling-internal
       (without-interrupts
        (setf (process-whostate process) whostate
          (process-wait-function process) function
          (process-wait-args process) args)
        (chain-rem-q process)
        (chain-ins-q process *waiting-processes*))
       (process-resume-scheduler nil))
    (setf (process-whostate process) saved-whostate
          (process-wait-function process) nil
          (process-wait-args process) nil)))))


#+clx-r4-process-patches
(defun process-wait-with-timeout (whostate seconds function &rest args)
  ;; Now returns T upon completion, NIL upon timeout. -- 6Jun89 smh
  ;; [spr1135] [rfe939] Timeout won't throw out of interrupt level code.
  ;;  -- 28Feb90 smh
  ;; Run the wait function once here both for efficiency and as a
  ;; first line check for errors in the function.
  (excl:if* (apply function args)
     then t
     else (let ((ret (list nil)))
            (without-interrupts
             (let ((clock-event
                    (with-timeout-event seconds #'identity '(nil))))
               (add-to-clock-queue clock-event)
               (process-wait-1 whostate
                               #'(lambda (clock-event function args ret)
                                   (or (null (chain-next clock-event))
                                       (and (apply function args)
                                            (setf (car ret) 't))))
                               (list clock-event function args ret))))
            (car ret))))


;;
;; Returns nil on timeout, otherwise t.
;;
#+clx-r4-process-patches
(defun wait-for-input-available
    (stream-or-fd &key (wait-function #'listen)
               (whostate "waiting for input")
               timeout)
  (let ((fd (excl:if* (excl:fixnump stream-or-fd) then stream-or-fd
         elseif (streamp stream-or-fd)
           then (excl::stream-input-fn stream-or-fd)
           else (error "wait-for-input-available expects a stream or file descriptor: ~s" stream-or-fd))))
    ;; At this point fd could be nil, since stream-input-fn returns nil for
    ;; streams that are output only, or for certain special purpose streams.
    (if fd
    (unwind-protect
        (progn
          (mp::mpwatchfor fd)
          (excl:if* timeout
         then (mp::process-wait-with-timeout
               whostate timeout wait-function stream-or-fd)
         else (mp::process-wait whostate wait-function stream-or-fd)
              t))
      (mp::mpunwatchfor fd))
      (excl:if* timeout
     then (mp::process-wait-with-timeout
           whostate timeout wait-function stream-or-fd)
     else (mp::process-wait whostate wait-function stream-or-fd)
          t))))