defsystem.cl

;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: T;  -*-

;;;
;;;			 TEXAS INSTRUMENTS INCORPORATED
;;;				  P.O. BOX 2909
;;;			       AUSTIN, TEXAS 78769
;;;
;;; Portions Copyright (C) 1987 Texas Instruments Incorporated.
;;; copyright (c) 1988-1989 Franz Inc, Berkeley, CA - All rights reserved.
;; copyright (c) 1989-2004 Franz Inc, Oakland, CA - All rights reserved.
;;;
;;; 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.

;;; #+ features used in this file
;;;   clx-ansi-common-lisp
;;;   lispm
;;;   genera
;;;   minima
;;;   lucid
;;;   lcl3.0
;;;   apollo
;;;   kcl
;;;   ibcl
;;;   excl

#+(or Genera Minima)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (common-lisp:pushnew :clx-ansi-common-lisp common-lisp:*features*))

#+(and Genera clx-ansi-common-lisp)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf *readtable* si:*ansi-common-lisp-readtable*))

#-clx-ansi-common-lisp 
(lisp:in-package :user)

#+clx-ansi-common-lisp
(common-lisp:in-package :common-lisp-user)


;;;; Lisp Machines

#+(and lispm (not genera))
(global:defsystem CLX
  (:pathname-default "clx:clx;")
  (:patchable "clx:patch;" clx-ti)
  (:initial-status :experimental)

  (:module package "package")
  (:module depdefs "depdefs")
  (:module clx "clx0")
  (:module dependent "dependent")
  (:module macros "macros")
  (:module bufmac "bufmac")
  (:module buffer "buffer")
  (:module display "display")
  (:module gcontext "gcontext")
  (:module requests "requests")
  (:module input "input")
  (:module fonts "fonts")
  (:module graphics "graphics")
  (:module text "text")
  (:module attributes "attributes")
  (:module translate "translate")
  (:module keysyms "keysyms")
  (:module manager "manager")
  (:module image "image")
  (:module resource "resource")
  (:module doc "doc")

  (:compile-load package)
  (:compile-load depdefs
   (:fasload package))
  (:compile-load clx
   (:fasload package depdefs))
  (:compile-load dependent
   (:fasload package depdefs clx))
  ;; Macros only needed for compilation
  (:skip :compile-load macros
   (:fasload package depdefs clx dependent))
  ;; Bufmac only needed for compilation
  (:skip :compile-load bufmac
   (:fasload package depdefs clx dependent macros))
  (:compile-load buffer
   (:fasload package depdefs clx dependent macros bufmac))
  (:compile-load display
   (:fasload package depdefs clx dependent macros bufmac buffer))
  (:compile-load gcontext
   (:fasload package depdefs clx dependent macros bufmac buffer display))
  (:compile-load input
   (:fasload package depdefs clx dependent macros bufmac buffer display))
  (:compile-load requests
   (:fasload package depdefs clx dependent macros bufmac buffer display input))
  (:compile-load fonts
   (:fasload package depdefs clx dependent macros bufmac buffer display))
  (:compile-load graphics
   (:fasload package depdefs clx dependent macros fonts bufmac buffer display
	     fonts))
  (:compile-load text
   (:fasload package depdefs clx dependent macros fonts bufmac buffer display
	     gcontext fonts))
  (:compile-load-init attributes
   (dependent)
   (:fasload package depdefs clx dependent macros bufmac buffer display))
  (:compile-load translate
   (:fasload package depdefs clx dependent macros bufmac buffer display))
  (:compile-load keysyms
   (:fasload package depdefs clx dependent macros bufmac buffer display
	     translate))
  (:compile-load manager
   (:fasload package depdefs clx dependent macros bufmac buffer display))
  (:compile-load image
   (:fasload package depdefs clx dependent macros bufmac buffer display))
  (:compile-load resource
   (:fasload package depdefs clx dependent macros bufmac buffer display))
  (:auxiliary doc)
  )


;;; Symbolics Lisp Machines
#+Genera
(scl:defsystem CLX
    (:default-pathname "SYS:X11;CLX;"
     :pretty-name "CLX"
     :maintaining-sites (:scrc)
     :distribute-sources t
     :distribute-binaries t
     :source-category :basic)
  (:module doc ("doc")
	   (:type :lisp-example))
  (:serial
    "package" "depdefs" "generalock" "clx0" "dependent" "macros" "bufmac"
    "buffer" "display" "gcontext" "input" "requests" "fonts" "graphics"
    "text" "attributes" "translate" "keysyms" "manager" "image" "resource"))


;;; Franz

;;
;; The following is a suggestion.  If you comment out this form be
;; prepared for possible deadlock, since no interrupts will be recognized
;; while reading from the X socket if the scheduler is not running.
;;
;; [bug18431]:
(setq compiler::generate-interrupt-checks-switch
  (compile nil
	   '(lambda (safety size speed &optional debug compilation-speed)
	     (declare (ignore size debug compilation-speed))
	     (or (< speed 3) (> safety 0)))))


;;; Allegro

#+(and allegro (not (version>= 4 1 devel 39)))
(excl:defsystem :clx 
  ()
  |package|
  (|excldep|
    :load-before-compile (|package|)
    :recompile-on (|package|))
  (|depdefs|
    :load-before-compile (|package| |excldep|)
    :recompile-on (|excldep|))
  (|clx|
    :load-before-compile (|package| |excldep| |depdefs|)
    :recompile-on (|package| |excldep| |depdefs|))
  (|dependent|
    :load-before-compile (|package| |excldep| |depdefs| |clx|)
    :recompile-on (|clx|))
  (|exclcmac|
    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|)
    :recompile-on (|dependent|))
  (|macros|
    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
			  |exclcmac|)
    :recompile-on (|exclcmac|))
  (|bufmac|
    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
			  |exclcmac| |macros|)
    :recompile-on (|macros|))
  (|buffer|
    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
			  |exclcmac| |macros| |bufmac|)
    :recompile-on (|bufmac|))
  (|display|
    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
			  |exclcmac| |macros| |bufmac| |buffer|)
    :recompile-on (|buffer|))
  (|gcontext|
    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
			  |exclcmac| |macros| |bufmac| |buffer| |display|)
    :recompile-on (|display|))
  (|input|
    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
			  |exclcmac| |macros| |bufmac| |buffer| |display|)
    :recompile-on (|display|))
  (|requests|
    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
			  |exclcmac| |macros| |bufmac| |buffer| |display|
			  |input|)
    :recompile-on (|display|))
  (|fonts|
    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
			  |exclcmac| |macros| |bufmac| |buffer| |display|)
    :recompile-on (|display|))
  (|graphics|
    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
			  |exclcmac| |macros| |bufmac| |buffer| |display|
			  |fonts|)
    :recompile-on (|fonts|))
  (|text|
    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
			  |exclcmac| |macros| |bufmac| |buffer| |display|
			  |gcontext| |fonts|)
    :recompile-on (|gcontext| |fonts|)
    :load-after (|translate|))
  ;; The above line gets around a compiler macro expansion bug.
  
  (|attributes|
    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
			  |exclcmac| |macros| |bufmac| |buffer| |display|)
    :recompile-on (|display|))
  (|translate|
    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
			  |exclcmac| |macros| |bufmac| |buffer| |display|
			  |text|)
    :recompile-on (|display|))
  (|keysyms|
    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
			  |exclcmac| |macros| |bufmac| |buffer| |display|
			  |translate|)
    :recompile-on (|translate|))
  (|manager|
    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
			  |exclcmac| |macros| |bufmac| |buffer| |display|)
    :recompile-on (|display|))
  (|image|
    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
			  |exclcmac| |macros| |bufmac| |buffer| |display|)
    :recompile-on (|display|))
  
  ;; Don't know if l-b-c list is correct.  XX
  (|resource|
    :load-before-compile (|package| |excldep| |depdefs| |clx| |dependent|
			  |exclcmac| |macros| |bufmac| |buffer| |display|)
    :recompile-on (|display|))
  )

#+(and allegro (not (version>= 4 1 devel 39)))
(excl:defsystem :clx-debug
    (:default-pathname "debug/"
     :needed-systems (:clx)
     :load-before-compile (:clx))
  |describe| |keytrans| |trace| |util|)

#+(and allegro (version>= 4 1 devel 39))
(defsystem :clx ()
  (:parallel
   "package"
   ("excldep"
    (:load-before-compile "package")
    (:recompile-on "package"))
   ("depdefs"
    (:load-before-compile "package" "excldep")
    (:recompile-on "excldep"))
   ("clx0"
    (:load-before-compile "package" "excldep" "depdefs")
    (:recompile-on "package" "excldep" "depdefs"))
   ("dependent"
    (:load-before-compile "package" "excldep" "depdefs" "clx0")
    (:recompile-on "clx0"))
   ("exclcmac"
    (:load-before-compile "package" "excldep" "depdefs" "clx0" "dependent")
    (:recompile-on "dependent"))
   ("macros"
    (:load-before-compile "package" "excldep" "depdefs" "clx0" "dependent"
				    "exclcmac")
    (:recompile-on "exclcmac"))
   ("bufmac"
    (:load-before-compile "package" "excldep" "depdefs" "clx0" "dependent"
				    "exclcmac" "macros")
    (:recompile-on "macros"))
   ("buffer"
    (:load-before-compile "package" "excldep" "depdefs" "clx0" "dependent"
				    "exclcmac" "macros" "bufmac")
    (:recompile-on "bufmac"))
   ("display"
    (:load-before-compile "package" "excldep" "depdefs" "clx0" "dependent"
				    "exclcmac" "macros" "bufmac" "buffer")
    (:recompile-on "buffer"))
   ("gcontext"
    (:load-before-compile "package" "excldep" "depdefs" "clx0" "dependent"
				    "exclcmac" "macros" "bufmac" "buffer" "display")
    (:recompile-on "display"))
   ("input"
    (:load-before-compile "package" "excldep" "depdefs" "clx0" "dependent"
				    "exclcmac" "macros" "bufmac" "buffer" "display")
    (:recompile-on "display"))
   ("requests"
    (:load-before-compile "package" "excldep" "depdefs" "clx0" "dependent"
				    "exclcmac" "macros" "bufmac" "buffer" "display"
				    "input")
    (:recompile-on "display"))
   ("fonts"
    (:load-before-compile "package" "excldep" "depdefs" "clx0" "dependent"
				    "exclcmac" "macros" "bufmac" "buffer" "display")
    (:recompile-on "display"))
   ("graphics"
    (:load-before-compile "package" "excldep" "depdefs" "clx0" "dependent"
				    "exclcmac" "macros" "bufmac" "buffer" "display"
				    "fonts")
    (:recompile-on "fonts"))
   ("text"
    (:load-before-compile "package" "excldep" "depdefs" "clx0" "dependent"
				    "exclcmac" "macros" "bufmac" "buffer" "display"
				    "gcontext" "fonts")
    (:recompile-on "gcontext" "fonts")
    (:load-after "translate"))
   ;; The above line gets around a compiler macro expansion bug.
  
   ("attributes"
    (:load-before-compile "package" "excldep" "depdefs" "clx0" "dependent"
				    "exclcmac" "macros" "bufmac" "buffer" "display")
    (:recompile-on "display"))
   ("translate"
    (:load-before-compile "package" "excldep" "depdefs" "clx0" "dependent"
				    "exclcmac" "macros" "bufmac" "buffer" "display"
				    "text")
    (:recompile-on "display"))
   ("keysyms"
    (:load-before-compile "package" "excldep" "depdefs" "clx0" "dependent"
				    "exclcmac" "macros" "bufmac" "buffer" "display"
				    "translate")
    (:recompile-on "translate"))
   ("manager"
    (:load-before-compile "package" "excldep" "depdefs" "clx0" "dependent"
				    "exclcmac" "macros" "bufmac" "buffer" "display")
    (:recompile-on "display"))
   ("image"
    (:load-before-compile "package" "excldep" "depdefs" "clx0" "dependent"
				    "exclcmac" "macros" "bufmac" "buffer" "display")
    (:recompile-on "display"))
  
   ;; Don't know if l-b-c list is correct.  XX
   ("resource"
    (:load-before-compile "package" "excldep" "depdefs" "clx0" "dependent"
				    "exclcmac" "macros" "bufmac" "buffer" "display")
    (:recompile-on "display"))))

#+(and allegro (version>= 4 1 devel 39))
(defsystem :clx-debug
    (:default-pathname "debug/")
  (:serial :clx
	   (:parallel "describe" "keytrans" "trace" "util")))


;;;; Compile CLX

;;; COMPILE-CLX compiles the lisp source files and loads the binaries.
;;; It goes to some trouble to let the source files be in one directory
;;; and the binary files in another.  Thus the same set of sources can
;;; be used for different machines and/or lisp systems.  It also allows
;;; you to supply explicit extensions, so source files do not have to
;;; be renamed to fit into the naming conventions of an implementation.

;;; For example,
;;;     (compile-clx "*.lisp" "machine/")
;;; compiles source files from the connected directory and puts them
;;; into the "machine" subdirectory.  You can then load CLX out of the
;;; machine directory.

;;; The code has no knowledge of the source file types (eg, ".l" or
;;; ".lisp") or of the binary file types (eg, ".b" or ".sbin").  Calling
;;; compile-file and load with a file type of NIL usually sorts things
;;; out correctly, but you may have to explicitly give the source and
;;; binary file types.

;;; An attempt at compiling the C language sources is also made,
;;; but you may have to set different compiler switches
;;; should be.  If it doesn't do the right thing, then do
;;;     (compile-clx "" "" :compile-c NIL)
;;; to prevent the compilation.

;;; compilation notes
;;;   lucid2.0/hp9000s300
;;;     must uudecode the file make-sequence-patch.uu

#+(or lucid kcl ibcl)
(defun clx-foreign-files (binary-path)

  #+(and lucid (not lcl3.0) (or mc68000 mc68020))
  (load (merge-pathnames "make-sequence-patch" binary-path))

  #+(and lucid apollo)
  (lucid::load-foreign-file
    (namestring (merge-pathnames "socket" binary-path))
    :preserve-pathname t)

  #+(and lucid (not apollo))
  (lucid::load-foreign-files
    (list (namestring (merge-pathnames "socket.o" binary-path)))
    '("-lc"))

  #+(or kcl ibcl)
  (progn
    (let ((pathname (merge-pathnames "sockcl.o" binary-path))
	  (options
	    (concatenate
	      'string
	      (namestring (merge-pathnames "socket.o" binary-path))
	      " -lc")))
      (format t "~&Faslinking ~A with ~A.~%" pathname options)
      (si:faslink (namestring pathname) options)
      (format t "~&Finished faslinking ~A.~%" pathname)))
  )

#-(or lispm allegro)
(defun compile-clx (&optional
		    (source-pathname-defaults "")
		    (binary-pathname-defaults "")
		    &key
		    (compile-c t))

  ;; The pathname-defaults above might only be strings, so coerce them
  ;; to pathnames.  Build a default binary path with every component
  ;; of the source except the file type.  This should prevent
  ;; (compile-clx "*.lisp") from destroying source files.
  (let* ((source-path (pathname source-pathname-defaults))
	 (path        (make-pathname
			:host      (pathname-host      source-path)
			:device    (pathname-device    source-path)
			:directory (pathname-directory source-path)
			:name      (pathname-name      source-path)
			:type      nil
			:version   (pathname-version   source-path)))
	 (binary-path (merge-pathnames binary-pathname-defaults
				       path))
	 #+clx-ansi-common-lisp (*compile-verbose* t)
	 (*load-verbose* t))
				       
    ;; Make sure source-path and binary-path file types are distinct so
    ;; we don't accidently overwrite the source files.  NIL should be an
    ;; ok type, but anything else spells trouble.
    (if (and (equal (pathname-type source-path)
		    (pathname-type binary-path))
	     (not (null (pathname-type binary-path))))
	(error "Source and binary pathname defaults have same type ~s ~s"
	       source-path binary-path))

    (format t "~&;;; Default paths: ~s ~s~%" source-path binary-path)

    ;; In lucid make sure we're using the compiler in production mode.
    #+lcl3.0
    (progn
      (unless (member :pqc *features*)
	(cerror
	  "Go ahead anyway."
	  "Lucid's production mode compiler must be loaded to compile CLX."))
      (proclaim '(optimize (speed 3)
			   (safety 1)
			   (space 0)
			   (compilation-speed 0))))

    (labels ((compile-lisp (filename)
	       (let ((source (merge-pathnames filename source-path))
		     (binary (merge-pathnames filename binary-path)))
		 ;; If the source and binary pathnames are the same,
		 ;; then don't supply an output file just to be sure
		 ;; compile-file defaults correctly.
		 #+(or kcl ibcl) (load source)
		 (if (equal source binary)
		     (compile-file source)
		   (compile-file source :output-file binary))
		 binary))
	     (compile-and-load (filename)
	       (load (compile-lisp filename)))
	     #+(or lucid kcl ibcl)
	     (compile-c (filename)
	       (let* ((c-filename (concatenate 'string filename ".c"))
		      (o-filename (concatenate 'string filename ".o"))
		      (src (merge-pathnames c-filename source-path))
		      (obj  (merge-pathnames o-filename binary-path))
		      (args (list "-c" (namestring src)
				  "-o" (namestring obj)
				  #+mips "-G 0"
				  #+(or hp sysv) "-DSYSV"
				  #+(and mips (not dec)) "-I/usr/include/bsd"
				  #-(and mips (not dec)) "-DUNIXCONN"
				  #+(and lucid pa) "-DHPUX -DHPUX7.0"
				  )))
		 (format t ";;; cc~{ ~A~}~%" args)
		 (unless
		   (zerop 
		     #+lucid
		     (multiple-value-bind (iostream estream exitstatus pid)
			 ;; in 2.0, run-program is exported from system:
			 ;; in 3.0, run-program is exported from lcl:
			 ;; system inheirits lcl
			 (system::run-program "cc" :arguments args)
		       (declare (ignore iostream estream pid))
		       exitstatus)
		     #+(or kcl ibcl)
		     (system (format nil "cc~{ ~A~}" args)))
		   (error "Compile of ~A failed." src)))))

      ;; Now compile and load all the files.
      ;; Defer compiler warnings until everything's compiled, if possible.
      (#+clx-ansi-common-lisp with-compilation-unit
       #+lcl3.0 lucid::with-deferred-warnings
       #-(or lcl3.0 clx-ansi-common-lisp) progn
       ()
       
       (compile-and-load "package")
       #+(or lucid kcl ibcl) (when compile-c (compile-c "socket"))
       #+(or kcl ibcl) (compile-lisp "sockcl")
       #+(or lucid kcl ibcl) (clx-foreign-files binary-path)
       #+excl (compile-and-load "excldep")
       (compile-and-load "depdefs")
       (compile-and-load "clx0")
       (compile-and-load "dependent")
       #+excl (compile-and-load "exclcmac")	; these are just macros
       (compile-and-load "macros")		; these are just macros
       (compile-and-load "bufmac")		; these are just macros
       (compile-and-load "buffer")
       (compile-and-load "display")
       (compile-and-load "gcontext")
       (compile-and-load "input")
       (compile-and-load "requests")
       (compile-and-load "fonts")
       (compile-and-load "graphics")
       (compile-and-load "text")
       (compile-and-load "attributes")
       (compile-and-load "translate")
       (compile-and-load "keysyms")
       (compile-and-load "manager")
       (compile-and-load "image")
       (compile-and-load "resource")
       ))))


;;;; Load CLX

;;; This procedure loads the binaries for CLX.  All of the binaries
;;; should be in the same directory, so setting the default pathname
;;; should point load to the right place.

;;; You should have a module definition somewhere so the require/provide
;;; mechanism can avoid reloading CLX.  In an ideal world, somebody would
;;; just put
;;;		(REQUIRE 'CLX)
;;; in their file (some implementations don't have a central registry for
;;; modules, so a pathname needs to be supplied).

;;; The REQUIRE should find a file that does
;;;		(IN-PACKAGE 'XLIB :USE '(LISP))
;;;		(PROVIDE 'CLX)
;;;		(LOAD <clx-defsystem-file>)
;;;		(LOAD-CLX <binary-specific-clx-directory>)

#-(or lispm allegro)
(defun load-clx (&optional (binary-pathname-defaults "")
		 &key (macrosp nil))

  (let* ((source-path (pathname ""))
	 (path        (make-pathname
			:host      (pathname-host      source-path)
			:device    (pathname-device    source-path)
			:directory (pathname-directory source-path)
			:name      (pathname-name      source-path)
			:type      nil
			:version   (pathname-version   source-path)))
	 (binary-path (merge-pathnames binary-pathname-defaults
				       path))
	 (*load-verbose* t))

    (flet ((load-binary (filename)
	     (let ((binary (merge-pathnames filename binary-path)))
	       (load binary))))

      (load-binary "package")
      #+(or lucid kcl ibcl) (clx-foreign-files binary-path)
      #+excl (load-binary "excldep")
      (load-binary "depdefs")
      (load-binary "clx0")
      (load-binary "dependent")
      (when macrosp
	#+excl (load-binary "exclcmac")
	(load-binary "macros")
	(load-binary "bufmac"))
      (load-binary "buffer")
      (load-binary "display")
      (load-binary "gcontext")
      (load-binary "input")
      (load-binary "requests")
      (load-binary "fonts")
      (load-binary "graphics")
      (load-binary "text")
      (load-binary "attributes")
      (load-binary "translate")
      (load-binary "keysyms")
      (load-binary "manager")
      (load-binary "image")
      (load-binary "resource")
      )))