clx.asd 7.41 KB
Newer Older
1
;;; -*- Lisp -*- mode
2
3
4
5
6
7
8
9
10
11

;;; Original copyright message from defsystem.lisp:

;;;			 TEXAS INSTRUMENTS INCORPORATED
;;;				  P.O. BOX 2909
;;;			       AUSTIN, TEXAS 78769
;;;
;;; Portions Copyright (C) 1987 Texas Instruments Incorporated.
;;; Portions Copyright (C) 1988, 1989 Franz Inc, Berkeley, Ca.
;;;
csr21's avatar
csr21 committed
12
13
14
15
;;; 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.
16
;;;
csr21's avatar
csr21 committed
17
18
;;; Texas Instruments Incorporated provides this software "as is"
;;; without express or implied warranty.
19
;;;
csr21's avatar
csr21 committed
20
21
;;; Franz Incorporated provides this software "as is" without express
;;; or implied warranty.
22
23
24
25
26
27

(defpackage :clx-system (:use :cl :asdf))
(in-package :clx-system)  

(pushnew :clx-ansi-common-lisp *features*)

28
(defclass clx-source-file (cl-source-file) ())
29
(defclass xrender-source-file (clx-source-file) ())
30

31
32
33
34
35
36
;;; CL-SOURCE-FILE, not CLX-SOURCE-FILE, so that we're not accused of
;;; cheating by rebinding *DERIVE-FUNCTION-TYPES* :-)
(defclass example-source-file (cl-source-file) ())

(defclass legacy-file (static-file) ())

37
38
(defsystem CLX
    :depends-on (sb-bsd-sockets)
Daniel Barlow's avatar
Daniel Barlow committed
39
    :version "0.7.1"
40
    :serial t
41
    :default-component-class clx-source-file
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
    :components
    ((:file "package")
     (:file "depdefs")
     (:file "clx")
     (:file "dependent")
     (:file "macros")
     (:file "bufmac")
     (:file "buffer")
     (:file "display")
     (:file "gcontext")
     (:file "input")
     (:file "requests")
     (:file "fonts")
     (:file "graphics")
     (:file "text")
     (:file "attributes")
     (:file "translate")
     (:file "keysyms")
     (:file "manager")
     (:file "image")
62
     (:file "resource")
63
64
65
66
67
     (:module extensions
	      :pathname #.(make-pathname :directory '(:relative))
	      :components
	      ((:file "shape")
	       (:file "xvidmode")
68
69
70
	       (:xrender-source-file "xrender")
               (:file "glx")
               (:file "gl" :depends-on ("glx"))))
71
72
73
74
75
76
77
78
     (:module demo
	      :default-component-class example-source-file
	      :components
	      ((:file "bezier")
	       ;; KLUDGE: this requires "bezier" for proper operation,
	       ;; but we don't declare that dependency here, because
	       ;; asdf doesn't load example files anyway.
	       (:file "beziertest")
csr21's avatar
csr21 committed
79
	       (:file "clclock")
csr21's avatar
csr21 committed
80
               (:file "clipboard")
81
	       (:file "clx-demos")
82
	       (:file "gl-test")
csr21's avatar
csr21 committed
83
	       ;; FIXME: compiling this generates 30-odd spurious code
84
	       ;; deletion notes.  Find out why, and either fix or
csr21's avatar
csr21 committed
85
86
	       ;; workaround the problem.
	       (:file "mandel")
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
	       (:file "menu")
	       (:file "zoid")))
     (:module test
	      :default-component-class example-source-file
	      :components
	      ((:file "image")
	       ;; KLUDGE: again, this depends on "zoid"
	       (:file "trapezoid")))
     (:static-file "NEWS")
     (:static-file "CHANGES")
     (:static-file "README")
     (:static-file "README-R5")
     (:legacy-file "exclMakefile")
     (:legacy-file "exclREADME")
     (:legacy-file "exclcmac" :pathname "exclcmac.lisp")
     (:legacy-file "excldepc" :pathname "excldep.c")
     (:legacy-file "excldep" :pathname "excldep.lisp")
csr21's avatar
csr21 committed
104
105
106
107
108
     (:legacy-file "sockcl" :pathname "sockcl.lisp")
     (:legacy-file "socket" :pathname "socket.c")
     (:legacy-file "defsystem" :pathname "defsystem.lisp")
     (:legacy-file "provide" :pathname "provide.lisp")
     (:legacy-file "cmudep" :pathname "cmudep.lisp")
109
110
111
     (:module manual
	      ;; TODO: teach asdf how to process texinfo files
	      :components ((:static-file "clx.texinfo")))
112
113
114
115
116
117
118
119
120
121
122
123
124
125
     (:module debug
	      :default-component-class legacy-file
	      :components
	      ((:file "debug" :pathname "debug.lisp")
	       (:file "describe" :pathname "describe.lisp")
	       (:file "event-test" :pathname "event-test.lisp")
	       (:file "keytrans" :pathname "keytrans.lisp")
	       (:file "trace" :pathname "trace.lisp")
	       (:file "util" :pathname "util.lisp")))))

(defmethod perform ((o load-op) (f example-source-file))
  ;; do nothing.  We want to compile them when CLX is compiled, but
  ;; not load them when CLX is loaded.
  t)
126

127
128
129
130
131
132
133
134
#+sbcl
(defmethod perform :around ((o compile-op) (f xrender-source-file))
  ;; RENDER would appear to be an inherently slow protocol; further,
  ;; it's not set in stone, and consequently we care less about speed
  ;; than we do about correctness.
  (handler-bind ((sb-ext:compiler-note #'muffle-warning))
    (call-next-method)))

135
136
#+sbcl
(defmethod perform :around ((o compile-op) (f clx-source-file))
137
138
139
  ;; our CLX library should compile without WARNINGs, and ideally
  ;; without STYLE-WARNINGs.  Since it currently does, let's enforce
  ;; it here so that we can catch regressions easily.
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
  (let ((on-warnings (operation-on-warnings o))
	(on-failure (operation-on-failure o)))
    (unwind-protect
	 (progn
	   (setf (operation-on-warnings o) :error
		 (operation-on-failure o) :error)
	   ;; a variety of accessors, such as AREF-CARD32, are not
	   ;; declared INLINE.  Without this (non-ANSI)
	   ;; static-type-inference behaviour, SBCL emits an extra 100
	   ;; optimization notes (roughly one fifth of all of the
	   ;; notes emitted).  Since the internals are unlikely to
	   ;; change much, and certainly the internals should stay in
	   ;; sync, enabling this extension is a win.  (Note that the
	   ;; use of this does not imply that applications using CLX
	   ;; calls that expand into calls to these accessors will be
	   ;; optimized in the same way).
	   (let ((sb-ext:*derive-function-types* t))
157
158
159
160
161
162
	     ;; deeply unportable stuff, this.  I will be shot.  We
	     ;; want to enable the dynamic-extent declarations in CLX.
	     (when (sb-c::policy-quality-name-p
		    'sb-c::stack-allocate-dynamic-extent)
	       ;; no way of setting it back short of yet more yukky stuff
	       (proclaim '(optimize (sb-c::stack-allocate-dynamic-extent 3))))
163
164
165
	     (call-next-method)))
      (setf (operation-on-warnings o) on-warnings
	    (operation-on-failure o) on-failure))))
166
167
168

#+sbcl
(defmethod perform :around (o (f clx-source-file))
169
170
171
172
173
174
  ;; SBCL signals an error if DEFCONSTANT is asked to redefine a
  ;; constant unEQLly.  For CLX's purposes, however, we are defining
  ;; structured constants (lists and arrays) not for EQLity, but for
  ;; the purposes of constant-folding operations such as (MEMBER FOO
  ;; +BAR+), so it is safe to abort the redefinition provided the
  ;; structured data is sufficiently equal.
175
176
177
  (handler-bind
      ((sb-ext:defconstant-uneql
	   (lambda (c)
178
179
	     ;; KLUDGE: this really means "don't warn me about
	     ;; efficiency of generic array access, please"
180
	     (declare (optimize (sb-ext:inhibit-warnings 3)))
181
182
183
184
	     (let ((old (sb-ext:defconstant-uneql-old-value c))
		   (new (sb-ext:defconstant-uneql-new-value c)))
	       (typecase old
		 (list (when (equal old new) (abort c)))
185
186
187
		 (string (when (and (typep new 'string)
				    (string= old new))
			   (abort c)))
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
		 (simple-vector
		  (when (and (typep new 'simple-vector)
			     (= (length old) (length new))
			     (every #'eql old new))
		    (abort c)))
		 (array
		  (when (and (typep new 'array)
			     (equal (array-dimensions old)
				    (array-dimensions new))
			     (equal (array-element-type old)
				    (array-element-type new))
			     (dotimes (i (array-total-size old) t)
			       (unless (eql (row-major-aref old i)
					    (row-major-aref new i))
				 (return nil))))
		    (abort c))))))))
    (call-next-method)))