Commit b1df6f1b authored by ram's avatar ram

This is CLX R5.01

parent c7892d65
This diff is collapsed.
......@@ -320,19 +320,19 @@
(defun window-visual (window)
(declare (type window window))
(declare (values resource-id))
(declare (clx-values resource-id))
(with-attributes (window :sizes 32)
(resource-id-get 8)))
(defun window-visual-info (window)
(declare (type window window))
(declare (values visual-info))
(declare (clx-values visual-info))
(with-attributes (window :sizes 32)
(visual-info (window-display window) (resource-id-get 8))))
(defun window-class (window)
(declare (type window window))
(declare (values (member :input-output :input-only)))
(declare (clx-values (member :input-output :input-only)))
(with-attributes (window :sizes 16)
(member16-get 12 :copy :input-output :input-only)))
......@@ -371,7 +371,7 @@
(defun window-bit-gravity (window)
;; setf'able
(declare (type window window))
(declare (values bit-gravity))
(declare (clx-values bit-gravity))
(with-attributes (window :sizes 8)
(member8-vector-get 14 *bit-gravity-vector*)))
......@@ -385,7 +385,7 @@
(defun window-gravity (window)
;; setf'able
(declare (type window window))
(declare (values win-gravity))
(declare (clx-values win-gravity))
(with-attributes (window :sizes 8)
(member8-vector-get 15 *win-gravity-vector*)))
......@@ -399,7 +399,7 @@
(defun window-backing-store (window)
;; setf'able
(declare (type window window))
(declare (values (member :not-useful :when-mapped :always)))
(declare (clx-values (member :not-useful :when-mapped :always)))
(with-attributes (window :sizes 8)
(member8-get 1 :not-useful :when-mapped :always)))
......@@ -413,7 +413,7 @@
(defun window-backing-planes (window)
;; setf'able
(declare (type window window))
(declare (values pixel))
(declare (clx-values pixel))
(with-attributes (window :sizes 32)
(card32-get 16)))
......@@ -426,7 +426,7 @@
(defun window-backing-pixel (window)
;; setf'able
(declare (type window window))
(declare (values pixel))
(declare (clx-values pixel))
(with-attributes (window :sizes 32)
(card32-get 20)))
......@@ -439,7 +439,7 @@
(defun window-save-under (window)
;; setf'able
(declare (type window window))
(declare (values (member :off :on)))
(declare (clx-values (member :off :on)))
(with-attributes (window :sizes 8)
(member8-get 24 :off :on)))
......@@ -452,7 +452,7 @@
(defun window-override-redirect (window)
;; setf'able
(declare (type window window))
(declare (values (member :off :on)))
(declare (clx-values (member :off :on)))
(with-attributes (window :sizes 8)
(member8-get 27 :off :on)))
......@@ -465,7 +465,7 @@
(defun window-event-mask (window)
;; setf'able
(declare (type window window))
(declare (values mask32))
(declare (clx-values mask32))
(with-attributes (window :sizes 32)
(card32-get 36)))
......@@ -479,7 +479,7 @@
(defun window-do-not-propagate-mask (window)
;; setf'able
(declare (type window window))
(declare (values mask32))
(declare (clx-values mask32))
(with-attributes (window :sizes 32)
(card32-get 40)))
......@@ -492,7 +492,7 @@
(defun window-colormap (window)
(declare (type window window))
(declare (values (or null colormap)))
(declare (clx-values (or null colormap)))
(with-attributes (window :sizes 32)
(let ((id (resource-id-get 28)))
(if (zerop id) nil
......@@ -507,7 +507,7 @@
(defun window-cursor (window)
(declare (type window window))
(declare (values cursor))
(declare (clx-values cursor))
window
(error "~S can only be set" 'window-cursor))
......@@ -520,19 +520,19 @@
(defun window-colormap-installed-p (window)
(declare (type window window))
(declare (values boolean))
(declare (clx-values boolean))
(with-attributes (window :sizes 8)
(boolean-get 25)))
(defun window-all-event-masks (window)
(declare (type window window))
(declare (values mask32))
(declare (clx-values mask32))
(with-attributes (window :sizes 32)
(card32-get 32)))
(defun window-map-state (window)
(declare (type window window))
(declare (values (member :unmapped :unviewable :viewable)))
(declare (clx-values (member :unmapped :unviewable :viewable)))
(with-attributes (window :sizes 8)
(member8-get 26 :unmapped :unviewable :viewable)))
......@@ -543,14 +543,14 @@
(defun drawable-root (drawable)
(declare (type drawable drawable))
(declare (values window))
(declare (clx-values window))
(with-geometry (drawable :sizes 32)
(window-get 8 (drawable-display drawable))))
(defun drawable-x (drawable)
;; setf'able
(declare (type drawable drawable))
(declare (values int16))
(declare (clx-values int16))
(with-geometry (drawable :sizes 16)
(int16-get 12)))
......@@ -563,7 +563,7 @@
(defun drawable-y (drawable)
;; setf'able
(declare (type drawable drawable))
(declare (values int16))
(declare (clx-values int16))
(with-geometry (drawable :sizes 16)
(int16-get 14)))
......@@ -577,7 +577,7 @@
;; setf'able
;; Inside width, excluding border.
(declare (type drawable drawable))
(declare (values card16))
(declare (clx-values card16))
(with-geometry (drawable :sizes 16)
(card16-get 16)))
......@@ -591,7 +591,7 @@
;; setf'able
;; Inside height, excluding border.
(declare (type drawable drawable))
(declare (values card16))
(declare (clx-values card16))
(with-geometry (drawable :sizes 16)
(card16-get 18)))
......@@ -603,14 +603,14 @@
(defun drawable-depth (drawable)
(declare (type drawable drawable))
(declare (values card8))
(declare (clx-values card8))
(with-geometry (drawable :sizes 8)
(card8-get 1)))
(defun drawable-border-width (drawable)
;; setf'able
(declare (type drawable drawable))
(declare (values integer))
(declare (clx-values integer))
(with-geometry (drawable :sizes 16)
(card16-get 20)))
......
......@@ -173,21 +173,17 @@
(buffer-lbuf (reply-ibuf32 %reply-buffer))))))
(declare (type array-index buffer-boffset))
#-clx-overlapping-arrays
(declare (type buffer-bytes buffer-bbuf)
(array-register buffer-bbuf))
(declare (type buffer-bytes buffer-bbuf))
#+clx-overlapping-arrays
,@(append
(when (member 8 sizes)
'((declare (type buffer-bytes buffer-bbuf)
(array-register buffer-bbuf))))
'((declare (type buffer-bytes buffer-bbuf))))
(when (member 16 sizes)
'((declare (type array-index buffer-woffset))
(declare (type buffer-words buffer-wbuf)
(array-register buffer-wbuf))))
(declare (type buffer-words buffer-wbuf))))
(when (member 32 sizes)
'((declare (type array-index buffer-loffset))
(declare (type buffer-longs buffer-lbuf)
(array-register buffer-lbuf)))))
(declare (type buffer-longs buffer-lbuf)))))
buffer-boffset
#-clx-overlapping-arrays
buffer-bbuf
......@@ -419,7 +415,7 @@
(type vector vector)
(type array-index start end)
(type (or null number) timeout))
(declare (values eof-p))
(declare (clx-values eof-p))
(when (buffer-dead buffer)
(x-error 'closed-display :display buffer))
(unless (= start end)
......@@ -437,7 +433,7 @@
;; Returns :TIMEOUT when timeout exceeded
(declare (type buffer buffer)
(type (or null number) timeout))
(declare (values timeout))
(declare (clx-values timeout))
(when (buffer-dead buffer)
(x-error 'closed-display :display buffer))
(let ((result
......@@ -452,7 +448,7 @@
;; Returns T if there is input available for the buffer. This should never
;; block, so it can be called from the scheduler.
(declare (type buffer buffer))
(declare (values input-available))
(declare (clx-values input-available))
(or (not (null (buffer-dead buffer)))
(wrap-buf-input (buffer)
(funcall (buffer-listen-function buffer) buffer))))
......@@ -1623,8 +1619,7 @@
(type array-index boffset)
(type (or null (simple-bit-vector 256)) data))
(let ((result (or data (make-array 256 :element-type 'bit :initial-element 0))))
(declare (type (simple-bit-vector 256) result)
(array-register result))
(declare (type (simple-bit-vector 256) result))
(do ((i (index+ boffset 1) (index+ i 1)) ;; Skip first byte
(j 8 (index+ j 8)))
((index>= j 256))
......
......@@ -120,21 +120,17 @@
(buffer-lbuf (buffer-obuf32 %buffer))))))
(declare (type array-index buffer-boffset))
#-clx-overlapping-arrays
(declare (type buffer-bytes buffer-bbuf)
(array-register buffer-bbuf))
(declare (type buffer-bytes buffer-bbuf))
#+clx-overlapping-arrays
,@(append
(when (member 8 sizes)
'((declare (type buffer-bytes buffer-bbuf)
(array-register buffer-bbuf))))
'((declare (type buffer-bytes buffer-bbuf))))
(when (member 16 sizes)
'((declare (type array-index buffer-woffset))
(declare (type buffer-words buffer-wbuf)
(array-register buffer-wbuf))))
(declare (type buffer-words buffer-wbuf))))
(when (member 32 sizes)
'((declare (type array-index buffer-loffset))
(declare (type buffer-longs buffer-lbuf)
(array-register buffer-lbuf)))))
(declare (type buffer-longs buffer-lbuf)))))
buffer-boffset
#-clx-overlapping-arrays
buffer-bbuf
......
This diff is collapsed.
;;; -*- Package: XLIB -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/clx/cmudep.lisp,v 1.1 1992/08/11 15:15:34 ram Exp $")
;;;
;;; **********************************************************************
;;;
(in-package "XLIB")
(alien:def-alien-routine ("connect_to_server" xlib::connect-to-server)
c-call:int
(host c-call:c-string)
(port c-call:int))
......@@ -30,6 +30,7 @@
;;; kcl
;;; ibcl
;;; excl
;;; CMU
#+(or Genera Minima)
(eval-when (:compile-toplevel :load-toplevel :execute)
......@@ -141,6 +142,23 @@
"buffer" "display" "gcontext" "input" "requests" "fonts" "graphics"
"text" "attributes" "translate" "keysyms" "manager" "image" "resource"))
#+Minima
(zl:::scl:defsystem Minima-CLX
(:default-pathname "SYS:X11;CLX;"
:pretty-name "Minima CLX"
:maintain-journals nil
:maintaining-sites (:scrc)
:distribute-sources t
:distribute-binaries t
:source-category :basic
:default-module-type :minima-lisp)
(:module doc ("doc")
(:type :lisp-example))
(:serial
"package" "depdefs" "clx" "dependent" "macros" "bufmac"
"buffer" "display" "gcontext" "input" "requests" "fonts" "graphics"
"text" "attributes" "translate" "keysyms" "manager" "image" "resource"))
;;; Franz
......@@ -322,7 +340,7 @@
(format t "~&Finished faslinking ~A.~%" pathname)))
)
#-(or lispm allegro)
#-(or lispm allegro Minima)
(defun compile-clx (&optional
(source-pathname-defaults "")
(binary-pathname-defaults "")
......@@ -378,7 +396,7 @@
#+(or kcl ibcl) (load source)
(if (equal source binary)
(compile-file source)
(compile-file source :output-file binary))
(compile-file source :output-file binary))
binary))
(compile-and-load (filename)
(load (compile-lisp filename)))
......@@ -413,9 +431,9 @@
;; Now compile and load all the files.
;; Defer compiler warnings until everything's compiled, if possible.
(#+clx-ansi-common-lisp with-compilation-unit
(#+(or clx-ansi-common-lisp CMU) with-compilation-unit
#+lcl3.0 lucid::with-deferred-warnings
#-(or lcl3.0 clx-ansi-common-lisp) progn
#-(or lcl3.0 clx-ansi-common-lisp CMU) progn
()
(compile-and-load "package")
......@@ -465,7 +483,7 @@
;;; (LOAD <clx-defsystem-file>)
;;; (LOAD-CLX <binary-specific-clx-directory>)
#-(or lispm allegro)
#-(or lispm allegro Minima)
(defun load-clx (&optional (binary-pathname-defaults "")
&key (macrosp nil))
......
......@@ -45,10 +45,13 @@
decl-specs))
`(proclaim ',(car decl-specs))))
;;; VALUES value1 value2 ... -- Documents the values returned by the function.
;;; CLX-VALUES value1 value2 ... -- Documents the values returned by the function.
#-lispm
(declaim (declaration values))
#-Genera
(declaim (declaration clx-values))
#+Genera
(setf (get 'clx-values 'si:declaration-alias) 'scl:values)
;;; ARGLIST arg1 arg2 ... -- Documents the arglist of the function. Overrides
;;; the documentation that might get generated by the real arglist of the
......@@ -69,12 +72,6 @@
#-clx-ansi-common-lisp
(declaim (declaration ignorable))
;;; ARRAY-REGISTER var1 var2 ... -- The variables mentioned are locals (not
;;; args) that hold vectors.
#-Genera
(declaim (declaration array-register))
;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to
;;; indent calls to the function or macro containing the declaration.
......@@ -89,8 +86,7 @@
;;; and then does a type declaration and array register declaration
(defmacro with-vector ((var type) &body body)
`(let ((,var ,var))
(declare (type ,type ,var)
(array-register ,var))
(declare (type ,type ,var))
,@body))
;;; WITHIN-DEFINITION (name type) &body body --- Includes definitions for
......@@ -155,6 +151,12 @@
(:big nil)
(:little (pushnew :clx-little-endian *features*))))
#+cmu
(eval-when (compile eval load)
(ecase #.(c:backend-byte-order c:*backend*)
(:big-endian)
(:little-endian (pushnew :clx-little-endian *features*))))
;;; Steele's Common-Lisp states: "It is an error if the array specified
;;; as the :displaced-to argument does not have the same :element-type
;;; as the array being created" If this is the case on your lisp, then
......
This diff is collapsed.
......@@ -20,6 +20,62 @@
(in-package :xlib)
;;; Authorizaton
(defparameter *known-authorizations* '("MIT-MAGIC-COOKIE-1"))
(defun get-best-authorization (host display protocol)
(labels ((read-short (stream &optional (eof-errorp t))
(let ((high-byte (read-byte stream eof-errorp)))
(and high-byte
(dpb high-byte (byte 8 8) (read-byte stream)))))
(read-short-length-string (stream)
(let ((length (read-short stream)))
(let ((string (make-string length)))
(dotimes (k length)
(setf (schar string k) (card8->char (read-byte stream))))
string)))
(read-short-length-vector (stream)
(let ((length (read-short stream)))
(let ((vector (make-array length :element-type '(unsigned-byte 8))))
(dotimes (k length)
(setf (aref vector k) (read-byte stream)))
vector))))
(let ((pathname (authority-pathname)))
(when pathname
(with-open-file (stream pathname :element-type '(unsigned-byte 8)
:if-does-not-exist nil)
(when stream
(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
;;
......@@ -38,7 +94,7 @@
(defun resourcealloc (display)
;; Allocate a resource-id for in DISPLAY
(declare (type display display))
(declare (values resource-id))
(declare (clx-values resource-id))
(dpb (incf (display-resource-id-count display))
(display-resource-id-byte display)
(display-resource-id-base display)))
......@@ -68,7 +124,7 @@
(declare (type display display)
(type integer id)
(type t object))
(declare (values object))
(declare (clx-values object))
(setf (gethash id (display-resource-id-map display)) object))
;; Define functions to find the CLX data types given a display and resource-id
......@@ -81,7 +137,7 @@
(display id)
(declare (type display display)
(type resource-id id))
(declare (values ,type))
(declare (clx-values ,type))
,(if (member type *clx-cached-types*)
`(let ((,type (lookup-resource-id display id)))
(cond ((null ,type) ;; Not found, create and save it.
......@@ -117,14 +173,14 @@
;; Return the cached atom for an atom ID
(declare (type resource-id id)
(type display display))
(declare (values (or null keyword)))
(declare (clx-values (or null keyword)))
(gethash id (display-atom-id-map display)))
(defun atom-id (atom display)
;; Return the ID for an atom in DISPLAY
(declare (type xatom atom)
(type display display))
(declare (values (or null resource-id)))
(declare (clx-values (or null resource-id)))
(gethash (if (or (null atom) (keywordp atom)) atom (kintern atom))
(display-atom-cache display)))
......@@ -133,7 +189,7 @@
(declare (type xatom atom)
(type display display)
(type resource-id id))
(declare (values resource-id))
(declare (clx-values resource-id))
(let ((atom (if (or (null atom) (keywordp atom)) atom (kintern atom))))
(setf (gethash id (display-atom-id-map display)) atom)
(setf (gethash atom (display-atom-cache display)) id)
......@@ -149,7 +205,7 @@
(defun visual-info (display visual-id)
(declare (type display display)
(type resource-id visual-id)
(values visual-info))
(clx-values visual-info))
(when (zerop visual-id)
(return-from visual-info nil))
(dolist (screen (display-roots display))
......@@ -223,8 +279,7 @@
,@(and timeout `(:timeout ,timeout)))
,@body))))
(defun open-display (host &rest options &key (display 0) protocol
authorization-name authorization-data &allow-other-keys)
(defun open-display (host &key (display 0) protocol authorization-name authorization-data)
;; Implementation specific routine to setup the buffer for a specific host and display.
;; This must interface with the local network facilities, and will probably do special
;; things to circumvent the nework when displaying on the local host.
......@@ -233,26 +288,25 @@
;; for host and protocol are not constrained, and will likely be very
;; system dependent. The default protocol is system specific. Authorization,
;; if any, is assumed to come from the environment somehow.
(declare (type integer display)
(dynamic-extent options))
(declare (values display))
(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 (apply #'make-buffer
*output-buffer-size*
'make-display-internal
:host host
:display display
:output-stream stream
:input-stream stream
:allow-other-keys t
options))
(disp (make-buffer *output-buffer-size* #'make-display-internal
:host host :display display
:output-stream stream :input-stream stream))
(ok-p nil))
(unwind-protect
(progn
(display-connect disp
:authorization-name authorization-name
:authorization-data authorization-data)
(setf (display-authorization-name disp) authorization-name)
(setf (display-authorization-data disp) authorization-data)
(initialize-resource-allocator disp)
(initialize-predefined-atoms disp)
(initialize-extensions disp)
......@@ -272,8 +326,6 @@
(close-buffer display :abort abort))
(defun display-connect (display &key authorization-name authorization-data)
(unless authorization-name (setq authorization-name ""))
(unless authorization-data (setq authorization-data ""))
(with-buffer-output (display :sizes (8 16))
(card8-put
0
......@@ -285,8 +337,11 @@
(card16-put 6 (length authorization-name))
(card16-put 8 (length authorization-data))
(write-sequence-char display 12 authorization-name)
(write-sequence-char display
(lround (+ 12 (length authorization-name))) authorization-data))
(if (stringp authorization-data)
(write-sequence-char display (lround (+ 12 (length authorization-name)))
authorization-data)
(write-sequence-card8 display (lround (+ 12 (length authorization-name)))
authorization-data)))
(buffer-force-output display)
(let ((reply-buffer nil))
(declare (type (or null reply-buffer) reply-buffer))
......@@ -420,13 +475,13 @@
(defun display-protocol-version (display)
(declare (type display display))
(declare (values major minor))
(declare (clx-values major minor))
(values (display-protocol-major-version display)
(display-protocol-minor-version display)))
(defun display-vendor (display)
(declare (type display display))
(declare (values name release))
(declare (clx-values name release))
(values (display-vendor-name display)
(display-release-number display)))
......
This diff is collapsed.
......@@ -31,17 +31,17 @@
; ;; signalling might be better.
; (declare (type font font)
; (type integer index)
; (values (or null integer))))
; (clx-values (or null integer))))
;(defun max-char-<metric> (font)
; ;; Note: I have tentatively chosen separate accessors over allowing :min and
; ;; :max as an index above.
; (declare (type font font)
; (values integer)))
; (clx-values integer)))
;(defun min-char-<metric> (font)
; (declare (type font font)
; (values integer)))
; (clx-values integer)))
;; Note: char16-<metric> accessors could be defined to accept two-byte indexes.
......@@ -64,7 +64,7 @@
`(defun ,name (font index)
(declare (type font font)
(type array-index index))
(declare (values (or null ,type)))
(declare (clx-values (or null ,type)))
(when (and (font-name font)
(index>= (font-max-char font) index (font-min-char font)))
(the ,type
......@@ -91,7 +91,7 @@
(push
`(defun ,name (font)
(declare (type font font))
(declare (values (or null ,type)))
(declare (clx-values (or null ,type)))
(when (font-name font)
(the ,type
,(from
......@@ -103,7 +103,7 @@
(push
`(defun ,name (font)
(declare (type font font))
(declare (values (or null ,type)))
(declare (clx-values (or null ,type)))
(when (font-name font)
(the ,type
,(from
......@@ -119,8 +119,7 @@
fields))
(declare ,@(mapcar #'(lambda (field) `(type ,@(reverse field))) fields))
(let ((result (make-array ,(length fields) :element-type 'int16)))
(declare (type char-info-vec result)
(array-register result))
(declare (type char-info-vec result))
,@(do* ((field fields (cdr field))
(var (caar field) (caar field))
(type (cadar field) (cadar field))
......@@ -147,7 +146,7 @@
;; The protocol QueryFont request happens on-demand under the covers.
(declare (type display display)
(type stringable name))
(declare (values font))
(declare (clx-values font))
(let* ((name-string (string-downcase (string name)))
(font (car (member name-string (display-font-cache display)
:key 'font-name
......@@ -169,7 +168,7 @@
(defun open-font-internal (font)
;; Called "under the covers" to open a font object
(declare (type font font))
(declare (values resource-id))
(declare (clx-values resource-id))
(let* ((name-string (font-name font))
(display (font-display font))
(id (allocate-resource-id display font 'font)))
......@@ -193,7 +192,7 @@
(defun query-font (font)
;; Internal function called by font and char info accessors
(declare (type font font))
(declare (values font-info))
(declare (clx-values font-info))
(let ((display (font-display font))
font-id
font-info
......@@ -258,7 +257,7 @@
(type string pattern)
(type card16 max-fonts)
(type t result-type)) ;; CL type
(declare (values (sequence string)))
(declare (clx-values (clx-sequence string)))
(let ((string (string pattern)))
(with-buffer-request-and-reply (display *x-listfonts* size :sizes (8 16))
((card16 max-fonts (length string))
......@@ -278,7 +277,7 @@
(type string pattern)
(type card16 max-fonts)
(type t result-type)) ;; CL type
(declare (values (sequence font)))
(declare (clx-values (clx-sequence font)))
(let ((string (string pattern))
(result nil))
(with-buffer-request-and-reply (display *x-listfontswithinfo* 60