Newer
Older
;;; -*- Lisp -*- mode
;;; 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.
;;;
;;; 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.
;;; Texas Instruments Incorporated provides this software "as is"
;;; without express or implied warranty.
;;; Franz Incorporated provides this software "as is" without express
;;; or implied warranty.
(defpackage :clx-system (:use :cl :asdf))
(in-package :clx-system)
(pushnew :clx-ansi-common-lisp *features*)
(defclass clx-source-file (cl-source-file) ())
(defclass xrender-source-file (clx-source-file) ())
;;; 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) ())
:default-component-class clx-source-file
:components
((:file "package")
(:file "depdefs")
(:file "clx")
#-(or openmcl) (:file "dependent")
#+openmcl (:file "dep-openmcl")
(: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")
(:file "resource")
(:module extensions
:pathname #.(make-pathname :directory '(:relative))
:components
((:file "shape")
(:file "xvidmode")
(:xrender-source-file "xrender")
(:file "glx")
(:file "gl" :depends-on ("glx"))))
(: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")
(:file "clx-demos")
(:file "gl-test")
;; FIXME: compiling this generates 30-odd spurious code
;; deletion notes. Find out why, and either fix or
(: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")
(: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")
(:module manual
;; TODO: teach asdf how to process texinfo files
:components ((:static-file "clx.texinfo")))
(: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)
#+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)))
#+sbcl
(defmethod perform :around ((o compile-op) (f clx-source-file))
;; 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.
(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))
;; 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))))
(call-next-method)))
(setf (operation-on-warnings o) on-warnings
(operation-on-failure o) on-failure))))
#+sbcl
(defmethod perform :around (o (f clx-source-file))
;; 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.
(handler-bind
((sb-ext:defconstant-uneql
(lambda (c)
;; KLUDGE: this really means "don't warn me about
;; efficiency of generic array access, please"
(declare (optimize (sb-ext:inhibit-warnings 3)))
(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)))
(string (when (and (typep new 'string)
(string= old new))
(abort c)))
(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)))