openmcl patch
bryan o'connor <[email protected]> Tue, 9 Aug 2005 14:41:42 -0700
| Newsgroups | gmane.lisp.clx.devel |
|---|---|
| Message-ID | <[email protected]> |
--Apple-Mail-2--712385391
Content-Transfer-Encoding: 7bit
Content-Type: text/plain;
charset=US-ASCII;
format=flowed
here's a back-ported patch of openmcl's clx fork to the
current version in the darcs repository.
i tested it with some of the clx demos, the mcclim demos,
and climacs.
...bryan
--Apple-Mail-2--712385391
Content-Transfer-Encoding: quoted-printable
Content-Type: text/plain;
x-unix-mode=0644;
name="clx-openmcl.patch.txt"
Content-Disposition: attachment;
filename=clx-openmcl.patch.txt
diff -rN -u old-clx/clx.asd new-clx/clx.asd
--- old-clx/clx.asd 2005-08-09 13:55:16.000000000 -0700
+++ new-clx/clx.asd 2005-08-09 13:55:16.000000000 -0700
@@ -35,7 +35,7 @@
(defclass legacy-file (static-file) ())
=20
(defsystem CLX
- :depends-on (sb-bsd-sockets)
+ #+sbcl #+sbcl :depends-on (sb-bsd-sockets)
:version "0.7.0"
:serial t
:default-component-class clx-source-file
diff -rN -u old-clx/dependent.lisp new-clx/dependent.lisp
--- old-clx/dependent.lisp 2005-08-09 13:55:16.000000000 -0700
+++ new-clx/dependent.lisp 2005-08-09 13:55:16.000000000 -0700
@@ -863,7 +863,7 @@
=20
;;; MAKE-PROCESS-LOCK: Creating a process lock.
=20
-#-(or LispM excl Minima sbcl (and cmu mp))
+#-(or LispM excl Minima sbcl (and cmu mp) openmcl)
(defun make-process-lock (name)
(declare (ignore name))
nil)
@@ -892,6 +892,10 @@
(defun make-process-lock (name)
(sb-thread:make-mutex :name name))
=20
+#+openmcl
+(defun make-process-lock (name)
+ (ccl:make-lock name))
+
;;; HOLDING-LOCK: Execute a body of code with a lock held.
=20
;;; The holding-lock macro takes a timeout keyword argument. =
EVENT-LISTEN
@@ -900,7 +904,7 @@
=20
;; If you're not sharing DISPLAY objects within a multi-processing
;; shared-memory environment, this is sufficient
-#-(or lispm excl lcl3.0 Minima sbcl (and CMU mp) )
+#-(or lispm excl lcl3.0 Minima sbcl (and CMU mp) openmcl)
(defmacro holding-lock ((locator display &optional whostate &key =
timeout) &body body)
(declare (ignore locator display whostate timeout))
`(progn ,@body))
@@ -1074,6 +1078,13 @@
(minima:with-lock (lock)
(funcall continuation)))
=20
+#+openmcl
+(defmacro holding-lock ((locator display &optional whostate &key =
timeout)
+ &body body)
+ (declare (ignore timeout display))
+ `(ccl:with-lock-grabbed (,locator ,whostate)
+ ,@body))
+
;;; WITHOUT-ABORTS
=20
;;; If you can inhibit asynchronous keyboard aborts inside the body of =
this
@@ -1081,7 +1092,7 @@
;;; request writing and reply reading to ensure that requests are =
atomically
;;; written and replies are atomically read from the stream.
=20
-#-(or Genera excl lcl3.0)
+#-(or Genera excl lcl3.0 openmcl)
(defmacro without-aborts (&body body)
`(progn ,@body))
=20
@@ -1098,11 +1109,15 @@
(defmacro without-aborts (&body body)
`(lcl:with-interruptions-inhibited ,@body))
=20
+#+openmcl
+(defmacro without-aborts (&body body)
+ `(ccl:without-interrupts ,@body))
+
;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL =
value.
;;; Caller guarantees that PROCESS-WAKEUP will be called after the =
predicate's
;;; value changes.
=20
-#-(or lispm excl lcl3.0 Minima (and sb-thread sbcl) (and cmu mp))
+#-(or lispm excl lcl3.0 Minima (and sb-thread sbcl) (and cmu mp) =
openmcl)
(defun process-block (whostate predicate &rest predicate-args)
(declare (ignore whostate))
(or (apply predicate predicate-args)
@@ -1168,6 +1183,11 @@
(return))
(yield)))
=20
+#+openmcl
+(defun process-block (whostate predicate &rest predicate-args)
+ (declare (dynamic-extern predicate-args))
+ (apply #'ccl:process-wait whostate predicate predicate-args))
+
;;; FIXME: the below implementation for threaded PROCESS-BLOCK using
;;; queues and condition variables might seem better, but in fact it
;;; turns out to make performance extremely suboptimal, at least as
@@ -1255,7 +1275,7 @@
=20
;;; Default return NIL, which is acceptable even if there is a =
scheduler.
=20
-#-(or lispm excl lcl3.0 sbcl Minima (and cmu mp))
+#-(or lispm excl lcl3.0 sbcl Minima (and cmu mp) openmcl)
(defun current-process ()
nil)
=20
@@ -1284,9 +1304,13 @@
(defun current-process ()
sb-thread:*current-thread*)
=20
+#+openmcl
+(defun current-process ()
+ ccl::*current-process*)
+
;;; WITHOUT-INTERRUPTS -- provide for atomic operations.
=20
-#-(or lispm excl lcl3.0 Minima cmu)
+#-(or lispm excl lcl3.0 Minima cmu openmcl)
(defmacro without-interrupts (&body body)
`(progn ,@body))
=20
@@ -1318,11 +1342,15 @@
`(sb-thread:with-recursive-lock (*without-interrupts-sic-lock*)
,@body))
=20
+#+openmcl
+(defmacro without-interrupts (&body body)
+ `(ccl:without-interrupts ,@body))
+
;;; CONDITIONAL-STORE:
=20
;; This should use GET-SETF-METHOD to avoid evaluating subforms =
multiple times.
;; It doesn't because CLtL doesn't pass the environment to =
GET-SETF-METHOD.
-#-sbcl
+#-(or sbcl openmcl)
(defmacro conditional-store (place old-value new-value)
`(without-interrupts
(cond ((eq ,place ,old-value)
@@ -1339,6 +1367,10 @@
(setf ,place ,new-value)
t)))))
=20
+#+openmcl
+(defmacro conditional-store (place old-value new-value)
+ `(ccl::conditional-store ,place ,old-value ,new-value))
+
=
;;;-----------------------------------------------------------------------=
-----
;;; IO Error Recovery
;;; All I/O operations are done within a WRAP-BUF-OUTPUT macro.
@@ -1401,7 +1433,7 @@
;;; OPEN-X-STREAM - create a stream for communicating to the =
appropriate X
;;; server
=20
-#-(or explorer Genera lucid kcl ibcl excl Minima CMU sbcl ecl)
+#-(or explorer Genera lucid kcl ibcl excl Minima CMU sbcl ecl openmcl)
(defun open-x-stream (host display protocol)
host display protocol ;; unused
(error "OPEN-X-STREAM not implemented yet."))
@@ -1541,6 +1573,20 @@
(format nil "~A~D" +X-unix-socket-path+ display))
(si::open-client-stream host (+ 6000 display)))))
=20
+#+openmcl
+(defparameter ccl::*x-server-unix-socket-format-string* =
"/tmp/.X11-unix/X~d")
+
+#+openmcl
+(defun open-x-stream (host display protocol)
+ (declare (ignore protocol))
+ (if (or (string=3D host "") (string=3D host "unix"))
+ (ccl::make-socket :connect :active
+ :address-family :file
+ :remote-filename (format nil =
ccl::*x-server-unix-socket-format-string* display))
+ (ccl::make-socket :connect :active
+ :remote-host host
+ :remote-port (+ 6000 display))))
+
;;; BUFFER-READ-DEFAULT - read data from the X stream
=20
#+(or Genera explorer)
@@ -1670,12 +1716,29 @@
:end end)
nil)))
=20
+#+openmcl
+(defun buffer-read-default (display vector start end timeout)
+ (declare (type display display)
+ (type buffer-bytes vector)
+ (type array-index start end)
+ (type (or null (real 0 *)) timeout))
+ #.(declare-buffun)
+ (let ((stream (display-input-stream display)))
+ (declare (type (or null stream) stream))
+ (or (cond ((null stream))
+ ((listen stream) nil)
+ ((and timeout (=3D timeout 0)) :timeout)
+ ((buffer-input-wait-default display timeout)))
+ (progn
+ (ccl:stream-read-ivector stream vector start (- end start))
+ nil))))
+
;;; WARNING:
;;; CLX performance will suffer if your lisp uses read-byte for
;;; receiving all data from the X Window System server.
;;; You are encouraged to write a specialized version of
;;; buffer-read-default that does block transfers.
-#-(or Genera explorer excl lcl3.0 Minima CMU sbcl ecl)
+#-(or Genera explorer excl lcl3.0 Minima CMU sbcl ecl openmcl)
(defun buffer-read-default (display vector start end timeout)
(declare (type display display)
(type buffer-bytes vector)
@@ -1778,13 +1841,25 @@
:end end)
nil)
=20
+#+openmcl
+(defun buffer-write-default (vector display start end)
+ (declare (type buffer-bytes vector)
+ (type display display)
+ (type array-index start end))
+ #.(declare-buffun)
+ (let ((stream (display-output-stream display)))
+ (declare (type (or null stream) stream))
+ (unless (null stream)
+ (ccl:stream-write-ivector stream vector start (- end start)))
+ nil))
+
;;; WARNING:
;;; CLX performance will be severely degraded if your lisp uses
;;; write-byte to send all data to the X Window System server.
;;; You are STRONGLY encouraged to write a specialized version
;;; of buffer-write-default that does block transfers.
=20
-#-(or Genera explorer excl lcl3.0 Minima CMU sbcl)
+#-(or Genera explorer excl lcl3.0 Minima CMU sbcl openmcl)
(defun buffer-write-default (vector display start end)
;; The default buffer write function for use with common-lisp streams
(declare (type buffer-bytes vector)
@@ -1844,10 +1919,10 @@
;;; The default implementation
=20
;; Poll for input every *buffer-read-polling-time* SECONDS.
-#-(or Genera explorer excl lcl3.0 CMU sbcl)
+#-(or Genera explorer excl lcl3.0 CMU sbcl openmcl)
(defparameter *buffer-read-polling-time* 0.5)
=20
-#-(or Genera explorer excl lcl3.0 CMU sbcl)
+#-(or Genera explorer excl lcl3.0 CMU sbcl openmcl)
(defun buffer-input-wait-default (display timeout)
(declare (type display display)
(type (or null (real 0 *)) timeout))
@@ -2008,6 +2083,22 @@
nil)
(:timeout))))
=20
+#+openmcl
+(defun buffer-input-wait-default (display timeout)
+ (declare (type display display)
+ (type (or null number) timeout))
+ (let ((stream (display-input-stream display)))
+ (declare (type (or null stream) stream))
+ (cond ((null stream))
+ ((listen stream) nil)
+ ((eql timeout 0) :timeout)
+ (t
+ (let* ((fd (ccl::stream-device stream :input))
+ (ticks (and timeout (floor (* timeout =
ccl::*ticks-per-second*)))))
+ (if (ccl::process-input-wait fd ticks)
+ nil
+ :timeout))))))
+
=20
;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for =
the
;;; buffer. This should never block, so it can be called from the =
scheduler.
@@ -2238,8 +2329,8 @@
;;; probably want to set this to nil if you want good performance at
;;; production time.
(defconstant +type-check?+
- #+(or Genera Minima CMU sbcl) nil
- #-(or Genera Minima CMU sbcl) t)
+ #+(or Genera Minima CMU sbcl openmcl) nil
+ #-(or Genera Minima CMU sbcl openmcl) t)
=20
;; TYPE? is used to allow the code to do error checking at a different =
level from
;; the declarations. It also does some optimizations for systems that =
don't have
@@ -2527,7 +2618,7 @@
;; HOST hacking
=
;;------------------------------------------------------------------------=
-----
=20
-#-(or explorer Genera Minima Allegro CMU sbcl ecl)
+#-(or explorer Genera Minima Allegro CMU sbcl ecl openmcl)
(defun host-address (host &optional (family :internet))
;; Return a list whose car is the family keyword (:internet :DECnet =
:Chaos)
;; and cdr is a list of network address bytes.
@@ -2714,6 +2805,22 @@
(ldb (byte 8 8) addr)
(ldb (byte 8 0) addr)))))
=20
+#+openmcl
+(defun host-address (host &optional (family :internet))
+ ;; Return a list whose car is the family keyword (:internet :DECnet =
:Chaos)
+ ;; and cdr is a list of network address bytes.
+ (declare (type stringable host)
+ (type (or null (member :internet :decnet :chaos) card8) =
family))
+ (declare (clx-values list))
+ (ecase family
+ ((:internet nil 0)
+ (let* ((addr (ccl::host-as-inet-host host)))
+ (cons :internet (list
+ (ldb (byte 8 24) addr)
+ (ldb (byte 8 16) addr)
+ (ldb (byte 8 8) addr)
+ (ldb (byte 8 0) addr)))))))
+
#+explorer ;; This isn't required, but it helps make sense of the =
results from access-hosts
(defun get-host (host-object)
;; host-object is a list whose car is the family keyword (:internet =
:DECnet :Chaos)
@@ -2808,17 +2915,18 @@
#+CMU (cdr (assoc name ext:*environment-list* :test #'string=3D))
#+sbcl (sb-ext:posix-getenv name)
#+ecl (si:getenv name)
- #-(or sbcl excl lcl3.0 CMU ecl) (progn name nil))
+ #+openmcl (ccl::getenv name)
+ #-(or sbcl excl lcl3.0 CMU ecl openmcl) (progn name nil))
=20
(defun get-host-name ()
"Return the same hostname as gethostname(3) would"
;; machine-instance probably works on a lot of lisps, but clisp is =
not
;; one of them
- #+(or cmu sbcl) (machine-instance)
+ #+(or cmu sbcl openmcl) (machine-instance)
;; resources-pathname was using short-site-name for this purpose
#+excl (short-site-name)
#+ecl (si:getenv "HOST")
- #-(or excl cmu sbcl ecl) (error "get-host-name not implemented"))
+ #-(or excl cmu sbcl ecl openmcl) (error "get-host-name not =
implemented"))
=20
(defun homedir-file-pathname (name)
(and #-(or unix mach) (search "Unix" (software-type) :test =
#'char-equal)
@@ -3095,6 +3203,13 @@
(declare (ignore start end))
,@body))
=20
+#+openmcl
+(defmacro with-underlying-simple-vector ((variable element-type =
pixarray)
+ &body body)
+ (declare (ignore element-type))
+ `(let* ((,variable (ccl::array-data-and-offset ,pixarray)))
+ ,@body))
+
;;; These are used to read and write pixels from and to CARD8s.
=20
;;; READ-IMAGE-LOAD-BYTE is used to extract 1 and 4 bit pixels from =
CARD8s.
diff -rN -u old-clx/gl.lisp new-clx/gl.lisp
--- old-clx/gl.lisp 2005-08-09 13:55:16.000000000 -0700
+++ new-clx/gl.lisp 2005-08-09 13:55:16.000000000 -0700
@@ -1159,6 +1159,7 @@
=0C
;;; Opcodes.
=20
+(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant +get-string+ 129)
(defconstant +new-list+ 101)
(defconstant +end-list+ 102)
@@ -2086,6 +2087,7 @@
(defconstant +ext-texture-env-add+ 1)=20
(defconstant +mesa-window-pos+ 1)=20
(defconstant +mesa-resize-buffers+ 1)
+)
=20
=20
=0C
--Apple-Mail-2--712385391
Content-Transfer-Encoding: 7bit
Content-Type: text/plain;
charset=US-ASCII;
format=flowed
--Apple-Mail-2--712385391--
_______________________________________________
Portable-clx mailing list
[email protected]
http://lists.metacircles.com/cgi-bin/mailman/listinfo/portable-clx
cvs -d :ext:cvs.telent.net:/usr/local/src/cvs co clx # over ssh
cvs -d :pserver:[email protected]:/cvs co clx # anonymous