Index: CLX/README.Lispworks diff -c /dev/null CLX/README.Lispworks:1.3 *** /dev/null Wed Nov 5 19:47:46 2003 --- CLX/README.Lispworks Sat Sep 27 15:13:11 2003 *************** *** 0 **** --- 1,17 ---- + ;;-*- Mode: Text -*- + Note : For Domain socket access, get uk.org.bew.comm-ext and load it BEFORE + compiling. The port will run fine however on tcp sockets WITHOUT this. + + I did not rename any of the .l files to .lisp - Just define a logical pathname + translation "CLX" something like : + + (setf (logical-pathname-translations "CLX") + '(("**;*.LISP.*" "D:\\Projects\\CLX\\**\\*.l") + ("**;*.FSL.*" "D:\\Projects\\CLX\\**\\*.fsl"))) + + Other than that, just load defsys.lisp, Compile System CLX and load CLX:demo;qix.lisp. Then run: + (xlib::qix :host "yourhost") + or, if you loaded my comm-ext stuff, + (xlib::qix :host "") or (xlib::qix :host "/local") + + Have fun! Index: CLX/clx.l diff -c CLX/clx.l:1.1.1.2 CLX/clx.l:1.2 *** CLX/clx.l:1.1.1.2 Sun Sep 23 21:43:15 2001 --- CLX/clx.l Fri Sep 28 20:49:29 2001 *************** *** 92,97 **** --- 92,103 ---- (defparameter *x-tcp-port* 6000) ;; add display number + ;;; For UNIX Domain socket access. The below is correct on Linux + ;;; (and FWIW, Solaris 2.6 too). I guess it may be different for other systems + #+LispWorks + (defvar *x-unix-path* "/tmp/.X11-unix/X0" + "The path for UNIX domain socket access") + ;; Note: if you have read the Version 11 protocol document or C Xlib manual, most of ;; the relationships should be fairly obvious. We have no intention of writing yet ;; another moby document for this interface. Index: CLX/defsys.lisp diff -c /dev/null CLX/defsys.lisp:1.2 *** /dev/null Wed Nov 5 19:47:46 2003 --- CLX/defsys.lisp Fri Sep 28 20:49:29 2001 *************** *** 0 **** --- 1,20 ---- + ;;; LispWorks + #+(or Genera Minima LispWorks) + (eval-when (:compile-toplevel :load-toplevel :execute) + (common-lisp:pushnew :clx-ansi-common-lisp common-lisp:*features*) + (require "comm")) + + #+clx-ansi-common-lisp + (common-lisp:in-package :common-lisp-user) + + #+LispWorks + (lw:defsystem CLX + (:default-pathname "CLX:" + :default-type :lisp-file + ) + :members + ("package" "depdefs" "clx" "dependent" "macros" "bufmac" + "buffer" "display" "gcontext" "input" "requests" "fonts" "graphics" + "text" "attributes" "translate" "keysyms" "manager" "image" "resource") + :rules ((:in-order-to :compile :all + (:requires (:load :previous))))) \ No newline at end of file Index: CLX/dependent.l diff -c CLX/dependent.l:1.1.1.2 CLX/dependent.l:1.6 *** CLX/dependent.l:1.1.1.2 Sun Sep 23 21:43:14 2001 --- CLX/dependent.l Sat Sep 27 15:13:11 2003 *************** *** 19,24 **** --- 19,26 ---- ;;; (in-package :xlib) + #+LispWorks + (require "comm") ;;; The size of the output buffer. Must be a multiple of 4. (defparameter *output-buffer-size* 8192) *************** *** 833,839 **** ;;; MAKE-PROCESS-LOCK: Creating a process lock. ! #-(or LispM excl Minima) (defun make-process-lock (name) (declare (ignore name)) nil) --- 835,841 ---- ;;; MAKE-PROCESS-LOCK: Creating a process lock. ! #-(or LispM excl Minima LispWorks) (defun make-process-lock (name) (declare (ignore name)) nil) *************** *** 854,859 **** --- 856,865 ---- (defun make-process-lock (name) (minima:make-lock name :recursive t)) + #+LispWorks + (defun make-process-lock (name) + (mp:make-lock :name name)) + ;;; HOLDING-LOCK: Execute a body of code with a lock held. ;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN *************** *** 862,872 **** ;; If you're not sharing DISPLAY objects within a multi-processing ;; shared-memory environment, this is sufficient ! #-(or lispm excl lcl3.0 Minima CMU) (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) (declare (ignore locator display whostate timeout)) `(progn ,@body)) ;;; HOLDING-LOCK for CMU Common Lisp. ;;; ;;; We are not multi-processing, but we use this macro to try to protect --- 868,886 ---- ;; If you're not sharing DISPLAY objects within a multi-processing ;; shared-memory environment, this is sufficient ! #-(or lispm excl lcl3.0 Minima CMU LispWorks) (defmacro holding-lock ((locator display &optional whostate &key timeout) &body body) (declare (ignore locator display whostate timeout)) `(progn ,@body)) + + #+LispWorks + (defmacro holding-lock ((locator display &optional whostate &key timeout) + &body body) + (declare (ignore display whostate)) + `(mp:with-lock (,locator :timeout ,timeout) + ,@body)) + ;;; HOLDING-LOCK for CMU Common Lisp. ;;; ;;; We are not multi-processing, but we use this macro to try to protect *************** *** 1008,1017 **** ;;; request writing and reply reading to ensure that requests are atomically ;;; written and replies are atomically read from the stream. ! #-(or Genera excl lcl3.0) (defmacro without-aborts (&body body) `(progn ,@body)) #+Genera (defmacro without-aborts (&body body) `(sys:without-aborts (clx "CLX is in the middle of an operation that should be atomic.") --- 1022,1032 ---- ;;; request writing and reply reading to ensure that requests are atomically ;;; written and replies are atomically read from the stream. ! #-(or Genera excl lcl3.0 ) (defmacro without-aborts (&body body) `(progn ,@body)) + #+Genera (defmacro without-aborts (&body body) `(sys:without-aborts (clx "CLX is in the middle of an operation that should be atomic.") *************** *** 1029,1040 **** ;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's ;;; value changes. ! #-(or lispm excl lcl3.0 Minima) (defun process-block (whostate predicate &rest predicate-args) (declare (ignore whostate)) (or (apply predicate predicate-args) (error "Program tried to wait with no scheduler."))) #+Genera (defun process-block (whostate predicate &rest predicate-args) (declare (type function predicate) --- 1044,1060 ---- ;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's ;;; value changes. ! #-(or lispm excl lcl3.0 Minima LispWorks) (defun process-block (whostate predicate &rest predicate-args) (declare (ignore whostate)) (or (apply predicate predicate-args) (error "Program tried to wait with no scheduler."))) + #+LispWorks + (defun process-block (whostate predicate &rest predicate-args) + (declare (dynamic-extent predicate-args)) + (mp:process-wait whostate predicate predicate-args)) + #+Genera (defun process-block (whostate predicate &rest predicate-args) (declare (type function predicate) *************** *** 1075,1085 **** (declaim (inline process-wakeup)) ! #-(or excl Genera Minima) (defun process-wakeup (process) (declare (ignore process)) nil) #+excl (defun process-wakeup (process) (let ((curproc mp::*current-process*)) --- 1095,1115 ---- (declaim (inline process-wakeup)) ! #-(or excl Genera Minima LispWorks) (defun process-wakeup (process) (declare (ignore process)) nil) + #+LispWorks + (defun process-wakeup (process) + (let ((curproc mp:*current-process*)) + (when (and curproc process) + (unless (mp:process-p curproc) + (error "~s is not a process" curproc)) + (unless (mp::process-p process) + (error "~s is not a process" process)) + (if (> (mp:process-priority process) (mp:process-priority curproc)) + (mp:process-allow-scheduling process))))) #+excl (defun process-wakeup (process) (let ((curproc mp::*current-process*)) *************** *** 1107,1113 **** ;;; Default return NIL, which is acceptable even if there is a scheduler. ! #-(or lispm excl lcl3.0 Minima) (defun current-process () nil) --- 1137,1143 ---- ;;; Default return NIL, which is acceptable even if there is a scheduler. ! #-(or lispm excl lcl3.0 Minima LispWorks) (defun current-process () nil) *************** *** 1128,1139 **** (defun current-process () (minima:current-process)) ;;; WITHOUT-INTERRUPTS -- provide for atomic operations. ! #-(or lispm excl lcl3.0 Minima) (defmacro without-interrupts (&body body) `(progn ,@body)) #+(and lispm (not Genera)) (defmacro without-interrupts (&body body) `(sys:without-interrupts ,@body)) --- 1158,1177 ---- (defun current-process () (minima:current-process)) + #+LispWorks + (defun current-process () + mp:*current-process*) + ;;; WITHOUT-INTERRUPTS -- provide for atomic operations. ! #-(or lispm excl lcl3.0 Minima LispWorks) (defmacro without-interrupts (&body body) `(progn ,@body)) + #-LispWorks + (defmacro without-interrupts (&body body) + `(mp:without-preemption ,@body)) + #+(and lispm (not Genera)) (defmacro without-interrupts (&body body) `(sys:without-interrupts ,@body)) *************** *** 1222,1232 **** ;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X ;;; server ! #-(or explorer Genera lucid kcl ibcl excl Minima CMU) (defun open-x-stream (host display protocol) host display protocol ;; unused (error "OPEN-X-STREAM not implemented yet.")) ;;; Genera: ;;; TCP and DNA are both layered products, so try to work with either one. --- 1260,1288 ---- ;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X ;;; server ! ! #-(or explorer Genera lucid kcl ibcl excl Minima LispWorks CMU) (defun open-x-stream (host display protocol) host display protocol ;; unused (error "OPEN-X-STREAM not implemented yet.")) + ;;; LispWorks + + + #+LispWorks + (defun open-x-stream (host display protocol) + (declare (ignore protocol)) + (if (or (string= host "") (not host) (string= host "/local")) + #+uk.org.bew.comm-ext(uk.org.bew.comm-ext:open-unix-stream host *x-unix-path* + :direction :io + :element-type 'unsigned-byte + :errorp t) + #-uk.org.bew.comm-ext(error "Need to load uk.org.bew.comm-ext for unix domain sockets") + (comm:open-tcp-stream host (+ *x-tcp-port* display) + :direction :io + :element-type 'unsigned-byte + :errorp t))) + ;;; Genera: ;;; TCP and DNA are both layered products, so try to work with either one. *************** *** 1464,1475 **** 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) (defun buffer-read-default (display vector start end timeout) (declare (type display display) (type buffer-bytes vector) --- 1520,1545 ---- vector start (- end start)) nil))) + #+LispWorks + (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) + (cond ((and (and timeout (= timeout 0)) + (not (listen (display-input-stream display)))) + :timeout) + (t + (read-sequence vector (display-input-stream display) :start start :end end) + nil))) + ;;; (read-sequence vector (display-input-stream display) :start start :end end) ;;; 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 LispWorks) (defun buffer-read-default (display vector start end timeout) (declare (type display display) (type buffer-bytes vector) *************** *** 1491,1496 **** --- 1561,1567 ---- (return t) (setf (aref vector index) (the card8 c)))))))) + ;;; BUFFER-WRITE-DEFAULT - write data to the X stream #+(or Genera explorer) *************** *** 1551,1563 **** (system:output-raw-bytes (display-output-stream display) vector start end) 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. ! #-(or Genera explorer excl lcl3.0 Minima CMU) (defun buffer-write-default (vector display start end) ;; The default buffer write function for use with common-lisp streams (declare (type buffer-bytes vector) --- 1622,1643 ---- (system:output-raw-bytes (display-output-stream display) vector start end) nil) + #+LispWorks + (defun buffer-write-default (vector display start end) + (declare (type buffer-bytes vector) + (type display display) + (type array-index start end)) + #.(declare-buffun) + (write-sequence vector (display-output-stream display) :start start :end end) + 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. ! #-(or Genera explorer excl lcl3.0 Minima CMU LispWorks) (defun buffer-write-default (vector display start end) ;; The default buffer write function for use with common-lisp streams (declare (type buffer-bytes vector) *************** *** 2302,2308 **** ;; HOST hacking ;;----------------------------------------------------------------------------- ! #-(or explorer Genera Minima Allegro CMU) (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. --- 2382,2388 ---- ;; HOST hacking ;;----------------------------------------------------------------------------- ! #-(or explorer Genera Minima LispWorks Allegro CMU) (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. *************** *** 2312,2317 **** --- 2392,2419 ---- host family (error "HOST-ADDRESS not implemented yet.")) + #+LispWorks + (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 (values list)) + (labels ((no-host-error () + (error "Unknown host ~S" host)) + (no-address-error () + (error "Host ~S has no ~S address" host family))) + (let ((addr (comm:get-host-entry (string host) :fields '(:address)))) + (when (not addr) + (no-host-error)) + (ecase family + ((:internet 0) + (list :internet + (ldb (byte 8 24) addr) + (ldb (byte 8 16) addr) + (ldb (byte 8 8) addr) + (ldb (byte 8 0) addr))))))) + #+explorer (defun host-address (host &optional (family :internet)) ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos) *************** *** 2541,2546 **** --- 2643,2649 ---- (defun default-resources-pathname () (homedir-file-pathname ".Xdefaults")) + ;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the ;;; defaults have been loaded. Index: CLX/display.l diff -c CLX/display.l:1.1.1.2 CLX/display.l:1.3 *** CLX/display.l:1.1.1.2 Sun Sep 23 21:43:15 2001 --- CLX/display.l Mon Sep 24 21:13:41 2001 *************** *** 49,81 **** (let* ((host-family (ecase protocol ((:tcp :internet nil) 0) ((:dna :DECnet) 1) ! ((:chaos) 2))) ! (host-address (rest (host-address host host-family))) (best-name nil) (best-data nil)) (loop ! (let ((family (read-short stream nil))) ! (when (null family) ! (return)) ! (let* ((address (read-short-length-vector stream)) ! (number (parse-integer (read-short-length-string stream))) ! (name (read-short-length-string stream)) ! (data (read-short-length-vector stream))) ! (when (and (= family host-family) ! (equal host-address (coerce address 'list)) ! (= number display) ! (let ((pos1 (position name *known-authorizations* :test #'string=))) ! (and pos1 ! (or (null best-name) ! (< pos1 (position best-name *known-authorizations* ! :test #'string=)))))) ! (setf best-name name) ! (setf best-data data))))) (when best-name (return-from get-best-authorization (values best-name best-data))))))))) (values "" "")) ;; ;; Resource id management ;; --- 49,85 ---- (let* ((host-family (ecase protocol ((:tcp :internet nil) 0) ((:dna :DECnet) 1) ! ((:chaos) 2) ! ((:unix) 256))) ! (host-address (if (eq protocol :unix) ! (map 'list #'char-int (machine-instance)) ! (rest (host-address host host-family)))) (best-name nil) (best-data nil)) (loop ! (let ((family (read-short stream nil))) ! (when (null family) ! (return)) ! (let* ((address (read-short-length-vector stream)) ! (number (parse-integer (read-short-length-string stream))) ! (name (read-short-length-string stream)) ! (data (read-short-length-vector stream))) ! (when (and (= family host-family) ! (equal host-address (coerce address 'list)) ! (= number display) ! (let ((pos1 (position name *known-authorizations* :test #'string=))) ! (and pos1 ! (or (null best-name) ! (< pos1 (position best-name *known-authorizations* ! :test #'string=)))))) ! (setf best-name name) ! (setf best-data data))))) (when best-name (return-from get-best-authorization (values best-name best-data))))))))) (values "" "")) + ;; ;; Resource id management ;; *************** *** 290,299 **** ;; if any, is assumed to come from the environment somehow. (declare (type integer display)) (declare (clx-values display)) ! ;; Get the authorization mechanism from the environment. (when (null authorization-name) (multiple-value-setq (authorization-name authorization-data) ! (get-best-authorization host display protocol))) ;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM. (let* ((stream (open-x-stream host display protocol)) (disp (make-buffer *output-buffer-size* #'make-display-internal --- 294,309 ---- ;; if any, is assumed to come from the environment somehow. (declare (type integer display)) (declare (clx-values display)) ! ;; Get the authorization mechanism from the environment. Handle the ! ;; special case of a host name of "" and "/local" which means the ! ;; protocol is :unix (when (null authorization-name) (multiple-value-setq (authorization-name authorization-data) ! (get-best-authorization host ! display ! (if (member host '("" "/local") :test #'string-equal) ! :unix ! protocol)))) ;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM. (let* ((stream (open-x-stream host display protocol)) (disp (make-buffer *output-buffer-size* #'make-display-internal Index: CLX/package.l diff -c CLX/package.l:1.1.1.2 CLX/package.l:1.3 *** CLX/package.l:1.1.1.2 Sun Sep 23 21:43:17 2001 --- CLX/package.l Mon Sep 24 21:13:41 2001 *************** *** 233,238 **** --- 233,239 ---- #+(or kcl ibcl) (:shadow rational) #+allegro (:use cltl1) #+allegro (:import-from excl without-interrupts) + #+LispWorks (:import-from mp without-interrupts) #+excl (:import-from excl arglist) #+Genera (:import-from zwei indentation) #+lcl3.0 (:import-from lcl arglist) Index: CLX/demo/qix.l diff -c /dev/null CLX/demo/qix.l:1.1 *** /dev/null Wed Nov 5 19:47:46 2003 --- CLX/demo/qix.l Sat Sep 27 15:13:11 2003 *************** *** 0 **** --- 1,96 ---- + ;;;; + ;;;; Title: The famous swirling vectors using CLX + ;;;; Created: Wed Feb 14 15:51:39 1996 + ;;;; Author: Gilbert Baumann + ;;;; Copyright: None, since this code is not worth it. + + ;;;; -- TODO -- + ;;;; + ;;;; o react on resize events + ;;;; o possibly react on iconify events by stoping + ;;;; o maybe pressing 'q' should terminate it + ;;;; o window documentation line is needed + ;;;; o maybe add a root window option + ;;;; o or a spline option?! + ;;;; + + (in-package :xlib) + + (defvar *offset* 3) + (defvar *delta* 6) + + (defun check-bounds (val del max) + (cond ((< val 0) (+ (random *delta*) *offset*)) + ((> val max) (- (+ (random *delta*) *offset*))) + (t del))) + + ;; IHMO this is worth to be added to the standard. + (defun make-circular (x) (nconc x x)) + + (defstruct qix + lines dims deltas coords) + + (defun gen-qix (nlines width height) + (make-qix :lines (make-circular (make-list nlines)) + :dims (list width height width height) + :deltas (list #3=(+ *offset* (random *delta*)) #3# #3# #3#) + :coords (list #1=(random width) #2=(random height) #1# #2#) )) + + (defun step-qix (qix win gc white-pixel black-pixel) + (when (car (qix-lines qix)) + (setf (xlib:gcontext-foreground gc) white-pixel) + (apply #'xlib:draw-line win gc (car (qix-lines qix))) + (setf (xlib:gcontext-foreground gc) black-pixel)) + (map-into (qix-coords qix) #'+ (qix-coords qix) (qix-deltas qix)) + (map-into (qix-deltas qix) #'check-bounds + (qix-coords qix) (qix-deltas qix) (qix-dims qix)) + (apply #'xlib:draw-line win gc (qix-coords qix)) + ;; push 'em into + (unless (car (qix-lines qix)) (setf (car (qix-lines qix)) (make-list 4))) + (map-into (car (qix-lines qix)) #'identity (qix-coords qix)) + (setf (qix-lines qix) (cdr (qix-lines qix))) ) + + (defun draw-qix (dpy win gc width height white-pixel black-pixel + delay nqixs nlines) + (let ((qixs nil) (n nlines)) + (dotimes (k nqixs) (push (gen-qix nlines width height) qixs)) + (loop + (dolist (k qixs) + (step-qix k win gc white-pixel black-pixel)) + (xlib:display-force-output dpy) + (sleep delay) + (setq n (- n 1)) + (if (<= n 0) (return))))) + + (defun qix (&key host display dpy + (width 400) (height 400) (delay 0.05) (nqixs 3) (nlines 80)) + #+ignore(setf (values host display) (x-host-display)) + (let* ((dp1 (or dpy (xlib:open-display host))) ;:display display))) + (scr (first (xlib:display-roots dp1))) + (root-win (xlib:screen-root scr)) + (white-pixel (xlib:screen-white-pixel scr)) + (black-pixel (xlib:screen-black-pixel scr)) + (win (xlib:create-window :parent root-win :x 10 :y 10 + :width width :height height + :background white-pixel)) + (gcon (xlib:create-gcontext :drawable win + :foreground black-pixel + :background white-pixel))) + (xlib:map-window win) + (xlib:display-finish-output dp1) + (format t "~&Qix uses the following parameters:~% :dpy: ~s + :host ~s :display ~s + :width ~d :height ~d :delay ~f :nqixs ~d :nlines ~d~%" + dp1 host display width height delay nqixs nlines) + (draw-qix dp1 win gcon width height white-pixel black-pixel + delay nqixs nlines) + (xlib:unmap-window win) + (xlib:destroy-window win) + ;;clean-up + (unless dpy (xlib:close-display dp1)))) + + ;; since we have no herald, simply dump it: + (format t "~& The famous swirling vectors.~% + (xlib::qix :host :display :dpy :width :height :delay :nqixs :nlines) + ~% Call (xlib::qix :host \"\") or (xlib::qix :host \"\" :delay 0).~%") +