[PATCH] CLISP support for telent-clx
"Evgeny M. Zubok" <[email protected]> Sun, 07 Jan 2007 01:25:48 +0000
| Newsgroups | gmane.lisp.clx.devel |
|---|---|
| Message-ID | <[email protected]> |
--=-=-=
Hi!
I merged CLISP dependent code from mit-clx sources to telent-clx. Now
telent-clx works also on CLISP. I tested some examples from clx/demo and run
McCLIM demo application (clim-demo::demodemo) from
mcclim/Examples. Patch attached.
--=-=-=
Content-Disposition: inline; filename=clisp-clx-patch
Content-Description: Patch_file
diff -r -u clx.orig/demo/clx-demos.lisp clx/demo/clx-demos.lisp
--- clx.orig/demo/clx-demos.lisp 2007-01-06 12:06:56.000000000 +0000
+++ clx/demo/clx-demos.lisp 2007-01-06 16:05:53.000000000 +0000
@@ -36,11 +36,11 @@
(unless *display*
#+:cmu
(multiple-value-setq (*display* *screen*) (ext:open-clx-display))
- #+(or sbcl allegro)
+ #+(or sbcl allegro clisp)
(progn
(setf *display* (xlib::open-default-display))
(setf *screen* (xlib:display-default-screen *display*)))
- #-(or cmu sbcl allegro)
+ #-(or cmu sbcl allegro clisp)
(progn
;; Portable method
(setf *display* (xlib:open-display (machine-instance)))
diff -r -u clx.orig/depdefs.lisp clx/depdefs.lisp
--- clx.orig/depdefs.lisp 2007-01-06 12:06:56.000000000 +0000
+++ clx/depdefs.lisp 2007-01-06 15:24:26.000000000 +0000
@@ -177,6 +177,10 @@
;;; this to do fast array packing/unpacking when the overlapping-arrays
;;; feature is enabled.
+#+clisp
+(eval-when (:compile-toplevel :execute :load-toplevel)
+ (unless system::*big-endian* (pushnew :clx-little-endian *features*)))
+
#+(and clx-little-endian lispm)
(eval-when (eval compile load)
(pushnew :clx-overlapping-arrays *features*))
diff -r -u clx.orig/dependent.lisp clx/dependent.lisp
--- clx.orig/dependent.lisp 2007-01-06 12:06:54.000000000 +0000
+++ clx/dependent.lisp 2007-01-06 15:51:12.000000000 +0000
@@ -689,7 +689,7 @@
(the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float))))
-#+(or cmu sbcl) (progn
+#+(or cmu sbcl clisp) (progn
;;; This overrides the (probably incorrect) definition in clx.lisp. Since PI
;;; is irrational, there can't be a precise rational representation. In
@@ -935,6 +935,14 @@
`(mp:with-lock-held (,lock ,whostate ,@(and timeout `(:timeout ,timeout)))
,@body))
+#+clisp
+(defmacro holding-lock ((lock display &optional (whostate "CLX wait")
+ &key timeout)
+ &body body)
+ (declare (ignore lock display whostate timeout))
+ `(progn
+ ,@body))
+
#+sbcl
(defmacro holding-lock ((lock display &optional (whostate "CLX wait")
&key timeout)
@@ -1168,6 +1176,7 @@
(return))
(yield)))
+
;;; 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
@@ -1401,11 +1410,35 @@
;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X
;;; server
-#-(or explorer Genera lucid kcl ibcl excl Minima CMU sbcl ecl)
+#-(or explorer Genera lucid kcl ibcl excl Minima CMU sbcl ecl clisp)
(defun open-x-stream (host display protocol)
host display protocol ;; unused
(error "OPEN-X-STREAM not implemented yet."))
+#+clisp
+(defun open-x-stream (host display protocol)
+ (declare (ignore protocol)
+ (type (integer 0) display))
+ (let ((socket
+ ;; are we dealing with a localhost?
+ (progn #+nil ignore-errors
+ (when (or (string= host "")
+ (string= host "unix"))
+ ;; ok, try to connect to a AF_UNIX domain socket
+ (sys::make-socket-stream "" display)))))
+ (if socket
+ socket
+ ;; try to connect by hand
+ (let ((host (host-address host)))
+ (when host
+ ;; Fixme: get a descent ip standard in CLX: a vector!
+ (let ((ip (format nil
+ "~{~D~^.~}"
+ (rest host))))
+ (socket:socket-connect (+ 6000 display) ip
+ :element-type '(unsigned-byte 8))))))))
+
+
;;; Genera:
;;; TCP and DNA are both layered products, so try to work with either one.
@@ -1653,7 +1686,7 @@
vector start (- end start))
nil)))
-#+ecl
+#+(or ecl clisp)
(defun buffer-read-default (display vector start end timeout)
(declare (type display display)
(type buffer-bytes vector)
@@ -1675,7 +1708,7 @@
;;; 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 clisp)
(defun buffer-read-default (display vector start end timeout)
(declare (type display display)
(type buffer-bytes vector)
@@ -1766,7 +1799,7 @@
(sb-impl::output-raw-bytes (display-output-stream display) vector start end)
nil)
-#+ecl
+#+(or ecl clisp)
(defun buffer-write-default (vector display start end)
(declare (type buffer-bytes vector)
(type display display)
@@ -1784,7 +1817,7 @@
;;; You are STRONGLY encouraged to write a specialized version
;;; of buffer-write-default that does block transfers.
-#-(or Genera explorer excl lcl3.0 Minima CMU sbcl)
+#-(or Genera explorer excl lcl3.0 Minima CMU sbcl clisp)
(defun buffer-write-default (vector display start end)
;; The default buffer write function for use with common-lisp streams
(declare (type buffer-bytes vector)
@@ -1847,7 +1880,7 @@
#-(or Genera explorer excl lcl3.0 CMU sbcl)
(defparameter *buffer-read-polling-time* 0.5)
-#-(or Genera explorer excl lcl3.0 CMU sbcl)
+#-(or Genera explorer excl lcl3.0 CMU sbcl clisp)
(defun buffer-input-wait-default (display timeout)
(declare (type display display)
(type (or null (real 0 *)) timeout))
@@ -1871,7 +1904,7 @@
(return-from buffer-input-wait-default nil)))
:timeout)))))
-#+(or CMU sbcl)
+#+(or CMU sbcl clisp)
(defun buffer-input-wait-default (display timeout)
(declare (type display display)
(type (or null number) timeout))
@@ -1885,7 +1918,10 @@
:input timeout)
#+mp (mp:process-wait-until-fd-usable
(system:fd-stream-fd stream) :input timeout)
- #-(or sbcl mp) (system:wait-until-fd-usable
+ #+clisp (multiple-value-bind (sec usec) (floor (or timeout 0))
+ (ext:socket-status stream (and timeout sec)
+ (round usec 1d-6)))
+ #-(or sbcl mp clisp) (system:wait-until-fd-usable
(system:fd-stream-fd stream) :input timeout)
nil
:timeout)))))
@@ -2252,9 +2288,9 @@
;; dispatching, not just type checking. -- Ram.
(defmacro type? (object type)
- #+(or cmu sbcl)
+ #+(or cmu sbcl clisp)
`(typep ,object ,type)
- #-(or cmu sbcl)
+ #-(or cmu sbcl clisp)
(if (not (constantp type))
`(typep ,object ,type)
(progn
@@ -2325,12 +2361,12 @@
(declare (dbg:error-reporter))
(apply #'sys:signal condition :continue-format-string proceed-format-string keyargs))
-#+(or clx-ansi-common-lisp excl lcl3.0 (and CMU mp))
+#+(or clx-ansi-common-lisp excl lcl3.0 clisp (and CMU mp))
(defun x-error (condition &rest keyargs)
(declare (dynamic-extent keyargs))
(apply #'error condition keyargs))
-#+(or clx-ansi-common-lisp excl lcl3.0 CMU)
+#+(or clx-ansi-common-lisp excl lcl3.0 CMU clisp)
(defun x-cerror (proceed-format-string condition &rest keyargs)
(declare (dynamic-extent keyargs))
(apply #'cerror proceed-format-string condition keyargs))
@@ -2353,12 +2389,12 @@
(ext::disable-clx-event-handling disp)))
(error condx)))
-#-(or lispm ansi-common-lisp excl lcl3.0 CMU sbcl)
+#-(or lispm ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
(defun x-error (condition &rest keyargs)
(error "X-Error: ~a"
(princ-to-string (apply #'make-condition condition keyargs))))
-#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
+#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
(defun x-cerror (proceed-format-string condition &rest keyargs)
(cerror proceed-format-string "X-Error: ~a"
(princ-to-string (apply #'make-condition condition keyargs))))
@@ -2451,7 +2487,7 @@
(sys:defmethod (dbg:document-proceed-type x-error :continue) (stream)
(format stream continue-format-string))
-#+(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
+#+(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
(define-condition x-error (error) ())
#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
@@ -2495,7 +2531,7 @@
,condition))
',name))))
-#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
+#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
(defun condition-print (condition stream depth)
(declare (type x-error condition)
(type stream stream)
@@ -2505,14 +2541,14 @@
(funcall (x-error-report-function condition) condition stream))
condition)
-#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
+#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
(defun make-condition (type &rest slot-initializations)
(declare (dynamic-extent slot-initializations))
(let ((make-function (intern (concatenate 'string (string 'make-) (string type))
(symbol-package type))))
(apply make-function slot-initializations)))
-#-(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
+#-(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl clisp)
(define-condition type-error (x-error)
((datum :reader type-error-datum :initarg :datum)
(expected-type :reader type-error-expected-type :initarg :expected-type))
@@ -2527,7 +2563,7 @@
;; HOST hacking
;;-----------------------------------------------------------------------------
-#-(or explorer Genera Minima Allegro CMU sbcl ecl)
+#-(or explorer Genera Minima Allegro CMU sbcl ecl clisp)
(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.
@@ -2537,6 +2573,45 @@
host family
(error "HOST-ADDRESS not implemented yet."))
+#+clisp
+(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))
+ (labels ((no-host-error ()
+ (error "Unknown host ~S" host))
+ (no-address-error ()
+ (error "Host ~S has no ~S address" host family)))
+
+ (let ((hostent (posix::resolve-host-ipaddr (string host))))
+ (when (not (posix::hostent-addr-list hostent))
+ (no-host-error))
+ (ecase family
+ ((:internet nil 0)
+ (unless (= (posix::hostent-addrtype hostent) 2)
+ (no-address-error))
+ (let ((addr (first (posix::hostent-addr-list hostent))))
+ (etypecase addr
+ (integer
+ (list :internet
+ (ldb (byte 8 24) addr)
+ (ldb (byte 8 16) addr)
+ (ldb (byte 8 8) addr)
+ (ldb (byte 8 0) addr)))
+ (string
+ (let ((parts (read-from-string
+ (nsubstitute #\Space #\. (ext:string-concat
+ "(" addr ")")))))
+ (check-type parts (cons (unsigned-byte 8)
+ (cons (unsigned-byte 8)
+ (cons (unsigned-byte 8)
+ (cons (unsigned-byte 8)
+ NULL)))))
+ (cons :internet parts))))))))))
+
+
#+explorer
(defun host-address (host &optional (family :internet))
;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
@@ -2808,7 +2883,8 @@
#+CMU (cdr (assoc name ext:*environment-list* :test #'string=))
#+sbcl (sb-ext:posix-getenv name)
#+ecl (si:getenv name)
- #-(or sbcl excl lcl3.0 CMU ecl) (progn name nil))
+ #+clisp (ext:getenv name)
+ #-(or sbcl excl lcl3.0 CMU ecl clisp) (progn name nil))
(defun get-host-name ()
"Return the same hostname as gethostname(3) would"
@@ -2818,7 +2894,8 @@
;; 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"))
+ #+clisp (let ((s (machine-instance))) (subseq s 0 (position #\Space s)))
+ #-(or excl cmu sbcl ecl clisp) (error "get-host-name not implemented"))
(defun homedir-file-pathname (name)
(and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal)
@@ -2986,7 +3063,7 @@
(setf (char-bit object :hyper) 1)))
object)
-#+(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl)
+#+(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl clisp)
(defun default-keysym-translate (display state object)
(declare (type display display)
(type card16 state)
--=-=-=--
_______________________________________________
Portable-clx mailing list
[email protected]
http://lists.metacircles.com/cgi-bin/mailman/listinfo/portable-clx
See http://www.cliki.net/clx for darcs URL(s)