- cmucl-cvs - mailman3.common-lisp.net

[Git][cmucl/cmucl] Pushed new tag snapshot-2019-06
by Raymond Toy 28 May '19

28 May '19

Raymond Toy pushed new tag snapshot-2019-06 at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/tree/snapshot-2019-06 You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Strikethru #73 since it's done.
by Raymond Toy 28 May '19

28 May '19

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 1ca3f155 by Raymond Toy at 2019-05-28T16:02:28Z Strikethru #73 since it's done. [skip ci] - - - - - 1 changed file: - src/general-info/release-21d.md Changes: ===================================== src/general-info/release-21d.md ===================================== @@ -44,7 +44,7 @@ public domain. * ~~#62~~ Segfault when compiling `ARRAY-DISPLACEMENT` on a string constant * ~~#69~~ GC assertions compiled in and allow user to enable them. * ~~#71~~ More info for `MACHINE-TYPE` and `MACHINE-VERSION` for x86 - * #73 Update clx from upstream clx + * ~~#73~~ Update clx from upstream clx * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/1ca3f1554de6a91873132f018… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/1ca3f1554de6a91873132f018… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Update notes
by Raymond Toy 28 May '19

28 May '19

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 4dbd847a by Raymond Toy at 2019-05-28T15:57:13Z Update notes * Update to ASDF 3.3.3 * Note that gcc -O1 can build cmucl now for gcc 8.1.1 and later. * Added x86_linux_clang to build cmucl with clang on linux - - - - - 1 changed file: - src/general-info/release-21d.md Changes: ===================================== src/general-info/release-21d.md ===================================== @@ -17,8 +17,10 @@ public domain. ## New in this release: * Known issues: + * Building with gcc8 or later doesn't work with the default -O option. Use -O1 instead. This shouldn't really impact overall speed much. + * Added simple support to compile with clang instead, which works. (Use x86_linux_clang). * Feature enhancements - * Update to ASDF 3.3.2 + * Update to ASDF 3.3.3 * Changes * x86 and sparc have replaced the MT19937 RNG with xoroshiro128+ RNG. * The required state for this generator is just 4 32-bit words instead of the 600+ for MT19937. @@ -42,6 +44,7 @@ public domain. * ~~#62~~ Segfault when compiling `ARRAY-DISPLACEMENT` on a string constant * ~~#69~~ GC assertions compiled in and allow user to enable them. * ~~#71~~ More info for `MACHINE-TYPE` and `MACHINE-VERSION` for x86 + * #73 Update clx from upstream clx * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/4dbd847afe39a4b84ba2ba0ae… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/4dbd847afe39a4b84ba2ba0ae… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Update to ASDF 3.3.3
by Raymond Toy 17 Apr '19

17 Apr '19

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 76fd7aef by Raymond Toy at 2019-04-17T19:20:16Z Update to ASDF 3.3.3 - - - - - 4 changed files: - src/contrib/asdf/asdf.lisp - src/contrib/asdf/doc/asdf.html - src/contrib/asdf/doc/asdf.info - src/contrib/asdf/doc/asdf.pdf Changes: ===================================== src/contrib/asdf/asdf.lisp ===================================== @@ -1,5 +1,5 @@ ;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*- -;;; This is ASDF 3.3.2: Another System Definition Facility. +;;; This is ASDF 3.3.3: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel(a)common-lisp.net>. @@ -19,7 +19,7 @@ ;;; http://www.opensource.org/licenses/mit-license.html on or about ;;; Monday; July 13, 2009) ;;; -;;; Copyright (c) 2001-2016 Daniel Barlow and contributors +;;; Copyright (c) 2001-2019 Daniel Barlow and contributors ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the @@ -45,6 +45,17 @@ ;;; The problem with writing a defsystem replacement is bootstrapping: ;;; we can't use defsystem to compile it. Hence, all in one file. +#+genera +(eval-when (:compile-toplevel :load-toplevel :execute) + (multiple-value-bind (system-major system-minor) + (sct:get-system-version) + (multiple-value-bind (is-major is-minor) + (sct:get-system-version "Intel-Support") + (unless (or (> system-major 452) + (and is-major + (or (> is-major 3) + (and (= is-major 3) (> is-minor 86))))) + (error "ASDF requires either System 453 or later or Intel Support 3.87 or later"))))) ;;;; --------------------------------------------------------------------------- ;;;; Handle ASDF package upgrade, including implementation-dependent magic. ;; @@ -818,10 +829,10 @@ UNINTERN -- Remove symbols here from PACKAGE." ;;;; Early meta-level tweaks -#+(or allegro clasp clisp clozure cmucl ecl mezzano mkcl sbcl) +#+(or allegro clasp clisp clozure cmucl ecl lispworks mezzano mkcl sbcl) (eval-when (:load-toplevel :compile-toplevel :execute) (when (and #+allegro (member :ics *features*) - #+(or clasp clisp cmucl ecl mkcl) (member :unicode *features*) + #+(or clasp clisp cmucl ecl lispworks mkcl) (member :unicode *features*) #+clozure (member :openmcl-unicode-strings *features*) #+sbcl (member :sb-unicode *features*)) ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode @@ -1043,7 +1054,9 @@ Return a string made of the parts not omitted or emitted by FROB." #:simple-style-warning #:style-warn ;; simple style warnings #:match-condition-p #:match-any-condition-p ;; conditions #:call-with-muffled-conditions #:with-muffled-conditions - #:not-implemented-error #:parameter-error)) + #:not-implemented-error #:parameter-error + #:symbol-test-to-feature-expression + #:boolean-to-feature-expression)) (in-package :uiop/utility) ;;;; Defining functions in a way compatible with hot-upgrade: @@ -1089,17 +1102,17 @@ to supersede any previous definition." ;;; Magic debugging help. See contrib/debug.lisp (with-upgradability () (defvar *uiop-debug-utility* - '(or (ignore-errors - (probe-file (symbol-call :asdf :system-relative-pathname :uiop "contrib/debug.lisp"))) - (probe-file (symbol-call :uiop/pathname :subpathname - (user-homedir-pathname) "common-lisp/asdf/uiop/contrib/debug.lisp"))) + '(symbol-call :uiop :subpathname (symbol-call :uiop :uiop-directory) "contrib/debug.lisp") "form that evaluates to the pathname to your favorite debugging utilities") (defmacro uiop-debug (&rest keys) + "Load the UIOP debug utility at compile-time as well as runtime" `(eval-when (:compile-toplevel :load-toplevel :execute) (load-uiop-debug-utility ,@keys))) (defun load-uiop-debug-utility (&key package utility-file) + "Load the UIOP debug utility in given PACKAGE (default *PACKAGE*). +Beware: The utility is located by EVAL'uating the UTILITY-FILE form (default *UIOP-DEBUG-UTILITY*)." (let* ((*package* (if package (find-package package) *package*)) (keyword (read-from-string (format nil ":DBG-~:@(~A~)" (package-name *package*))))) @@ -1658,6 +1671,18 @@ message, that takes the functionality as its first argument (that can be skipped :format-control format-control :format-arguments format-arguments))) +(with-upgradability () + (defun boolean-to-feature-expression (value) + "Converts a boolean VALUE to a form suitable for testing with #+." + (if value + '(:and) + '(:or))) + + (defun symbol-test-to-feature-expression (name package) + "Check if a symbol with a given NAME exists in PACKAGE and returns a +form suitable for testing with #+." + (boolean-to-feature-expression + (find-symbol* name package nil)))) (uiop/package:define-package :uiop/version (:recycle :uiop/version :uiop/utility :asdf) (:use :uiop/common-lisp :uiop/package :uiop/utility) @@ -1672,7 +1697,7 @@ message, that takes the functionality as its first argument (that can be skipped (in-package :uiop/version) (with-upgradability () - (defparameter *uiop-version* "3.3.2") + (defparameter *uiop-version* "3.3.3") (defun unparse-version (version-list) "From a parsed version (a list of natural numbers), compute the version string" @@ -2335,8 +2360,8 @@ by the underlying implementation's MAKE-PATHNAME and other primitives" ;; See CLHS make-pathname and 19.2.2.2.3. ;; This will be :unspecific if supported, or NIL if not. (defparameter *unspecific-pathname-type* - #+(or abcl allegro clozure cmucl genera lispworks sbcl scl) :unspecific - #+(or clasp clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl mezzano) nil + #+(or abcl allegro clozure cmucl lispworks sbcl scl) :unspecific + #+(or genera clasp clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl mezzano) nil "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME") (defun make-pathname* (&rest keys &key directory host device name type version defaults @@ -2574,7 +2599,14 @@ actually-existing directory." (make-pathname :directory (append (or (normalize-pathname-directory-component (pathname-directory pathspec)) (list :relative)) - (list (file-namestring pathspec))) + (list #-genera (file-namestring pathspec) + ;; On Genera's native filesystem (LMFS), + ;; directories have a type and version + ;; which must be ignored when converting + ;; to a directory pathname + #+genera (if (typep pathspec 'fs:lmfs-pathname) + (pathname-name pathspec) + (file-namestring pathspec)))) :name nil :type nil :version nil :defaults pathspec) (error (c) (call-function on-error (compatfmt "~@<error while trying to create a directory pathname for ~S: ~A~@:>") pathspec c))))))) @@ -3056,7 +3088,13 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" (or (ignore-errors (truename p)) ;; this is here because trying to find the truename of a directory pathname WITHOUT supplying ;; a trailing directory separator, causes an error on some lisps. - #+(or clisp gcl) (if-let (d (ensure-directory-pathname p nil)) (ignore-errors (truename d))))))) + #+(or clisp gcl) (if-let (d (ensure-directory-pathname p nil)) (ignore-errors (truename d))) + ;; On Genera, truename of a directory pathname will probably fail as Genera + ;; will merge in a filename/type/version from *default-pathname-defaults* and + ;; will try to get the truename of a file that probably doesn't exist. + #+genera (when (directory-pathname-p p) + (let ((d (scl:send p :directory-pathname-as-file))) + (ensure-directory-pathname (ignore-errors (truename d)) nil))))))) (defun safe-file-write-date (pathname) "Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error." @@ -4832,7 +4870,6 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." (shell-boolean-exit (restore-image)))))))) (when forms `(progn ,@forms)))))) - #+(or clasp ecl mkcl) (check-type kind (member :dll :shared-library :lib :static-library :fasl :fasb :program)) (apply #+clasp 'cmp:builder #+clasp kind @@ -5209,12 +5246,28 @@ Simple means made of symbols, numbers, characters, simple-strings, pathnames, co (sb-c::undefined-warning-kind warning) (sb-c::undefined-warning-name warning) (sb-c::undefined-warning-count warning) + ;; the COMPILER-ERROR-CONTEXT struct has changed in SBCL, which means how we + ;; handle deferred warnings must change... TODO: when enough time has + ;; gone by, just assume all versions of SBCL are adequately + ;; up-to-date, and cut this material.[2018/05/30:rpg] (mapcar #'(lambda (frob) ;; the lexenv slot can be ignored for reporting purposes - `(:enclosing-source ,(sb-c::compiler-error-context-enclosing-source frob) - :source ,(sb-c::compiler-error-context-source frob) - :original-source ,(sb-c::compiler-error-context-original-source frob) + `( + #- #.(uiop/utility:symbol-test-to-feature-expression '#:compiler-error-context-%source '#:sb-c) + ,@`(:enclosing-source + ,(sb-c::compiler-error-context-enclosing-source frob) + :source + ,(sb-c::compiler-error-context-source frob) + :original-source + ,(sb-c::compiler-error-context-original-source frob)) + #+ #.(uiop/utility:symbol-test-to-feature-expression '#:compiler-error-context-%source '#:sb-c) + ,@ `(:%enclosing-source + ,(sb-c::compiler-error-context-enclosing-source frob) + :%source + ,(sb-c::compiler-error-context-source frob) + :original-form + ,(sb-c::compiler-error-context-original-form frob)) :context ,(sb-c::compiler-error-context-context frob) :file-name ,(sb-c::compiler-error-context-file-name frob) ; a pathname :file-position ,(sb-c::compiler-error-context-file-position frob) ; an integer @@ -5565,9 +5618,10 @@ it will filter them appropriately." (with-saved-deferred-warnings (warnings-file :source-namestring (namestring input-file)) (with-muffled-compiler-conditions () (or #-(or clasp ecl mkcl) - (apply 'compile-file input-file :output-file tmp-file - #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords) - #-sbcl keywords) + (let (#+genera (si:*common-lisp-syntax-is-ansi-common-lisp* t)) + (apply 'compile-file input-file :output-file tmp-file + #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords) + #-sbcl keywords)) #+ecl (apply 'compile-file input-file :output-file (if object-file (list* object-file :system-p t keywords) @@ -5619,19 +5673,20 @@ it will filter them appropriately." (defun load* (x &rest keys &key &allow-other-keys) "Portable wrapper around LOAD that properly handles loading from a stream." (with-muffled-loader-conditions () - (etypecase x - ((or pathname string #-(or allegro clozure genera) stream #+clozure file-stream) - (apply 'load x keys)) - ;; Genera can't load from a string-input-stream - ;; ClozureCL 1.6 can only load from file input stream - ;; Allegro 5, I don't remember but it must have been broken when I tested. - #+(or allegro clozure genera) - (stream ;; make do this way - (let ((*package* *package*) - (*readtable* *readtable*) - (*load-pathname* nil) - (*load-truename* nil)) - (eval-input x)))))) + (let (#+genera (si:*common-lisp-syntax-is-ansi-common-lisp* t)) + (etypecase x + ((or pathname string #-(or allegro clozure genera) stream #+clozure file-stream) + (apply 'load x keys)) + ;; Genera can't load from a string-input-stream + ;; ClozureCL 1.6 can only load from file input stream + ;; Allegro 5, I don't remember but it must have been broken when I tested. + #+(or allegro clozure genera) + (stream ;; make do this way + (let ((*package* *package*) + (*readtable* *readtable*) + (*load-pathname* nil) + (*load-truename* nil)) + (eval-input x))))))) (defun load-from-string (string) "Portably read and evaluate forms from a STRING." @@ -6930,7 +6985,7 @@ or an indication of failure via the EXIT-CODE of the process" (uiop/package:define-package :uiop/configuration (:recycle :uiop/configuration :asdf/configuration) ;; necessary to upgrade from 2.27. - (:use :uiop/common-lisp :uiop/utility + (:use :uiop/package :uiop/common-lisp :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build) (:export #:user-configuration-directories #:system-configuration-directories ;; implemented in backward-driver @@ -6945,7 +7000,8 @@ or an indication of failure via the EXIT-CODE of the process" #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #:*user-cache* #:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook #:resolve-location #:location-designator-p #:location-function-p #:*here-directory* - #:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration)) + #:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration + #:uiop-directory)) (in-package :uiop/configuration) (with-upgradability () @@ -7337,7 +7393,28 @@ or just the first one (for direction :output or :io). "Compute (and return) the location of the default user-cache for translate-output objects. Side-effects for cached file location computation." (setf *user-cache* (xdg-cache-home "common-lisp" :implementation))) - (register-image-restore-hook 'compute-user-cache)) + (register-image-restore-hook 'compute-user-cache) + + (defun uiop-directory () + "Try to locate the UIOP source directory at runtime" + (labels ((pf (x) (ignore-errors (probe-file* x))) + (sub (x y) (pf (subpathname x y))) + (ssd (x) (ignore-errors (symbol-call :asdf :system-source-directory x)))) + ;; NB: conspicuously *not* including searches based on #.(current-lisp-pathname) + (or + ;; Look under uiop if available as source override, under asdf if avaiable as source + (ssd "uiop") + (sub (ssd "asdf") "uiop/") + ;; Look in recommended path for user-visible source installation + (sub (user-homedir-pathname) "common-lisp/asdf/uiop/") + ;; Look in XDG paths under known package names for user-invisible source installation + (xdg-data-pathname "common-lisp/source/asdf/uiop/") + (xdg-data-pathname "common-lisp/source/cl-asdf/uiop/") ; traditional Debian location + ;; The last one below is useful for Fare, primary (sole?) known user + (sub (user-homedir-pathname) "cl/asdf/uiop/") + (cerror "Configure source registry to include UIOP source directory and retry." + "Unable to find UIOP directory") + (uiop-directory))))) ;;; ------------------------------------------------------------------------- ;;; Hacks for backward-compatibility with older versions of UIOP @@ -7372,7 +7449,8 @@ DEPRECATED. Use UIOP:XDG-CONFIG-PATHNAMES instead." (xdg-config-pathnames "common-lisp")) (defun system-configuration-directories () "Return the list of system configuration directories for common-lisp. -DEPRECATED. Use UIOP:CONFIG-SYSTEM-PATHNAMES instead." +DEPRECATED. Use UIOP:SYSTEM-CONFIG-PATHNAMES (with argument \"common-lisp\"), +instead." (system-config-pathnames "common-lisp")) (defun in-first-directory (dirs x &key (direction :input)) "Finds the first appropriate file named X in the list of DIRS for I/O @@ -7521,7 +7599,7 @@ previously-loaded version of ASDF." ;; "3.4.5.67" would be a development version in the official branch, on top of 3.4.5. ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5 ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67 - (asdf-version "3.3.2") + (asdf-version "3.3.3") (existing-version (asdf-version))) (setf *asdf-version* asdf-version) (when (and existing-version (not (equal asdf-version existing-version))) @@ -7534,7 +7612,7 @@ previously-loaded version of ASDF." ;;; Upon upgrade, specially frob some functions and classes that are being incompatibly redefined (when-upgrading () (let* ((previous-version (first *previous-asdf-versions*)) - (redefined-functions ;; List of functions that changes incompatibly since 2.27: + (redefined-functions ;; List of functions that changed incompatibly since 2.27: ;; gf signature changed (should NOT happen), defun that became a generic function, ;; method removed that will mess up with new ones (especially :around :before :after, ;; more specific or call-next-method'ed method) and/or semantics otherwise modified. Oops. @@ -7545,8 +7623,8 @@ previously-loaded version of ASDF." ;; Also note that we don't include the defgeneric=>defun, because they are ;; done directly with defun* and need not trigger a punt on data. ;; See discussion at https://gitlab.common-lisp.net/asdf/asdf/merge_requests/36 - `(,@(when (version<= previous-version "3.1.2") '(#:component-depends-on #:input-files)) ;; crucial methods *removed* before 3.1.2 - ,@(when (version<= previous-version "3.1.7.20") '(#:find-component)))) + `(,@(when (version< previous-version "3.1.2") '(#:component-depends-on #:input-files)) ;; crucial methods *removed* before 3.1.2 + ,@(when (version< previous-version "3.1.7.20") '(#:find-component)))) (redefined-classes ;; redefining the classes causes interim circularities ;; with the old ASDF during upgrade, and many implementations bork @@ -7883,9 +7961,9 @@ or NIL for top-level components (a.k.a. systems)")) (defmethod component-parent ((component null)) nil) ;; Deprecated: Backward compatible way of computing the FILE-TYPE of a component. - ;; TODO: find users, have them stop using that, remove it for ASDF4. - (defgeneric source-file-type (component system) - (:documentation "DEPRECATED. Use the FILE-TYPE of a COMPONENT instead.")) + (with-asdf-deprecation (:style-warning "3.4") + (defgeneric source-file-type (component system) + (:documentation "DEPRECATED. Use the FILE-TYPE of a COMPONENT instead."))) (define-condition duplicate-names (system-definition-error) ((name :initarg :name :reader duplicate-names-name)) @@ -8222,6 +8300,7 @@ Use of INITARGS is not supported at this time." #:system-source-file #:system-source-directory #:system-relative-pathname #:system-description #:system-long-description #:system-author #:system-maintainer #:system-licence #:system-license + #:system-version #:definition-dependency-list #:definition-dependency-set #:system-defsystem-depends-on #:system-depends-on #:system-weakly-depends-on #:component-build-pathname #:build-pathname @@ -8243,8 +8322,10 @@ Use of INITARGS is not supported at this time." If no system is found, then signal an error if ERROR-P is true (the default), or else return NIL. A system designator is usually a string (conventionally all lowercase) or a symbol, designating the same system as its downcased name; it can also be a system object (designating itself).")) + (defgeneric system-source-file (system) (:documentation "Return the source file in which system is defined.")) + ;; This is bad design, but was the easiest kluge I found to let the user specify that ;; some special actions create outputs at locations controled by the user that are not affected ;; by the usual output-translations. @@ -8263,6 +8344,7 @@ NB: This interface is subject to change. Please contact ASDF maintainers if you (with no argument) when running an image dumped from the COMPONENT. NB: This interface is subject to change. Please contact ASDF maintainers if you use it.")) + (defmethod component-entry-point ((c component)) nil)) @@ -8287,19 +8369,21 @@ a SYSTEM is redefined and its class is modified.")) (defclass system (module proto-system) ;; Backward-compatibility: inherit from module. ASDF4: only inherit from parent-component. (;; {,long-}description is now inherited from component, but we add the legacy accessors - (description :accessor system-description) - (long-description :accessor system-long-description) - (author :accessor system-author :initarg :author :initform nil) - (maintainer :accessor system-maintainer :initarg :maintainer :initform nil) - (licence :accessor system-licence :initarg :licence - :accessor system-license :initarg :license :initform nil) - (homepage :accessor system-homepage :initarg :homepage :initform nil) - (bug-tracker :accessor system-bug-tracker :initarg :bug-tracker :initform nil) - (mailto :accessor system-mailto :initarg :mailto :initform nil) - (long-name :accessor system-long-name :initarg :long-name :initform nil) + (description :writer (setf system-description)) + (long-description :writer (setf system-long-description)) + (author :writer (setf system-author) :initarg :author :initform nil) + (maintainer :writer (setf system-maintainer) :initarg :maintainer :initform nil) + (licence :writer (setf system-licence) :initarg :licence + :writer (setf system-license) :initarg :license + :initform nil) + (homepage :writer (setf system-homepage) :initarg :homepage :initform nil) + (bug-tracker :writer (setf system-bug-tracker) :initarg :bug-tracker :initform nil) + (mailto :writer (setf system-mailto) :initarg :mailto :initform nil) + (long-name :writer (setf system-long-name) :initarg :long-name :initform nil) ;; Conventions for this slot aren't clear yet as of ASDF 2.27, but whenever they are, they will be enforced. ;; I'm introducing the slot before the conventions are set for maximum compatibility. - (source-control :accessor system-source-control :initarg :source-control :initform nil) + (source-control :writer (setf system-source-control) :initarg :source-control :initform nil) + (builtin-system-p :accessor builtin-system-p :initform nil :initarg :builtin-system-p) (build-pathname :initform nil :initarg :build-pathname :accessor component-build-pathname) @@ -8375,6 +8459,35 @@ NB: The onus is unhappily on the user to avoid clashes." (frob-substrings (coerce-name name) '("/" ":" "\\") "--"))) +;;; System virtual slot readers, recursing to the primary system if needed. +(with-upgradability () + (defvar *system-virtual-slots* '(long-name description long-description + author maintainer mailto + homepage source-control + licence version bug-tracker) + "The list of system virtual slot names.") + (defun system-virtual-slot-value (system slot-name) + "Return SYSTEM's virtual SLOT-NAME value. +If SYSTEM's SLOT-NAME value is NIL and SYSTEM is a secondary system, look in +the primary one." + (or (slot-value system slot-name) + (unless (primary-system-p system) + (slot-value (find-system (primary-system-name system)) + slot-name)))) + (defmacro define-system-virtual-slot-reader (slot-name) + `(defun* ,(intern (concatenate 'string (string :system-) + (string slot-name))) + (system) + (system-virtual-slot-value system ',slot-name))) + (defmacro define-system-virtual-slot-readers () + `(progn ,@(mapcar (lambda (slot-name) + `(define-system-virtual-slot-reader ,slot-name)) + *system-virtual-slots*))) + (define-system-virtual-slot-readers) + (defun system-license (system) + (system-virtual-slot-value system 'licence))) + + ;;;; Pathnames (with-upgradability () @@ -10786,8 +10899,9 @@ Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD." (defvar *old-asdf-systems* (make-hash-table :test 'equal)) ;; (Private) function to check that a system that was found isn't an asdf downgrade. - ;; Returns T if everything went right, NIL if the system was an ASDF of the same or older version, - ;; that shall not be loaded. Also issue a warning if it was a strictly older version of ASDF. + ;; Returns T if everything went right, NIL if the system was an ASDF at an older version, + ;; or UIOP of the same or older version, that shall not be loaded. + ;; Also issue a warning if it was a strictly older version of ASDF. (defun check-not-old-asdf-system (name pathname) (or (not (member name '("asdf" "uiop") :test 'equal)) (null pathname) @@ -10798,9 +10912,12 @@ Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD." (read-file-form version-pathname :at (if asdfp '(0) '(2 2 2))))) (old-version (asdf-version))) (cond - ;; Don't load UIOP of the exact same version: we already loaded it as part of ASDF. - ((and (equal old-version version) (equal name "uiop")) nil) - ((version<= old-version version) t) ;; newer or same version: Good! + ;; Same version is OK for ASDF, to allow loading from modified source. + ;; However, do *not* load UIOP of the exact same version: + ;; it was already loaded it as part of ASDF and would only be double-loading. + ;; Be quiet about it, though, since it's a normal situation. + ((equal old-version version) asdfp) + ((version< old-version version) t) ;; newer version: Good! (t ;; old version: bad (ensure-gethash (list (namestring pathname) version) *old-asdf-systems* @@ -10962,6 +11079,8 @@ PREVIOUS-PRIMARY when not null is the primary system for the PREVIOUS system." #:class-for-type #:*default-component-class* #:determine-system-directory #:parse-component-form #:non-toplevel-system #:non-system-system #:bad-system-name + #:*known-systems-with-bad-secondary-system-names* + #:known-system-with-bad-secondary-system-names-p #:sysdef-error-component #:check-component-input #:explain)) (in-package :asdf/parse-defsystem) @@ -11114,7 +11233,7 @@ Please only define ~S and secondary systems with a name starting with ~S (e.g. ~ ;;; "inline methods" (with-upgradability () (defparameter* +asdf-methods+ - '(perform-with-restarts perform explain output-files operation-done-p)) + '(perform-with-restarts perform explain output-files operation-done-p)) (defun %remove-component-inline-methods (component) (dolist (name +asdf-methods+) @@ -11127,19 +11246,55 @@ Please only define ~S and secondary systems with a name starting with ~S (e.g. ~ (component-inline-methods component))) (component-inline-methods component) nil) + (defparameter *standard-method-combination-qualifiers* + '(:around :before :after)) + +;;; Find inline method definitions of the form +;;; +;;; :perform (test-op :before (operation component) ...) +;;; +;;; in REST (which is the plist of all DEFSYSTEM initargs) and define the specified methods. (defun %define-component-inline-methods (ret rest) + ;; find key-value pairs that look like inline method definitions in REST. For each identified + ;; definition, parse it and, if it is well-formed, define the method. (loop* :for (key value) :on rest :by #'cddr :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=)) :when name :do - (destructuring-bind (op &rest body) value - (loop :for arg = (pop body) - :while (atom arg) - :collect arg :into qualifiers - :finally - (destructuring-bind (o c) arg - (pushnew - (eval `(defmethod ,name ,@qualifiers ((,o ,op) (,c (eql ,ret))) ,@body)) - (component-inline-methods ret))))))) + ;; parse VALUE as an inline method definition of the form + ;; + ;; (OPERATION-NAME [QUALIFIER] (OPERATION-PARAMETER COMPONENT-PARAMETER) &rest BODY) + (destructuring-bind (operation-name &rest rest) value + (let ((qualifiers '())) + ;; ensure that OPERATION-NAME is a symbol. + (unless (and (symbolp operation-name) (not (null operation-name))) + (sysdef-error "Ill-formed inline method: ~S. The first element is not a symbol ~ + designating an operation but ~S." + value operation-name)) + ;; ensure that REST starts with either a cons (potential lambda list, further checked + ;; below) or a qualifier accepted by the standard method combination. Everything else + ;; is ill-formed. In case of a valid qualifier, pop it from REST so REST now definitely + ;; has to start with the lambda list. + (cond + ((consp (car rest))) + ((not (member (car rest) + *standard-method-combination-qualifiers*)) + (sysdef-error "Ill-formed inline method: ~S. Only a single of the standard ~ + qualifiers ~{~S~^ ~} is allowed, not ~S." + value *standard-method-combination-qualifiers* (car rest))) + (t + (setf qualifiers (list (pop rest))))) + ;; REST must start with a two-element lambda list. + (unless (and (listp (car rest)) + (length=n-p (car rest) 2) + (null (cddar rest))) + (sysdef-error "Ill-formed inline method: ~S. The operation name ~S is not followed by ~ + a lambda-list of the form (OPERATION COMPONENT) and a method body." + value operation-name)) + ;; define the method. + (destructuring-bind ((o c) &rest body) rest + (pushnew + (eval `(defmethod ,name ,@qualifiers ((,o ,operation-name) (,c (eql ,ret))) ,@body)) + (component-inline-methods ret))))))) (defun %refresh-component-inline-methods (component rest) ;; clear methods, then add the new ones @@ -11253,6 +11408,13 @@ system names contained using COERCE-NAME. Return the result." (coerce-name (component-system component)))) component))) + (defparameter* *known-systems-with-bad-secondary-system-names* + (list-to-hash-set '("cl-ppcre"))) + (defun known-system-with-bad-secondary-system-names-p (asd-name) + ;; Does .asd file with name ASD-NAME contain known exceptions + ;; that should be screened out of checking for BAD-SYSTEM-NAME? + (gethash asd-name *known-systems-with-bad-secondary-system-names*)) + (defun register-system-definition (name &rest options &key pathname (class 'system) (source-file () sfp) defsystem-depends-on &allow-other-keys) @@ -11270,8 +11432,11 @@ system names contained using COERCE-NAME. Return the result." (let* ((asd-name (and source-file (equal "asd" (fix-case (pathname-type source-file))) (fix-case (pathname-name source-file)))) + ;; note that PRIMARY-NAME is a *syntactically* primary name (primary-name (primary-system-name name))) - (when (and asd-name (not (equal asd-name primary-name))) + (when (and asd-name + (not (equal asd-name primary-name)) + (not (known-system-with-bad-secondary-system-names-p asd-name))) (warn (make-condition 'bad-system-name :source-file source-file :name name)))) (let* (;; NB: handle defsystem-depends-on BEFORE to create the system object, ;; so that in case it fails, there is no incomplete object polluting the build. @@ -11833,8 +11998,17 @@ which is probably not what you want; you probably need to tweak your output tran :static-library (resolve-symlinks* pathname)))) (defun linkable-system (x) - (or (if-let (s (find-system x)) + (or ;; If the system is available as source, use it. + (if-let (s (find-system x)) + (and (output-files 'lib-op s) s)) + ;; If an ASDF upgrade is available from source, but not a UIOP upgrade to that, + ;; then use the asdf/driver system instead of + ;; the UIOP that was disabled by check-not-old-asdf-system. + (if-let (s (and (equal (coerce-name x) "uiop") + (output-files 'lib-op "asdf") + (find-system "asdf/driver"))) (and (output-files 'lib-op s) s)) + ;; If there was no source upgrade, look for modules provided by the implementation. (if-let (p (system-module-pathname (coerce-name x))) (make-prebuilt-system x p)))) @@ -12567,7 +12741,7 @@ after having found a .asd file? True by default.") (recurse-beyond-asds *recurse-beyond-asds*) ignore-cache) (let ((visited (make-hash-table :test 'equalp))) (flet ((collectp (dir) - (unless (and (not ignore-cache) (process-source-registry-cache directory collect)) + (unless (and (not ignore-cache) (process-source-registry-cache dir collect)) (let ((asds (collect-asds-in-directory dir collect))) (or recurse-beyond-asds (not asds))))) (recursep (x) ; x will be a directory pathname @@ -13225,6 +13399,7 @@ system or its dependencies if it has already been loaded." #:system-maintainer #:system-license #:system-licence + #:system-version #:system-source-file #:system-source-directory #:system-relative-pathname ===================================== src/contrib/asdf/doc/asdf.html ===================================== The diff for this file was not included because it is too large. ===================================== src/contrib/asdf/doc/asdf.info ===================================== The diff for this file was not included because it is too large. ===================================== src/contrib/asdf/doc/asdf.pdf ===================================== Binary files a/src/contrib/asdf/doc/asdf.pdf and b/src/contrib/asdf/doc/asdf.pdf differ View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/76fd7aeffcee03106d710b311… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/76fd7aeffcee03106d710b311… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #68: Use -O1 when compiling with gcc now
by Raymond Toy 17 Apr '19

17 Apr '19

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 9bd292bd by Raymond Toy at 2019-04-17T02:17:32Z Fix #68: Use -O1 when compiling with gcc now As reported gcc 8.1.1 can't produce a working lisp. gcc 8.3.1 also fails. But as reported on cmucl-imp, 2019-04-08, by Juan Pablo Hierro Alverez, -O1 works. Use -O1. - - - - - 2776c40d by Raymond Toy at 2019-04-17T02:36:50Z Merge branch 'issue-68-use-gcc-o1' into 'master' Fix #68: Use -O1 when compiling with gcc now Closes #68 See merge request cmucl/cmucl!45 - - - - - 1 changed file: - src/lisp/Config.x86_common Changes: ===================================== src/lisp/Config.x86_common ===================================== @@ -44,7 +44,10 @@ endif CPPFLAGS := $(CPP_DEFINE_OPTIONS) $(CPP_INCLUDE_OPTIONS) CFLAGS += -Wstrict-prototypes -Wall -g -fno-omit-frame-pointer -CFLAGS += -O2 + +# gcc 8.1.1 and 8.3.1 (and probably anything after 8.1.1?) won't +# produce a working lisp with -O2. Just use -O1. +CFLAGS += -O1 ASFLAGS = -g ASSEM_SRC = x86-assem.S View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/04c1bee3840ecbbd8a35cc7e… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/04c1bee3840ecbbd8a35cc7e… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-68-use-gcc-o1
by Raymond Toy 17 Apr '19

17 Apr '19

Raymond Toy pushed new branch issue-68-use-gcc-o1 at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/tree/issue-68-use-gcc-o1 You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-update-clx-with-cmucl-fixes] Merge with sharplispers/clx commit 021f5d7
by Raymond Toy 30 Dec '18

30 Dec '18

Raymond Toy pushed to branch rtoy-update-clx-with-cmucl-fixes at cmucl / cmucl Commits: ab34d94e by Raymond Toy at 2018-12-30T01:53:39Z Merge with sharplispers/clx commit 021f5d7 - - - - - 5 changed files: - src/clx/clx.asd - src/clx/demo/clx-demos.lisp - src/clx/demo/menu.lisp - src/clx/dependent.lisp - src/clx/provide.lisp Changes: ===================================== src/clx/clx.asd ===================================== @@ -116,7 +116,8 @@ Independent FOSS developers" :components ((:module "demo" :components - ((:file "bezier") + ((:file "menu") + (:file "bezier") (:file "beziertest" :depends-on ("bezier")) (:file "clclock") (:file "clipboard") @@ -126,7 +127,6 @@ Independent FOSS developers" ;; deletion notes. Find out why, and either fix or ;; workaround the problem. (:file "mandel") - (:file "menu") (:file "zoid") (:file "image") (:file "trapezoid" :depends-on ("zoid")))))) ===================================== src/clx/demo/clx-demos.lisp ===================================== @@ -5,9 +5,15 @@ ;;; ;;; This file should be portable to any valid Common Lisp with CLX -- DEC 88. ;;; +;;; CMUCL MP support by Douglas Crosher 1998. +;;; Enhancements including the CLX menu, rewrite of the greynetic +;;; demo, and other fixes by Fred Gilham 1998. +;;; +;;; Backported some changes found in CMUCL repository -- jd 2018-12-29. -(defpackage #:xlib-demo/demos (:use :common-lisp) - (:export do-all-demos demo)) +(defpackage #:xlib-demo/demos + (:use :common-lisp) + (:export #:demo)) (in-package :xlib-demo/demos) @@ -21,6 +27,7 @@ ;;; it is running. (defparameter *demos* nil) +(defparameter *delay* 0.5) (defvar *display* nil) (defvar *screen* nil) @@ -33,105 +40,82 @@ `(progn (defun ,fun-name ,args ,doc - (unless *display* - #+:cmu - (multiple-value-setq (*display* *screen*) (ext:open-clx-display)) - #+(or sbcl allegro clisp lispworks) - (progn - (setf *display* (xlib::open-default-display)) - (setf *screen* (xlib:display-default-screen *display*))) - #-(or cmu sbcl allegro clisp lispworks) - (progn - ;; Portable method - (setf *display* (xlib:open-display (machine-instance))) - (setf *screen* (xlib:display-default-screen *display*))) - (setf *root* (xlib:screen-root *screen*)) - (setf *black-pixel* (xlib:screen-black-pixel *screen*)) - (setf *white-pixel* (xlib:screen-white-pixel *screen*))) - (let ((*window* (xlib:create-window :parent *root* - :x ,x :y ,y - :event-mask nil - :width ,width :height ,height - :background *white-pixel* - :border *black-pixel* - :border-width 2 - :override-redirect :on))) + (let* ((*display* (or *display* + (xlib:open-default-display) + (xlib:open-display (machine-instance)))) + (*screen* (xlib:display-default-screen *display*)) + (*root* (xlib:screen-root *screen*)) + (*black-pixel* (xlib:screen-black-pixel *screen*)) + (*white-pixel* (xlib:screen-white-pixel *screen*)) + (*window* (xlib:create-window :parent *root* + :x ,x :y ,y + :event-mask '(:visibility-change) + :width ,width :height ,height + :background *white-pixel* + :border *black-pixel* + :border-width 2 + :override-redirect :off))) + (xlib:set-wm-properties *window* + :name ,demo-name + :icon-name ,demo-name + :resource-name ,demo-name + :x ,x :y ,y :width ,width :height ,height + :user-specified-position-p t + :user-specified-size-p t + :min-width ,width :min-height ,height + :width-inc nil :height-inc nil) (xlib:map-window *window*) - ;; - ;; I hate to do this since this is not something any normal - ;; program should do ... - (setf (xlib:window-priority *window*) :above) - (xlib:display-finish-output *display*) - (unwind-protect - (progn ,@forms) - (xlib:unmap-window *window*) - (xlib:display-finish-output *display*)))) + ;; Wait until we get mapped before doing anything. + (xlib:display-finish-output *display*) + (unwind-protect (progn ,@forms) + (xlib:display-finish-output *display*) + (xlib:unmap-window *window*)))) (setf (get ',fun-name 'demo-name) ',demo-name) (setf (get ',fun-name 'demo-doc) ',doc) - (export ',fun-name) (pushnew ',fun-name *demos*) ',fun-name)) -;;;; Main entry points. - -(defun do-all-demos () - (loop - (dolist (demo *demos*) - (funcall demo) - (sleep 3)))) - -;;; DEMO is a hack to get by. It should be based on creating a menu. At -;;; that time, *name-to-function* should be deleted, since this mapping will -;;; be manifested in the menu slot name cross its action. Also the -;;; "Shove-bounce" demo should be renamed to "Shove bounce"; likewise for -;;; "Fast-towers-of-Hanoi" and "Slow-towers-of-hanoi". -;;; +;;; DEMO (defvar *name-to-function* (make-hash-table :test #'eq)) (defvar *keyword-package* (find-package "KEYWORD")) +(defvar *demo-names* nil) (defun demo () - (macrolet ((read-demo () - `(let ((*package* *keyword-package*)) - (read)))) + (let ((*demo-names* '("Quit"))) (dolist (d *demos*) (setf (gethash (intern (string-upcase (get d 'demo-name)) *keyword-package*) *name-to-function*) - d)) - (loop - (fresh-line) - (dolist (d *demos*) - (write-string " ") - (write-line (get d 'demo-name))) - (write-string " ") - (write-line "Help <demo name>") - (write-string " ") - (write-line "Quit") - (write-string "Enter demo name: ") - (let ((demo (read-demo))) - (case demo - (:help - (let* ((demo (read-demo)) - (fun (gethash demo *name-to-function*))) - (fresh-line) - (if fun - (format t "~&~%~A~&~%" (get fun 'demo-doc)) - (format t "Unknown demo name -- ~A." demo)))) - (:quit (return t)) - (t - (let ((fun (gethash demo *name-to-function*))) - (if fun - #+mp - (mp:make-process #'(lambda () - (loop - (funcall fun) - (sleep 2))) - :name (format nil "~S" demo)) - #-mp - (funcall fun) - (format t "~&~%Unknown demo name -- ~A.~&~%" demo))))))))) + d) + (push (get d 'demo-name) *demo-names*)) + + (let* ((display (xlib:open-default-display)) + (screen (xlib:display-default-screen display)) + (fg-color (xlib:screen-white-pixel screen)) + (bg-color (xlib:screen-black-pixel screen)) + (nice-font (xlib:open-font display "fixed"))) + + (let ((a-menu (xlib::create-menu + (xlib::screen-root screen) ;the menu's parent + fg-color bg-color nice-font))) + + (setf (xlib::menu-title a-menu) "Please pick your favorite demo:") + (xlib::menu-set-item-list a-menu *demo-names*) + (ignore-errors ;; closing window is not handled properly in menu. + (unwind-protect + (do ((choice (xlib::menu-choose a-menu 100 100) + (xlib::menu-choose a-menu 100 100))) + ((and choice (string-equal "Quit" choice))) + (let* ((demo-choice (intern (string-upcase choice) + *keyword-package*)) + (fun (gethash demo-choice *name-to-function*))) + (setf choice nil) + (when fun + (ignore-errors (funcall fun))))) + (xlib:display-finish-output display) + (xlib:close-display display))))))) ;;;; Shared demo utilities. @@ -143,60 +127,124 @@ (xlib:window-map-state w)))) -;;;; Greynetic. - -;;; GREYNETIC displays random sized and shaded boxes in a window. This is -;;; real slow. It needs work. -;;; -(defun greynetic (window duration) - (let* ((pixmap (xlib:create-pixmap :width 32 :height 32 :depth 1 - :drawable window)) - (gcontext (xlib:create-gcontext :drawable window - :background *white-pixel* - :foreground *black-pixel* - :tile pixmap - :fill-style :tiled))) - (multiple-value-bind (width height) (full-window-state window) - (dotimes (i duration) - (let* ((pixmap-data (greynetic-pixmapper)) - (image (xlib:create-image :width 32 :height 32 - :depth 1 :data pixmap-data))) - (xlib:put-image pixmap gcontext image :x 0 :y 0 :width 32 :height 32) - (xlib:draw-rectangle window gcontext - (- (random width) 5) - (- (random height) 5) - (+ 4 (random (truncate width 3))) - (+ 4 (random (truncate height 3))) - t)) - (xlib:display-force-output *display*))) - (xlib:free-gcontext gcontext) - (xlib:free-pixmap pixmap))) - -(defvar *greynetic-pixmap-array* - (make-array '(32 32) :initial-element 0 :element-type 'xlib:pixel)) - -(defun greynetic-pixmapper () - (let ((pixmap-data *greynetic-pixmap-array*)) +(defun make-random-bitmap () + (let ((bitmap-data (make-array '(32 32) :initial-element 0 + :element-type 'xlib::bit))) (dotimes (i 4) (declare (fixnum i)) (let ((nibble (random 16))) - (setf nibble (logior nibble (ash nibble 4)) - nibble (logior nibble (ash nibble 8)) - nibble (logior nibble (ash nibble 12)) - nibble (logior nibble (ash nibble 16))) - (dotimes (j 32) - (let ((bit (if (logbitp j nibble) 1 0))) - (setf (aref pixmap-data i j) bit - (aref pixmap-data (+ 4 i) j) bit - (aref pixmap-data (+ 8 i) j) bit - (aref pixmap-data (+ 12 i) j) bit - (aref pixmap-data (+ 16 i) j) bit - (aref pixmap-data (+ 20 i) j) bit - (aref pixmap-data (+ 24 i) j) bit - (aref pixmap-data (+ 28 i) j) bit))))) - pixmap-data)) - -#+nil + (setf nibble (logior nibble (ash nibble 4)) + nibble (logior nibble (ash nibble 8)) + nibble (logior nibble (ash nibble 12)) + nibble (logior nibble (ash nibble 16))) + (dotimes (j 32) + (let ((bit (if (logbitp j nibble) 1 0))) + (setf (aref bitmap-data i j) bit + (aref bitmap-data (+ 4 i) j) bit + (aref bitmap-data (+ 8 i) j) bit + (aref bitmap-data (+ 12 i) j) bit + (aref bitmap-data (+ 16 i) j) bit + (aref bitmap-data (+ 20 i) j) bit + (aref bitmap-data (+ 24 i) j) bit + (aref bitmap-data (+ 28 i) j) bit))))) + bitmap-data)) + + +(defun make-random-pixmap () + (let ((image (xlib:create-image :depth 1 :data (make-random-bitmap)))) + (make-pixmap image 32 32))) + +(defvar *pixmaps* nil) + +(defun make-pixmap (image width height) + (let* ((pixmap (xlib:create-pixmap :width width :height height + :depth 1 :drawable *root*)) + (gc (xlib:create-gcontext :drawable pixmap + :background *black-pixel* + :foreground *white-pixel*))) + (xlib:put-image pixmap gc image :x 0 :y 0 :width width :height height) + (xlib:free-gcontext gc) + pixmap)) + + +;;; +;;; This function returns one of the pixmaps in the *pixmaps* array. +(defun greynetic-pixmapper () + (aref *pixmaps* (random (length *pixmaps*)))) + + +(defun greynetic (window duration) + (let* ((depth (xlib:drawable-depth window)) + (draw-gcontext (xlib:create-gcontext :drawable window + :foreground *white-pixel* + :background *black-pixel*)) + ;; Need a random state per process. + (*random-state* (make-random-state t)) + (*pixmaps* (let ((pixmap-array (make-array 30))) + (dotimes (i 30) + (setf (aref pixmap-array i) (make-random-pixmap))) + pixmap-array))) + + (unwind-protect + (multiple-value-bind (width height) (full-window-state window) + (declare (fixnum width height)) + (let ((border-x (truncate width 20)) + (border-y (truncate height 20))) + (declare (fixnum border-x border-y)) + (dotimes (i duration) + (let ((pixmap (greynetic-pixmapper))) + (xlib:with-gcontext (draw-gcontext + :foreground (random (ash 1 depth)) + :background (random (ash 1 depth)) + :stipple pixmap + :fill-style + :opaque-stippled) + (cond ((zerop (mod i 500)) + (xlib:clear-area window) + (sleep .1)) + (t + (sleep *delay*))) + (if (< (random 3) 2) + (let* ((w (+ border-x + (truncate (* (random (- width + (* 2 border-x))) + (random width)) width))) + (h (+ border-y + (truncate (* (random (- height + (* 2 border-y))) + (random height)) height))) + (x (random (- width w))) + (y (random (- height h)))) + (declare (fixnum w h x y)) + (if (zerop (random 2)) + (xlib:draw-rectangle window draw-gcontext + x y w h t) + (xlib:draw-arc window draw-gcontext + x y w h 0 (* 2 pi) t))) + (let ((p1-x (+ border-x + (random (- width (* 2 border-x))))) + (p1-y (+ border-y + (random (- height (* 2 border-y))))) + (p2-x (+ border-x + (random (- width (* 2 border-x))))) + (p2-y (+ border-y + (random (- height (* 2 border-y))))) + (p3-x (+ border-x + (random (- width (* 2 border-x))))) + (p3-y (+ border-y + (random (- height (* 2 border-y)))))) + (declare (fixnum p1-x p1-y p2-x p2-y p3-x p3-y)) + (xlib:draw-lines window draw-gcontext + (list p1-x p1-y p2-x p2-y p3-x p3-y) + :relative-p nil + :fill-p t + :shape :convex))) + (xlib:display-force-output *display*)))))) + (dotimes (i (length *pixmaps*)) + (xlib:free-pixmap (aref *pixmaps* i))) + (xlib:free-gcontext draw-gcontext)))) + + (defdemo greynetic-demo "Greynetic" (&optional (duration 300)) 100 100 600 600 "Displays random grey rectangles." @@ -677,6 +725,7 @@ start-needle end-needle) end-needle) + (sleep *delay*) t) ;;; Move-N-Disks moves the top N disks from START-NEEDLE to END-NEEDLE @@ -775,27 +824,28 @@ (when (= prev-neg-velocity 0) (return t)) (let ((negative-velocity (minusp y-velocity))) (loop - (let ((next-y (+ y y-velocity)) - (next-y-velocity (+ y-velocity gravity))) - (declare (fixnum next-y next-y-velocity)) - (when (> next-y top-of-window-at-bottom) - (cond - (number-problems - (setf y-velocity (incf prev-neg-velocity))) - (t - (setq y-velocity - (- (truncate (* elasticity y-velocity)))) - (when (= y-velocity prev-neg-velocity) - (incf y-velocity) - (setf number-problems t)) - (setf prev-neg-velocity y-velocity))) - (setf y top-of-window-at-bottom) - (setf (xlib:drawable-x window) x - (xlib:drawable-y window) y) - (xlib:display-force-output *display*) - (return)) - (setq y-velocity next-y-velocity) - (setq y next-y)) + (let ((next-y (+ y y-velocity)) + (next-y-velocity (+ y-velocity gravity))) + (declare (fixnum next-y next-y-velocity)) + (when (> next-y top-of-window-at-bottom) + (cond + (number-problems + (setf y-velocity (incf prev-neg-velocity))) + (t + (setq y-velocity + (- (truncate (* elasticity y-velocity)))) + (when (= y-velocity prev-neg-velocity) + (incf y-velocity) + (setf number-problems t)) + (setf prev-neg-velocity y-velocity))) + (setf y top-of-window-at-bottom) + (setf (xlib:drawable-x window) x + (xlib:drawable-y window) y) + (xlib:display-force-output *display*) + (return)) + (setq y-velocity next-y-velocity) + (setq y next-y) + (sleep (/ *delay* 100))) (when (and negative-velocity (>= y-velocity 0)) (setf negative-velocity nil)) (let ((next-x (+ x x-velocity))) @@ -814,7 +864,7 @@ 100 100 300 300 "Drops the demo window with an inital X velocity which bounces off screen borders." - (bounce-window *window* 30)) + (bounce-window *window* 3)) (defdemo bounce-demo "Bounce" () 100 100 300 300 @@ -846,8 +896,8 @@ (multiple-value-bind (width height) (full-window-state window) (xlib:clear-area window) (draw-ppict window gc point-count 0.0 0.0 (* width 0.5) (* height 0.5)) - (xlib:display-force-output display) - (sleep 4)) + (xlib:display-finish-output display) + (sleep 1)) (xlib:free-gcontext gc))) ;;; Draw points. X assumes points are in the range of width x height, @@ -892,8 +942,8 @@ :function boole-c2 :plane-mask (logxor *white-pixel* *black-pixel*) - :background *white-pixel* - :foreground *black-pixel* + :background *black-pixel* + :foreground *white-pixel* :fill-style :solid)) (rectangles (make-array (* 4 num-rectangles) :element-type 'number @@ -920,6 +970,7 @@ (decf y-off (ash y-dir 1)) (setf y-dir (- y-dir)))) (xlib:draw-rectangles window gcontext rectangles t) + (sleep *delay*) (xlib:display-force-output display)))) (xlib:free-gcontext gcontext))) @@ -938,9 +989,12 @@ (defvar *ball-size-x* 38) (defvar *ball-size-y* 34) -(defmacro xor-ball (pixmap window gcontext x y) - `(xlib:copy-area ,pixmap ,gcontext 0 0 *ball-size-x* *ball-size-y* - ,window ,x ,y)) +(defun xor-ball (pixmap window gcontext x y) + (xlib:copy-plane pixmap gcontext 1 + 0 0 + *ball-size-x* *ball-size-y* + window + x y)) (defconstant bball-gravity 1) (defconstant maximum-x-drift 7) @@ -1016,7 +1070,7 @@ (defun bounce-balls (display window how-many duration) (xlib:clear-area window) - (xlib:display-force-output display) + (xlib:display-finish-output display) (multiple-value-bind (*max-bball-x* *max-bball-y*) (full-window-state window) (let* ((balls (do ((i 0 (1+ i)) (list () (cons (make-ball) list))) @@ -1036,16 +1090,16 @@ (xlib:free-gcontext pixmap-gc) (dolist (ball balls) (xor-ball bounce-pixmap window gcontext (ball-x ball) (ball-y ball))) - (xlib:display-force-output display) + (xlib:display-finish-output display) (dotimes (i duration) (dolist (ball balls) - (bounce-1-ball bounce-pixmap window gcontext ball)) - (xlib:display-force-output display)) + (bounce-1-ball bounce-pixmap window gcontext ball) + (xlib:display-finish-output display)) + (sleep (/ *delay* 50.0))) (xlib:free-pixmap bounce-pixmap) (xlib:free-gcontext gcontext)))) -#+nil (defdemo bouncing-ball-demo "Bouncing-Ball" (&optional (how-many 5) (duration 500)) - 34 34 700 500 + 36 34 700 500 "Bouncing balls in space." (bounce-balls *display* *window* how-many duration)) ===================================== src/clx/demo/menu.lisp ===================================== @@ -27,7 +27,8 @@ ;;; | ;;;----------------------------------------------------------------------------------+ - +;;; Some changes are backported from CMUCL CLX source (our implementation had +;;; errors when we tried to use menu). This one is a little shorter. (defstruct (menu) "A simple menu of text strings." @@ -45,29 +46,27 @@ (defun create-menu (parent-window text-color background-color text-font) (make-menu - ;; Create menu graphics context - :gcontext (CREATE-GCONTEXT :drawable parent-window - :foreground text-color - :background background-color - :font text-font) - ;; Create menu window - :window (CREATE-WINDOW - :parent parent-window - :class :input-output - :x 0 ;temporary value - :y 0 ;temporary value - :width 16 ;temporary value - :height 16 ;temporary value - :border-width 2 - :border text-color - :background background-color - :save-under :on - :override-redirect :on ;override window mgr when positioning - :event-mask (MAKE-EVENT-MASK :leave-window - :exposure)))) - - -(defun menu-set-item-list (menu &rest item-strings) + ;; Create menu graphics context + :gcontext (CREATE-GCONTEXT :drawable parent-window + :foreground text-color + :background background-color + :font text-font) + ;; Create menu window + :window (CREATE-WINDOW + :parent parent-window + :class :input-output + :x 0 ;temporary value + :y 0 ;temporary value + :width 16 ;temporary value + :height 16 ;temporary value + :border-width 2 + :border text-color + :background background-color + :save-under :on + ;; :override-redirect :on ;override window mgr when positioning + :event-mask (MAKE-EVENT-MASK :leave-window :exposure)))) + +(defun menu-set-item-list (menu item-strings) ;; Assume the new items will change the menu's width and height (setf (menu-geometry-changed-p menu) t) @@ -148,7 +147,11 @@ (defun menu-refresh (menu) - (let* ((gcontext (menu-gcontext menu)) + (xlib:set-wm-properties (menu-window menu) + :name (menu-title menu) + :icon-name (menu-title menu) + :resource-name (menu-title menu)) + (let* ((gcontext (menu-gcontext menu)) (baseline-y (FONT-ASCENT (GCONTEXT-FONT gcontext)))) ;; Show title centered in "reverse-video" @@ -217,7 +220,7 @@ t))) ;; Erase the menu - (UNMAP-WINDOW mw) +;;; (UNMAP-WINDOW mw) ;; Return selected item string, if any (unless (eq selected-item :none) selected-item))) @@ -272,111 +275,3 @@ ;; Make menu visible (MAP-WINDOW menu-window))) - -(defun just-say-lisp (&optional (font-name "fixed")) - (let* ((display (open-default-display)) - (screen (first (DISPLAY-ROOTS display))) - (fg-color (SCREEN-BLACK-PIXEL screen)) - (bg-color (SCREEN-WHITE-PIXEL screen)) - (nice-font (OPEN-FONT display font-name)) - (a-menu (create-menu (screen-root screen) ;the menu's parent - fg-color bg-color nice-font))) - - (setf (menu-title a-menu) "Please pick your favorite language:") - (menu-set-item-list a-menu "Fortran" "APL" "Forth" "Lisp") - - ;; Bedevil the user until he picks a nice programming language - (unwind-protect - (do (choice) - ((and (setf choice (menu-choose a-menu 100 100)) - (string-equal "Lisp" choice)))) - - (CLOSE-DISPLAY display)))) - - -(defun pop-up (host strings &key (title "Pick one:") (font "fixed")) - (let* ((display (OPEN-DISPLAY host)) - (screen (first (DISPLAY-ROOTS display))) - (fg-color (SCREEN-BLACK-PIXEL screen)) - (bg-color (SCREEN-WHITE-PIXEL screen)) - (font (OPEN-FONT display font)) - (parent-width 400) - (parent-height 400) - (parent (CREATE-WINDOW :parent (SCREEN-ROOT screen) - :override-redirect :on - :x 100 :y 100 - :width parent-width :height parent-height - :background bg-color - :event-mask (MAKE-EVENT-MASK :button-press - :exposure))) - (a-menu (create-menu parent fg-color bg-color font)) - (prompt "Press a button...") - (prompt-gc (CREATE-GCONTEXT :drawable parent - :foreground fg-color - :background bg-color - :font font)) - (prompt-y (FONT-ASCENT font)) - (ack-y (- parent-height (FONT-DESCENT font)))) - - (setf (menu-title a-menu) title) - (apply #'menu-set-item-list a-menu strings) - - ;; Present main window - (MAP-WINDOW parent) - - (flet ((display-centered-text - (window string gcontext height width) - (multiple-value-bind (w a d l r fa fd) (text-extents gcontext string) - (declare (ignore a d l r)) - (let ((box-height (+ fa fd))) - - ;; Clear previous text - (CLEAR-AREA window - :x 0 :y (- height fa) - :width width :height box-height) - - ;; Draw new text - (DRAW-IMAGE-GLYPHS window gcontext (round (- width w) 2) height string))))) - - (unwind-protect - (loop - (EVENT-CASE (display :force-output-p t) - - (:exposure (count) - - ;; Display prompt - (when (zerop count) - (display-centered-text - parent - prompt - prompt-gc - prompt-y - parent-width)) - t) - - (:button-press (x y) - - ;; Pop up the menu - (let ((choice (menu-choose a-menu x y))) - (if choice - (display-centered-text - parent - (format nil "You have selected ~a." choice) - prompt-gc - ack-y - parent-width) - - (display-centered-text - parent - "No selection...try again." - prompt-gc - ack-y - parent-width))) - t) - - (otherwise () - ;;Ignore and discard any other event - t))) - - (CLOSE-DISPLAY display))))) - ===================================== src/clx/dependent.lisp ===================================== @@ -1061,36 +1061,56 @@ ;;; :TIMEOUT if it times out, NIL otherwise. ;;; The default implementation - -;; Poll for input every *buffer-read-polling-time* SECONDS. -#-(or CMU sbcl) -(defparameter *buffer-read-polling-time* 0.5) - -#-(or CMU sbcl clisp) +#-(or cmu sbcl clisp (and ecl serve-event)) +(progn + ;; Issue a warning to incentivize providing better implementation. + (eval-when (:compile-toplevel :load-toplevel :execute) + (warn "XLIB::BUFFER-INPUT-WAIT-DEFAULT: timeout polling used.")) + ;; Poll for input every *buffer-read-polling-time* SECONDS. + (defparameter *buffer-read-polling-time* 0.01) + (defun buffer-input-wait-default (display timeout) + (declare (type display display) + (type (or null (real 0 *)) timeout)) + (declare (clx-values timeout)) + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + (cond ((null stream)) + ((listen stream) nil) + ((and timeout (= timeout 0)) :timeout) + ((not (null timeout)) + (multiple-value-bind (npoll fraction) + (truncate timeout *buffer-read-polling-time*) + (dotimes (i npoll) ; Sleep for a time, then listen again + (sleep *buffer-read-polling-time*) + (when (listen stream) + (return-from buffer-input-wait-default nil))) + (when (plusp fraction) + (sleep fraction) ; Sleep a fraction of a second + (when (listen stream) ; and listen one last time + (return-from buffer-input-wait-default nil))) + :timeout)))))) + +#+(and ecl serve-event) (defun buffer-input-wait-default (display timeout) (declare (type display display) - (type (or null (real 0 *)) timeout)) - (declare (clx-values timeout)) - + (type (or null number) timeout)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (cond ((null stream)) ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((not (null timeout)) - (multiple-value-bind (npoll fraction) - (truncate timeout *buffer-read-polling-time*) - (dotimes (i npoll) ; Sleep for a time, then listen again - (sleep *buffer-read-polling-time*) - (when (listen stream) - (return-from buffer-input-wait-default nil))) - (when (plusp fraction) - (sleep fraction) ; Sleep a fraction of a second - (when (listen stream) ; and listen one last time - (return-from buffer-input-wait-default nil))) - :timeout))))) - -#+(or CMU sbcl clisp) + ((eql timeout 0) :timeout) + (T (flet ((usable! (fd) + (declare (ignore fd)) + (return-from buffer-input-wait-default))) + (serve-event:with-fd-handler ((ext:file-stream-fd + (typecase stream + (two-way-stream (two-way-stream-input-stream stream)) + (otherwise stream))) + :input #'usable!) + (serve-event:serve-event timeout))) + :timeout)))) + +#+(or cmu sbcl clisp) (defun buffer-input-wait-default (display timeout) (declare (type display display) (type (or null number) timeout)) @@ -1099,18 +1119,14 @@ (cond ((null stream)) ((listen stream) nil) ((eql timeout 0) :timeout) - (t - (if #+sbcl (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream) - :input timeout) - #+mp (mp:process-wait-until-fd-usable - (system:fd-stream-fd stream) :input timeout) + ;; MP package protocol may be shared between clisp and cmu. + ((or #+sbcl (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream) :input timeout) + #+mp (mp:process-wait-until-fd-usable (system:fd-stream-fd stream) :input timeout) #+clisp (multiple-value-bind (sec usec) (floor (or timeout 0)) - (ext:socket-status stream (and timeout sec) - (round usec 1d-6))) - #-(or sbcl mp clisp) (system:wait-until-fd-usable - (system:fd-stream-fd stream) :input timeout) - nil - :timeout))))) + (ext:socket-status stream (and timeout sec) (round usec 1d-6))) + #+cmu (system:wait-until-fd-usable (system:fd-stream-fd stream) :input timeout)) + nil) + (T :timeout)))) ;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the ;;; buffer. This should never block, so it can be called from the scheduler. ===================================== src/clx/provide.lisp ===================================== @@ -17,38 +17,3 @@ (in-package :common-lisp-user) (provide :clx) - -#-cmu -(progn -(defvar *clx-source-pathname* - (pathname "/src/local/clx/*.l")) - -(defvar *clx-binary-pathname* - (let ((lisp - (or #+lucid "lucid" - #+akcl "akcl" - #+kcl "kcl" - #+ibcl "ibcl" - (error "Can't provide CLX for this lisp."))) - (architecture - (or #+(or sun3 (and sun (or mc68000 mc68020))) "sun3" - #+(or sun4 sparc) "sparc" - #+(and hp (or mc68000 mc68020)) "hp9000s300" - #+vax "vax" - #+prime "prime" - #+sunrise "sunrise" - #+ibm-rt-pc "ibm-rt-pc" - #+mips "mips" - #+prism "prism" - (error "Can't provide CLX for this architecture.")))) - (pathname (format nil "/src/local/clx/~A.~A/" lisp architecture)))) - -(defvar *compile-clx* - nil) - -(load (merge-pathnames "defsystem" *clx-source-pathname*)) - -(if *compile-clx* - (compile-clx *clx-source-pathname* *clx-binary-pathname*) - (load-clx *clx-binary-pathname*)) -) \ No newline at end of file View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/ab34d94e0f317fa75f8b5b87b… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/ab34d94e0f317fa75f8b5b87b… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-update-clx-with-cmucl-fixes] 3 commits: Fix #73: Update clx from upstream clx
by Raymond Toy 30 Dec '18

30 Dec '18

Raymond Toy pushed to branch rtoy-update-clx-with-cmucl-fixes at cmucl / cmucl Commits: 6453d716 by Raymond Toy at 2018-12-17T17:30:57Z Fix #73: Update clx from upstream clx - - - - - 04c1bee3 by Raymond Toy at 2018-12-17T17:30:57Z Merge branch 'rtoy-update-clx-with-cmucl-fixes' into 'master' Fix #73: Update clx from upstream clx Closes #73 See merge request cmucl/cmucl!44 - - - - - f269c092 by Raymond Toy at 2018-12-30T01:29:59Z Merge branch 'master' into rtoy-update-clx-with-cmucl-fixes - - - - - 0 changed files: Changes: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/5e075fa01a55c4022fa9277b… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/5e075fa01a55c4022fa9277b… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][upstream-clx] Update to sharplispers/clx commit 021f5d7
by Raymond Toy 30 Dec '18

30 Dec '18

Raymond Toy pushed to branch upstream-clx at cmucl / cmucl Commits: 640f90eb by Raymond Toy at 2018-12-30T01:29:29Z Update to sharplispers/clx commit 021f5d7 - - - - - 5 changed files: - src/clx/clx.asd - src/clx/demo/clx-demos.lisp - src/clx/demo/menu.lisp - src/clx/dependent.lisp - src/clx/provide.lisp Changes: ===================================== src/clx/clx.asd ===================================== @@ -116,7 +116,8 @@ Independent FOSS developers" :components ((:module "demo" :components - ((:file "bezier") + ((:file "menu") + (:file "bezier") (:file "beziertest" :depends-on ("bezier")) (:file "clclock") (:file "clipboard") @@ -126,7 +127,6 @@ Independent FOSS developers" ;; deletion notes. Find out why, and either fix or ;; workaround the problem. (:file "mandel") - (:file "menu") (:file "zoid") (:file "image") (:file "trapezoid" :depends-on ("zoid")))))) ===================================== src/clx/demo/clx-demos.lisp ===================================== @@ -5,9 +5,15 @@ ;;; ;;; This file should be portable to any valid Common Lisp with CLX -- DEC 88. ;;; +;;; CMUCL MP support by Douglas Crosher 1998. +;;; Enhancements including the CLX menu, rewrite of the greynetic +;;; demo, and other fixes by Fred Gilham 1998. +;;; +;;; Backported some changes found in CMUCL repository -- jd 2018-12-29. -(defpackage #:xlib-demo/demos (:use :common-lisp) - (:export do-all-demos demo)) +(defpackage #:xlib-demo/demos + (:use :common-lisp) + (:export #:demo)) (in-package :xlib-demo/demos) @@ -21,6 +27,7 @@ ;;; it is running. (defparameter *demos* nil) +(defparameter *delay* 0.5) (defvar *display* nil) (defvar *screen* nil) @@ -33,105 +40,82 @@ `(progn (defun ,fun-name ,args ,doc - (unless *display* - #+:cmu - (multiple-value-setq (*display* *screen*) (ext:open-clx-display)) - #+(or sbcl allegro clisp lispworks) - (progn - (setf *display* (xlib::open-default-display)) - (setf *screen* (xlib:display-default-screen *display*))) - #-(or cmu sbcl allegro clisp lispworks) - (progn - ;; Portable method - (setf *display* (xlib:open-display (machine-instance))) - (setf *screen* (xlib:display-default-screen *display*))) - (setf *root* (xlib:screen-root *screen*)) - (setf *black-pixel* (xlib:screen-black-pixel *screen*)) - (setf *white-pixel* (xlib:screen-white-pixel *screen*))) - (let ((*window* (xlib:create-window :parent *root* - :x ,x :y ,y - :event-mask nil - :width ,width :height ,height - :background *white-pixel* - :border *black-pixel* - :border-width 2 - :override-redirect :on))) + (let* ((*display* (or *display* + (xlib:open-default-display) + (xlib:open-display (machine-instance)))) + (*screen* (xlib:display-default-screen *display*)) + (*root* (xlib:screen-root *screen*)) + (*black-pixel* (xlib:screen-black-pixel *screen*)) + (*white-pixel* (xlib:screen-white-pixel *screen*)) + (*window* (xlib:create-window :parent *root* + :x ,x :y ,y + :event-mask '(:visibility-change) + :width ,width :height ,height + :background *white-pixel* + :border *black-pixel* + :border-width 2 + :override-redirect :off))) + (xlib:set-wm-properties *window* + :name ,demo-name + :icon-name ,demo-name + :resource-name ,demo-name + :x ,x :y ,y :width ,width :height ,height + :user-specified-position-p t + :user-specified-size-p t + :min-width ,width :min-height ,height + :width-inc nil :height-inc nil) (xlib:map-window *window*) - ;; - ;; I hate to do this since this is not something any normal - ;; program should do ... - (setf (xlib:window-priority *window*) :above) - (xlib:display-finish-output *display*) - (unwind-protect - (progn ,@forms) - (xlib:unmap-window *window*) - (xlib:display-finish-output *display*)))) + ;; Wait until we get mapped before doing anything. + (xlib:display-finish-output *display*) + (unwind-protect (progn ,@forms) + (xlib:display-finish-output *display*) + (xlib:unmap-window *window*)))) (setf (get ',fun-name 'demo-name) ',demo-name) (setf (get ',fun-name 'demo-doc) ',doc) - (export ',fun-name) (pushnew ',fun-name *demos*) ',fun-name)) -;;;; Main entry points. - -(defun do-all-demos () - (loop - (dolist (demo *demos*) - (funcall demo) - (sleep 3)))) - -;;; DEMO is a hack to get by. It should be based on creating a menu. At -;;; that time, *name-to-function* should be deleted, since this mapping will -;;; be manifested in the menu slot name cross its action. Also the -;;; "Shove-bounce" demo should be renamed to "Shove bounce"; likewise for -;;; "Fast-towers-of-Hanoi" and "Slow-towers-of-hanoi". -;;; +;;; DEMO (defvar *name-to-function* (make-hash-table :test #'eq)) (defvar *keyword-package* (find-package "KEYWORD")) +(defvar *demo-names* nil) (defun demo () - (macrolet ((read-demo () - `(let ((*package* *keyword-package*)) - (read)))) + (let ((*demo-names* '("Quit"))) (dolist (d *demos*) (setf (gethash (intern (string-upcase (get d 'demo-name)) *keyword-package*) *name-to-function*) - d)) - (loop - (fresh-line) - (dolist (d *demos*) - (write-string " ") - (write-line (get d 'demo-name))) - (write-string " ") - (write-line "Help <demo name>") - (write-string " ") - (write-line "Quit") - (write-string "Enter demo name: ") - (let ((demo (read-demo))) - (case demo - (:help - (let* ((demo (read-demo)) - (fun (gethash demo *name-to-function*))) - (fresh-line) - (if fun - (format t "~&~%~A~&~%" (get fun 'demo-doc)) - (format t "Unknown demo name -- ~A." demo)))) - (:quit (return t)) - (t - (let ((fun (gethash demo *name-to-function*))) - (if fun - #+mp - (mp:make-process #'(lambda () - (loop - (funcall fun) - (sleep 2))) - :name (format nil "~S" demo)) - #-mp - (funcall fun) - (format t "~&~%Unknown demo name -- ~A.~&~%" demo))))))))) + d) + (push (get d 'demo-name) *demo-names*)) + + (let* ((display (xlib:open-default-display)) + (screen (xlib:display-default-screen display)) + (fg-color (xlib:screen-white-pixel screen)) + (bg-color (xlib:screen-black-pixel screen)) + (nice-font (xlib:open-font display "fixed"))) + + (let ((a-menu (xlib::create-menu + (xlib::screen-root screen) ;the menu's parent + fg-color bg-color nice-font))) + + (setf (xlib::menu-title a-menu) "Please pick your favorite demo:") + (xlib::menu-set-item-list a-menu *demo-names*) + (ignore-errors ;; closing window is not handled properly in menu. + (unwind-protect + (do ((choice (xlib::menu-choose a-menu 100 100) + (xlib::menu-choose a-menu 100 100))) + ((and choice (string-equal "Quit" choice))) + (let* ((demo-choice (intern (string-upcase choice) + *keyword-package*)) + (fun (gethash demo-choice *name-to-function*))) + (setf choice nil) + (when fun + (ignore-errors (funcall fun))))) + (xlib:display-finish-output display) + (xlib:close-display display))))))) ;;;; Shared demo utilities. @@ -143,60 +127,124 @@ (xlib:window-map-state w)))) -;;;; Greynetic. - -;;; GREYNETIC displays random sized and shaded boxes in a window. This is -;;; real slow. It needs work. -;;; -(defun greynetic (window duration) - (let* ((pixmap (xlib:create-pixmap :width 32 :height 32 :depth 1 - :drawable window)) - (gcontext (xlib:create-gcontext :drawable window - :background *white-pixel* - :foreground *black-pixel* - :tile pixmap - :fill-style :tiled))) - (multiple-value-bind (width height) (full-window-state window) - (dotimes (i duration) - (let* ((pixmap-data (greynetic-pixmapper)) - (image (xlib:create-image :width 32 :height 32 - :depth 1 :data pixmap-data))) - (xlib:put-image pixmap gcontext image :x 0 :y 0 :width 32 :height 32) - (xlib:draw-rectangle window gcontext - (- (random width) 5) - (- (random height) 5) - (+ 4 (random (truncate width 3))) - (+ 4 (random (truncate height 3))) - t)) - (xlib:display-force-output *display*))) - (xlib:free-gcontext gcontext) - (xlib:free-pixmap pixmap))) - -(defvar *greynetic-pixmap-array* - (make-array '(32 32) :initial-element 0 :element-type 'xlib:pixel)) - -(defun greynetic-pixmapper () - (let ((pixmap-data *greynetic-pixmap-array*)) +(defun make-random-bitmap () + (let ((bitmap-data (make-array '(32 32) :initial-element 0 + :element-type 'xlib::bit))) (dotimes (i 4) (declare (fixnum i)) (let ((nibble (random 16))) - (setf nibble (logior nibble (ash nibble 4)) - nibble (logior nibble (ash nibble 8)) - nibble (logior nibble (ash nibble 12)) - nibble (logior nibble (ash nibble 16))) - (dotimes (j 32) - (let ((bit (if (logbitp j nibble) 1 0))) - (setf (aref pixmap-data i j) bit - (aref pixmap-data (+ 4 i) j) bit - (aref pixmap-data (+ 8 i) j) bit - (aref pixmap-data (+ 12 i) j) bit - (aref pixmap-data (+ 16 i) j) bit - (aref pixmap-data (+ 20 i) j) bit - (aref pixmap-data (+ 24 i) j) bit - (aref pixmap-data (+ 28 i) j) bit))))) - pixmap-data)) - -#+nil + (setf nibble (logior nibble (ash nibble 4)) + nibble (logior nibble (ash nibble 8)) + nibble (logior nibble (ash nibble 12)) + nibble (logior nibble (ash nibble 16))) + (dotimes (j 32) + (let ((bit (if (logbitp j nibble) 1 0))) + (setf (aref bitmap-data i j) bit + (aref bitmap-data (+ 4 i) j) bit + (aref bitmap-data (+ 8 i) j) bit + (aref bitmap-data (+ 12 i) j) bit + (aref bitmap-data (+ 16 i) j) bit + (aref bitmap-data (+ 20 i) j) bit + (aref bitmap-data (+ 24 i) j) bit + (aref bitmap-data (+ 28 i) j) bit))))) + bitmap-data)) + + +(defun make-random-pixmap () + (let ((image (xlib:create-image :depth 1 :data (make-random-bitmap)))) + (make-pixmap image 32 32))) + +(defvar *pixmaps* nil) + +(defun make-pixmap (image width height) + (let* ((pixmap (xlib:create-pixmap :width width :height height + :depth 1 :drawable *root*)) + (gc (xlib:create-gcontext :drawable pixmap + :background *black-pixel* + :foreground *white-pixel*))) + (xlib:put-image pixmap gc image :x 0 :y 0 :width width :height height) + (xlib:free-gcontext gc) + pixmap)) + + +;;; +;;; This function returns one of the pixmaps in the *pixmaps* array. +(defun greynetic-pixmapper () + (aref *pixmaps* (random (length *pixmaps*)))) + + +(defun greynetic (window duration) + (let* ((depth (xlib:drawable-depth window)) + (draw-gcontext (xlib:create-gcontext :drawable window + :foreground *white-pixel* + :background *black-pixel*)) + ;; Need a random state per process. + (*random-state* (make-random-state t)) + (*pixmaps* (let ((pixmap-array (make-array 30))) + (dotimes (i 30) + (setf (aref pixmap-array i) (make-random-pixmap))) + pixmap-array))) + + (unwind-protect + (multiple-value-bind (width height) (full-window-state window) + (declare (fixnum width height)) + (let ((border-x (truncate width 20)) + (border-y (truncate height 20))) + (declare (fixnum border-x border-y)) + (dotimes (i duration) + (let ((pixmap (greynetic-pixmapper))) + (xlib:with-gcontext (draw-gcontext + :foreground (random (ash 1 depth)) + :background (random (ash 1 depth)) + :stipple pixmap + :fill-style + :opaque-stippled) + (cond ((zerop (mod i 500)) + (xlib:clear-area window) + (sleep .1)) + (t + (sleep *delay*))) + (if (< (random 3) 2) + (let* ((w (+ border-x + (truncate (* (random (- width + (* 2 border-x))) + (random width)) width))) + (h (+ border-y + (truncate (* (random (- height + (* 2 border-y))) + (random height)) height))) + (x (random (- width w))) + (y (random (- height h)))) + (declare (fixnum w h x y)) + (if (zerop (random 2)) + (xlib:draw-rectangle window draw-gcontext + x y w h t) + (xlib:draw-arc window draw-gcontext + x y w h 0 (* 2 pi) t))) + (let ((p1-x (+ border-x + (random (- width (* 2 border-x))))) + (p1-y (+ border-y + (random (- height (* 2 border-y))))) + (p2-x (+ border-x + (random (- width (* 2 border-x))))) + (p2-y (+ border-y + (random (- height (* 2 border-y))))) + (p3-x (+ border-x + (random (- width (* 2 border-x))))) + (p3-y (+ border-y + (random (- height (* 2 border-y)))))) + (declare (fixnum p1-x p1-y p2-x p2-y p3-x p3-y)) + (xlib:draw-lines window draw-gcontext + (list p1-x p1-y p2-x p2-y p3-x p3-y) + :relative-p nil + :fill-p t + :shape :convex))) + (xlib:display-force-output *display*)))))) + (dotimes (i (length *pixmaps*)) + (xlib:free-pixmap (aref *pixmaps* i))) + (xlib:free-gcontext draw-gcontext)))) + + (defdemo greynetic-demo "Greynetic" (&optional (duration 300)) 100 100 600 600 "Displays random grey rectangles." @@ -677,6 +725,7 @@ start-needle end-needle) end-needle) + (sleep *delay*) t) ;;; Move-N-Disks moves the top N disks from START-NEEDLE to END-NEEDLE @@ -775,27 +824,28 @@ (when (= prev-neg-velocity 0) (return t)) (let ((negative-velocity (minusp y-velocity))) (loop - (let ((next-y (+ y y-velocity)) - (next-y-velocity (+ y-velocity gravity))) - (declare (fixnum next-y next-y-velocity)) - (when (> next-y top-of-window-at-bottom) - (cond - (number-problems - (setf y-velocity (incf prev-neg-velocity))) - (t - (setq y-velocity - (- (truncate (* elasticity y-velocity)))) - (when (= y-velocity prev-neg-velocity) - (incf y-velocity) - (setf number-problems t)) - (setf prev-neg-velocity y-velocity))) - (setf y top-of-window-at-bottom) - (setf (xlib:drawable-x window) x - (xlib:drawable-y window) y) - (xlib:display-force-output *display*) - (return)) - (setq y-velocity next-y-velocity) - (setq y next-y)) + (let ((next-y (+ y y-velocity)) + (next-y-velocity (+ y-velocity gravity))) + (declare (fixnum next-y next-y-velocity)) + (when (> next-y top-of-window-at-bottom) + (cond + (number-problems + (setf y-velocity (incf prev-neg-velocity))) + (t + (setq y-velocity + (- (truncate (* elasticity y-velocity)))) + (when (= y-velocity prev-neg-velocity) + (incf y-velocity) + (setf number-problems t)) + (setf prev-neg-velocity y-velocity))) + (setf y top-of-window-at-bottom) + (setf (xlib:drawable-x window) x + (xlib:drawable-y window) y) + (xlib:display-force-output *display*) + (return)) + (setq y-velocity next-y-velocity) + (setq y next-y) + (sleep (/ *delay* 100))) (when (and negative-velocity (>= y-velocity 0)) (setf negative-velocity nil)) (let ((next-x (+ x x-velocity))) @@ -814,7 +864,7 @@ 100 100 300 300 "Drops the demo window with an inital X velocity which bounces off screen borders." - (bounce-window *window* 30)) + (bounce-window *window* 3)) (defdemo bounce-demo "Bounce" () 100 100 300 300 @@ -846,8 +896,8 @@ (multiple-value-bind (width height) (full-window-state window) (xlib:clear-area window) (draw-ppict window gc point-count 0.0 0.0 (* width 0.5) (* height 0.5)) - (xlib:display-force-output display) - (sleep 4)) + (xlib:display-finish-output display) + (sleep 1)) (xlib:free-gcontext gc))) ;;; Draw points. X assumes points are in the range of width x height, @@ -892,8 +942,8 @@ :function boole-c2 :plane-mask (logxor *white-pixel* *black-pixel*) - :background *white-pixel* - :foreground *black-pixel* + :background *black-pixel* + :foreground *white-pixel* :fill-style :solid)) (rectangles (make-array (* 4 num-rectangles) :element-type 'number @@ -920,6 +970,7 @@ (decf y-off (ash y-dir 1)) (setf y-dir (- y-dir)))) (xlib:draw-rectangles window gcontext rectangles t) + (sleep *delay*) (xlib:display-force-output display)))) (xlib:free-gcontext gcontext))) @@ -938,9 +989,12 @@ (defvar *ball-size-x* 38) (defvar *ball-size-y* 34) -(defmacro xor-ball (pixmap window gcontext x y) - `(xlib:copy-area ,pixmap ,gcontext 0 0 *ball-size-x* *ball-size-y* - ,window ,x ,y)) +(defun xor-ball (pixmap window gcontext x y) + (xlib:copy-plane pixmap gcontext 1 + 0 0 + *ball-size-x* *ball-size-y* + window + x y)) (defconstant bball-gravity 1) (defconstant maximum-x-drift 7) @@ -1016,7 +1070,7 @@ (defun bounce-balls (display window how-many duration) (xlib:clear-area window) - (xlib:display-force-output display) + (xlib:display-finish-output display) (multiple-value-bind (*max-bball-x* *max-bball-y*) (full-window-state window) (let* ((balls (do ((i 0 (1+ i)) (list () (cons (make-ball) list))) @@ -1036,16 +1090,16 @@ (xlib:free-gcontext pixmap-gc) (dolist (ball balls) (xor-ball bounce-pixmap window gcontext (ball-x ball) (ball-y ball))) - (xlib:display-force-output display) + (xlib:display-finish-output display) (dotimes (i duration) (dolist (ball balls) - (bounce-1-ball bounce-pixmap window gcontext ball)) - (xlib:display-force-output display)) + (bounce-1-ball bounce-pixmap window gcontext ball) + (xlib:display-finish-output display)) + (sleep (/ *delay* 50.0))) (xlib:free-pixmap bounce-pixmap) (xlib:free-gcontext gcontext)))) -#+nil (defdemo bouncing-ball-demo "Bouncing-Ball" (&optional (how-many 5) (duration 500)) - 34 34 700 500 + 36 34 700 500 "Bouncing balls in space." (bounce-balls *display* *window* how-many duration)) ===================================== src/clx/demo/menu.lisp ===================================== @@ -27,7 +27,8 @@ ;;; | ;;;----------------------------------------------------------------------------------+ - +;;; Some changes are backported from CMUCL CLX source (our implementation had +;;; errors when we tried to use menu). This one is a little shorter. (defstruct (menu) "A simple menu of text strings." @@ -45,29 +46,27 @@ (defun create-menu (parent-window text-color background-color text-font) (make-menu - ;; Create menu graphics context - :gcontext (CREATE-GCONTEXT :drawable parent-window - :foreground text-color - :background background-color - :font text-font) - ;; Create menu window - :window (CREATE-WINDOW - :parent parent-window - :class :input-output - :x 0 ;temporary value - :y 0 ;temporary value - :width 16 ;temporary value - :height 16 ;temporary value - :border-width 2 - :border text-color - :background background-color - :save-under :on - :override-redirect :on ;override window mgr when positioning - :event-mask (MAKE-EVENT-MASK :leave-window - :exposure)))) - - -(defun menu-set-item-list (menu &rest item-strings) + ;; Create menu graphics context + :gcontext (CREATE-GCONTEXT :drawable parent-window + :foreground text-color + :background background-color + :font text-font) + ;; Create menu window + :window (CREATE-WINDOW + :parent parent-window + :class :input-output + :x 0 ;temporary value + :y 0 ;temporary value + :width 16 ;temporary value + :height 16 ;temporary value + :border-width 2 + :border text-color + :background background-color + :save-under :on + ;; :override-redirect :on ;override window mgr when positioning + :event-mask (MAKE-EVENT-MASK :leave-window :exposure)))) + +(defun menu-set-item-list (menu item-strings) ;; Assume the new items will change the menu's width and height (setf (menu-geometry-changed-p menu) t) @@ -148,7 +147,11 @@ (defun menu-refresh (menu) - (let* ((gcontext (menu-gcontext menu)) + (xlib:set-wm-properties (menu-window menu) + :name (menu-title menu) + :icon-name (menu-title menu) + :resource-name (menu-title menu)) + (let* ((gcontext (menu-gcontext menu)) (baseline-y (FONT-ASCENT (GCONTEXT-FONT gcontext)))) ;; Show title centered in "reverse-video" @@ -217,7 +220,7 @@ t))) ;; Erase the menu - (UNMAP-WINDOW mw) +;;; (UNMAP-WINDOW mw) ;; Return selected item string, if any (unless (eq selected-item :none) selected-item))) @@ -272,111 +275,3 @@ ;; Make menu visible (MAP-WINDOW menu-window))) - -(defun just-say-lisp (&optional (font-name "fixed")) - (let* ((display (open-default-display)) - (screen (first (DISPLAY-ROOTS display))) - (fg-color (SCREEN-BLACK-PIXEL screen)) - (bg-color (SCREEN-WHITE-PIXEL screen)) - (nice-font (OPEN-FONT display font-name)) - (a-menu (create-menu (screen-root screen) ;the menu's parent - fg-color bg-color nice-font))) - - (setf (menu-title a-menu) "Please pick your favorite language:") - (menu-set-item-list a-menu "Fortran" "APL" "Forth" "Lisp") - - ;; Bedevil the user until he picks a nice programming language - (unwind-protect - (do (choice) - ((and (setf choice (menu-choose a-menu 100 100)) - (string-equal "Lisp" choice)))) - - (CLOSE-DISPLAY display)))) - - -(defun pop-up (host strings &key (title "Pick one:") (font "fixed")) - (let* ((display (OPEN-DISPLAY host)) - (screen (first (DISPLAY-ROOTS display))) - (fg-color (SCREEN-BLACK-PIXEL screen)) - (bg-color (SCREEN-WHITE-PIXEL screen)) - (font (OPEN-FONT display font)) - (parent-width 400) - (parent-height 400) - (parent (CREATE-WINDOW :parent (SCREEN-ROOT screen) - :override-redirect :on - :x 100 :y 100 - :width parent-width :height parent-height - :background bg-color - :event-mask (MAKE-EVENT-MASK :button-press - :exposure))) - (a-menu (create-menu parent fg-color bg-color font)) - (prompt "Press a button...") - (prompt-gc (CREATE-GCONTEXT :drawable parent - :foreground fg-color - :background bg-color - :font font)) - (prompt-y (FONT-ASCENT font)) - (ack-y (- parent-height (FONT-DESCENT font)))) - - (setf (menu-title a-menu) title) - (apply #'menu-set-item-list a-menu strings) - - ;; Present main window - (MAP-WINDOW parent) - - (flet ((display-centered-text - (window string gcontext height width) - (multiple-value-bind (w a d l r fa fd) (text-extents gcontext string) - (declare (ignore a d l r)) - (let ((box-height (+ fa fd))) - - ;; Clear previous text - (CLEAR-AREA window - :x 0 :y (- height fa) - :width width :height box-height) - - ;; Draw new text - (DRAW-IMAGE-GLYPHS window gcontext (round (- width w) 2) height string))))) - - (unwind-protect - (loop - (EVENT-CASE (display :force-output-p t) - - (:exposure (count) - - ;; Display prompt - (when (zerop count) - (display-centered-text - parent - prompt - prompt-gc - prompt-y - parent-width)) - t) - - (:button-press (x y) - - ;; Pop up the menu - (let ((choice (menu-choose a-menu x y))) - (if choice - (display-centered-text - parent - (format nil "You have selected ~a." choice) - prompt-gc - ack-y - parent-width) - - (display-centered-text - parent - "No selection...try again." - prompt-gc - ack-y - parent-width))) - t) - - (otherwise () - ;;Ignore and discard any other event - t))) - - (CLOSE-DISPLAY display))))) - ===================================== src/clx/dependent.lisp ===================================== @@ -1061,36 +1061,56 @@ ;;; :TIMEOUT if it times out, NIL otherwise. ;;; The default implementation - -;; Poll for input every *buffer-read-polling-time* SECONDS. -#-(or CMU sbcl) -(defparameter *buffer-read-polling-time* 0.5) - -#-(or CMU sbcl clisp) +#-(or cmu sbcl clisp (and ecl serve-event)) +(progn + ;; Issue a warning to incentivize providing better implementation. + (eval-when (:compile-toplevel :load-toplevel :execute) + (warn "XLIB::BUFFER-INPUT-WAIT-DEFAULT: timeout polling used.")) + ;; Poll for input every *buffer-read-polling-time* SECONDS. + (defparameter *buffer-read-polling-time* 0.01) + (defun buffer-input-wait-default (display timeout) + (declare (type display display) + (type (or null (real 0 *)) timeout)) + (declare (clx-values timeout)) + (let ((stream (display-input-stream display))) + (declare (type (or null stream) stream)) + (cond ((null stream)) + ((listen stream) nil) + ((and timeout (= timeout 0)) :timeout) + ((not (null timeout)) + (multiple-value-bind (npoll fraction) + (truncate timeout *buffer-read-polling-time*) + (dotimes (i npoll) ; Sleep for a time, then listen again + (sleep *buffer-read-polling-time*) + (when (listen stream) + (return-from buffer-input-wait-default nil))) + (when (plusp fraction) + (sleep fraction) ; Sleep a fraction of a second + (when (listen stream) ; and listen one last time + (return-from buffer-input-wait-default nil))) + :timeout)))))) + +#+(and ecl serve-event) (defun buffer-input-wait-default (display timeout) (declare (type display display) - (type (or null (real 0 *)) timeout)) - (declare (clx-values timeout)) - + (type (or null number) timeout)) (let ((stream (display-input-stream display))) (declare (type (or null stream) stream)) (cond ((null stream)) ((listen stream) nil) - ((and timeout (= timeout 0)) :timeout) - ((not (null timeout)) - (multiple-value-bind (npoll fraction) - (truncate timeout *buffer-read-polling-time*) - (dotimes (i npoll) ; Sleep for a time, then listen again - (sleep *buffer-read-polling-time*) - (when (listen stream) - (return-from buffer-input-wait-default nil))) - (when (plusp fraction) - (sleep fraction) ; Sleep a fraction of a second - (when (listen stream) ; and listen one last time - (return-from buffer-input-wait-default nil))) - :timeout))))) - -#+(or CMU sbcl clisp) + ((eql timeout 0) :timeout) + (T (flet ((usable! (fd) + (declare (ignore fd)) + (return-from buffer-input-wait-default))) + (serve-event:with-fd-handler ((ext:file-stream-fd + (typecase stream + (two-way-stream (two-way-stream-input-stream stream)) + (otherwise stream))) + :input #'usable!) + (serve-event:serve-event timeout))) + :timeout)))) + +#+(or cmu sbcl clisp) (defun buffer-input-wait-default (display timeout) (declare (type display display) (type (or null number) timeout)) @@ -1099,18 +1119,14 @@ (cond ((null stream)) ((listen stream) nil) ((eql timeout 0) :timeout) - (t - (if #+sbcl (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream) - :input timeout) - #+mp (mp:process-wait-until-fd-usable - (system:fd-stream-fd stream) :input timeout) + ;; MP package protocol may be shared between clisp and cmu. + ((or #+sbcl (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream) :input timeout) + #+mp (mp:process-wait-until-fd-usable (system:fd-stream-fd stream) :input timeout) #+clisp (multiple-value-bind (sec usec) (floor (or timeout 0)) - (ext:socket-status stream (and timeout sec) - (round usec 1d-6))) - #-(or sbcl mp clisp) (system:wait-until-fd-usable - (system:fd-stream-fd stream) :input timeout) - nil - :timeout))))) + (ext:socket-status stream (and timeout sec) (round usec 1d-6))) + #+cmu (system:wait-until-fd-usable (system:fd-stream-fd stream) :input timeout)) + nil) + (T :timeout)))) ;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the ;;; buffer. This should never block, so it can be called from the scheduler. ===================================== src/clx/provide.lisp ===================================== @@ -17,35 +17,3 @@ (in-package :common-lisp-user) (provide :clx) - -(defvar *clx-source-pathname* - (pathname "/src/local/clx/*.l")) - -(defvar *clx-binary-pathname* - (let ((lisp - (or #+lucid "lucid" - #+akcl "akcl" - #+kcl "kcl" - #+ibcl "ibcl" - (error "Can't provide CLX for this lisp."))) - (architecture - (or #+(or sun3 (and sun (or mc68000 mc68020))) "sun3" - #+(or sun4 sparc) "sparc" - #+(and hp (or mc68000 mc68020)) "hp9000s300" - #+vax "vax" - #+prime "prime" - #+sunrise "sunrise" - #+ibm-rt-pc "ibm-rt-pc" - #+mips "mips" - #+prism "prism" - (error "Can't provide CLX for this architecture.")))) - (pathname (format nil "/src/local/clx/~A.~A/" lisp architecture)))) - -(defvar *compile-clx* - nil) - -(load (merge-pathnames "defsystem" *clx-source-pathname*)) - -(if *compile-clx* - (compile-clx *clx-source-pathname* *clx-binary-pathname*) - (load-clx *clx-binary-pathname*)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/640f90eba0b045c93c116fa55… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/640f90eba0b045c93c116fa55… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #73: Update clx from upstream clx
by Raymond Toy 17 Dec '18

17 Dec '18

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 6453d716 by Raymond Toy at 2018-12-17T17:30:57Z Fix #73: Update clx from upstream clx - - - - - 04c1bee3 by Raymond Toy at 2018-12-17T17:30:57Z Merge branch 'rtoy-update-clx-with-cmucl-fixes' into 'master' Fix #73: Update clx from upstream clx Closes #73 See merge request cmucl/cmucl!44 - - - - - 29 changed files: - src/clx/CHANGES - src/clx/NEWS - src/clx/README-R5 - + src/clx/README.md - + src/clx/ci-doc-gh-pages.sh - src/clx/clx.asd - src/clx/debug/debug.lisp - src/clx/debug/describe.lisp - src/clx/debug/event-test.lisp - src/clx/debug/keytrans.lisp - src/clx/debug/trace.lisp - src/clx/debug/util.lisp - + src/clx/demo/image.lisp - + src/clx/demo/trapezoid.lisp - src/clx/dep-allegro.lisp - src/clx/dep-lispworks.lisp - src/clx/dep-openmcl.lisp - src/clx/depdefs.lisp - src/clx/dependent.lisp - src/clx/exclMakefile - src/clx/exclREADME - src/clx/excldep.c - + src/clx/extensions/composite.lisp - + src/clx/extensions/dbe.lisp - + src/clx/extensions/dri2.lisp - + src/clx/extensions/randr.lisp - src/clx/extensions/shape.lisp - + src/clx/extensions/xc-misc.lisp - src/clx/extensions/xrender.lisp The diff was not included because it is too large. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/d94877687e6deab2f08d066f… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/d94877687e6deab2f08d066f… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0