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

[Git][cmucl/cmucl] Pushed new tag snapshot-2017-10
by Raymond Toy 30 Jan '18

30 Jan '18

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

1 0

[Git][cmucl/cmucl][master] Move defsystem for pcl-tests to its own file.
by Raymond Toy 30 Jan '18

30 Jan '18

Raymond Toy pushed to branch master at cmucl / cmucl Commits: a368558e by Raymond Toy at 2017-10-08T15:17:59-07:00 Move defsystem for pcl-tests to its own file. The upgrade to ASDF 3.3.0 broke the pcl-tests; this version doesn't like having the defsystem in the same file. Thus, move the defsystem to its own file and load it up in pcl.lisp (via require). - - - - - 2 changed files: - + tests/pcl-tests.asd - tests/pcl.lisp Changes: ===================================== tests/pcl-tests.asd ===================================== --- /dev/null +++ b/tests/pcl-tests.asd @@ -0,0 +1,39 @@ +;;; -*- Mode: lisp -*- + +(asdf:defsystem :pcl-tests + :pathname "pcl/" + :components + ((:file "pkg") + #+gerds-pcl + (:file "ctor" + :depends-on ("pkg")) + (:file "defclass" + :depends-on ("pkg")) + (:file "make-instance" + :depends-on ("pkg" #+gerds-pcl "ctor")) + (:file "reinitialize-instance" + :depends-on ("pkg" "make-instance")) + (:file "slot-value" + :depends-on ("pkg" "make-instance")) + (:file "slot-boundp" + :depends-on ("pkg" "make-instance")) + (:file "slot-missing" + :depends-on ("pkg" "make-instance")) + (:file "slot-accessors" + :depends-on ("pkg" "make-instance")) + (:file "slot-type" + :depends-on ("pkg" "slot-value")) + (:file "inline-access" + :depends-on ("pkg" "slot-type")) + (:file "method-combination" + :depends-on ("pkg")) + (:file "pv" + :depends-on ("pkg")) + (:file "defgeneric" + :depends-on ("pkg")) + (:file "defmethod" + :depends-on ("pkg")) + (:file "find-method" + :depends-on ("pkg")) + (:file "methods" + :depends-on ("pkg")))) ===================================== tests/pcl.lisp ===================================== --- a/tests/pcl.lisp +++ b/tests/pcl.lisp @@ -26,42 +26,11 @@ (merge-pathnames #p"pcl/*.*" *load-truename*)))) -(asdf:defsystem :pcl-test - :pathname "pcl/" - :components - ((:file "pkg") - #+gerds-pcl - (:file "ctor" - :depends-on ("pkg")) - (:file "defclass" - :depends-on ("pkg")) - (:file "make-instance" - :depends-on ("pkg" #+gerds-pcl "ctor")) - (:file "reinitialize-instance" - :depends-on ("pkg" "make-instance")) - (:file "slot-value" - :depends-on ("pkg" "make-instance")) - (:file "slot-boundp" - :depends-on ("pkg" "make-instance")) - (:file "slot-missing" - :depends-on ("pkg" "make-instance")) - (:file "slot-accessors" - :depends-on ("pkg" "make-instance")) - (:file "slot-type" - :depends-on ("pkg" "slot-value")) - (:file "inline-access" - :depends-on ("pkg" "slot-type")) - (:file "method-combination" - :depends-on ("pkg")) - (:file "pv" - :depends-on ("pkg")) - (:file "defgeneric" - :depends-on ("pkg")) - (:file "defmethod" - :depends-on ("pkg")) - (:file "find-method" - :depends-on ("pkg")) - (:file "methods" - :depends-on ("pkg")))) +;; Just smash it with our path so we don't accidentally look up +;; pcl-files somewhere else. +(setf asdf:*central-registry* + (list (make-pathname :directory (pathname-directory *load-pathname*)))) -(asdf:oos 'asdf:load-op :pcl-test) +(require :pcl-tests) + +(asdf:oos 'asdf:load-op :pcl-tests) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/a368558eacabee5d8b099dc07… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/a368558eacabee5d8b099dc07… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #47: Print backquote multiple splices correctly
by Raymond Toy 30 Jan '18

30 Jan '18

Raymond Toy pushed to branch master at cmucl / cmucl Commits: dc4a7e00 by Raymond Toy at 2018-01-28T18:20:20-08:00 Fix #47: Print backquote multiple splices correctly * Print multiple splices correclty without the extra set of parenthesis around each splice. * Add test for this. - - - - - e7f97a5d by Raymond Toy at 2018-01-30T03:04:30+00:00 Merge branch 'rtoy-fix-47-backq-splice-printer' into 'master' Fix #47: Print backquote multiple splices correctly Closes #47 See merge request cmucl/cmucl!33 - - - - - 2 changed files: - src/code/backq.lisp - tests/issues.lisp Changes: ===================================== src/code/backq.lisp ===================================== --- a/src/code/backq.lisp +++ b/src/code/backq.lisp @@ -263,7 +263,8 @@ (backq-unparse (car tail) t))) (push (backq-unparse (car tail)) accum))) (backq-append - (mapcar #'(lambda (el) (backq-unparse el t)) + (mapcar #'(lambda (el) + (car (backq-unparse el t))) (cdr form))) (backq-nconc (mapcar #'(lambda (el) (backq-unparse el :nconc)) ===================================== tests/issues.lisp ===================================== --- a/tests/issues.lisp +++ b/tests/issues.lisp @@ -434,4 +434,12 @@ "./" test-dir-name "ls-link"))))) - + +(define-test issue.47 + (:tag :issues) + (with-standard-io-syntax + (assert-equal "`(,@VARS ,@VARS)" + (with-output-to-string (s) + (write (read-from-string "`(,@vars ,@vars)") + :pretty t + :stream s))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/380759e3d91a1d6517a20254… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/380759e3d91a1d6517a20254… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch rtoy-fix-47-backq-splice-printer
by Raymond Toy 30 Jan '18

30 Jan '18

Raymond Toy pushed new branch rtoy-fix-47-backq-splice-printer at cmucl / cmucl --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/tree/rtoy-fix-47-backq-splice-pr… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Restore ability to compile in mt19937 rng.
by Raymond Toy 28 Jan '18

28 Jan '18

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 380759e3 by Raymond Toy at 2018-01-27T21:59:25-08:00 Restore ability to compile in mt19937 rng. - src/tools/worldbuild.lisp - only compile rand-xoroshiro if :random-xoroshiro is a feature - src/tools/worldload.lisp - only load rand-xoroshiro if :random-xoroshiro is a feature - tests/rng.lisp - Add a quick test that the state vector of the *random-state* has the correct type. - - - - - 3 changed files: - src/tools/worldbuild.lisp - src/tools/worldload.lisp - tests/rng.lisp Changes: ===================================== src/tools/worldbuild.lisp ===================================== --- a/src/tools/worldbuild.lisp +++ b/src/tools/worldbuild.lisp @@ -127,7 +127,6 @@ '("target:code/rand-xoroshiro")) (t '("target:code/rand"))) - "target:code/rand-xoroshiro" "target:code/alieneval" "target:code/c-call" "target:code/sap" ===================================== src/tools/worldload.lisp ===================================== --- a/src/tools/worldload.lisp +++ b/src/tools/worldload.lisp @@ -102,7 +102,6 @@ (maybe-byte-load "code:rand-xoroshiro") #-(or random-mt19937 random-xoroshiro) (maybe-byte-load "code:rand") -(maybe-byte-load "code:rand-xoroshiro") (maybe-byte-load "target:pcl/walk") (maybe-byte-load "code:fwrappers") (maybe-byte-load "code:ntrace") ===================================== tests/rng.lisp ===================================== --- a/tests/rng.lisp +++ b/tests/rng.lisp @@ -20,6 +20,13 @@ (defvar *test-state*) +(define-test rng.state + (let ((s (kernel::random-state-state *random-state*))) + #+random-xoroshiro + (assert-true (typep s '(simple-array double-float (2)))) + #+random-mt19937 + (assert-true (typep s '(simple-array (unsigned-byte 32) (627)))))) + #+random-xoroshiro (define-test rng.initial-state (setf *test-state* @@ -56,6 +63,7 @@ (assert-equal value (64-bit-value *test-state*)) (assert-equal state (multiple-value-list (64-bit-rng-state *test-state*)))))) +#+random-xoroshiro (define-test rng.jump (setf *test-state* (kernel::make-random-object :state (kernel::init-random-state #x12345678) @@ -68,3 +76,4 @@ (kernel:random-state-jump *test-state*) (assert-equal result (multiple-value-list (64-bit-rng-state *test-state*))))) + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/380759e3d91a1d6517a202545… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/380759e3d91a1d6517a202545… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 3 commits: Fix #49: CLM crashes
by Raymond Toy 28 Jan '18

28 Jan '18

Raymond Toy pushed to branch master at cmucl / cmucl Commits: b8841170 by Raymond Toy at 2018-01-27T13:04:52-08:00 Fix #49: CLM crashes When invoking motifd, the program name is #p:'library:motifd". This is passed directly to spawn (a C routine), which only accepts strings. So, before calling spawn, convert the program path to a unix namestring. This allows the example from the bug to run without crashing. - - - - - 87c07e5d by Raymond Toy at 2018-01-27T18:19:56-08:00 Make sure spawn is called with a string The previous commit worked for search lists, but the program could be a string. Take care to convert pathnames to strings so that spawn is always called with a string. - - - - - 99eb4311 by Raymond Toy at 2018-01-28T02:54:17+00:00 Merge branch 'rtoy-fix-49-clm-crash' into 'master' Fix #49: CLM crashes Closes #49 See merge request cmucl/cmucl!32 - - - - - 1 changed file: - src/code/run-program.lisp Changes: ===================================== src/code/run-program.lisp ===================================== --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -522,8 +522,18 @@ ;; Make sure all the args are okay. (unless (every #'simple-string-p args) (error (intl:gettext "All args to program must be simple strings -- ~S.") args)) + + ;; Make sure program is a string that we can use with spawn. + (setf program + (if (pathnamep program) + (lisp::with-pathname (p program) + (or (unix::unix-namestring p) + (namestring p))) + (namestring program))) + (check-type program string) + ;; Prepend the program to the argument list. - (push (namestring program) args) + (push program args) ;; Clear random specials used by GET-DESCRIPTOR-FOR to communicate cleanup ;; info. Also, establish proc at this level so we can return it. (let (*close-on-error* *close-in-parent* *handlers-installed* proc) @@ -566,9 +576,10 @@ (cdr entry))) env)) (let ((child-pid - (without-gcing - (spawn program argv envp pty-name - stdin stdout stderr)))) + (without-gcing + (spawn program + argv envp pty-name + stdin stdout stderr)))) (when (< child-pid 0) (error (intl:gettext "Could not fork child process: ~A") (unix:get-unix-error-msg))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/b464fc941ebe07fb0e11ef8d… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/b464fc941ebe07fb0e11ef8d… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-fix-49-clm-crash] Make sure spawn is called with a string
by Raymond Toy 28 Jan '18

28 Jan '18

Raymond Toy pushed to branch rtoy-fix-49-clm-crash at cmucl / cmucl Commits: 87c07e5d by Raymond Toy at 2018-01-27T18:19:56-08:00 Make sure spawn is called with a string The previous commit worked for search lists, but the program could be a string. Take care to convert pathnames to strings so that spawn is always called with a string. - - - - - 1 changed file: - src/code/run-program.lisp Changes: ===================================== src/code/run-program.lisp ===================================== --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -522,8 +522,18 @@ ;; Make sure all the args are okay. (unless (every #'simple-string-p args) (error (intl:gettext "All args to program must be simple strings -- ~S.") args)) + + ;; Make sure program is a string that we can use with spawn. + (setf program + (if (pathnamep program) + (lisp::with-pathname (p program) + (or (unix::unix-namestring p) + (namestring p))) + (namestring program))) + (check-type program string) + ;; Prepend the program to the argument list. - (push (namestring program) args) + (push program args) ;; Clear random specials used by GET-DESCRIPTOR-FOR to communicate cleanup ;; info. Also, establish proc at this level so we can return it. (let (*close-on-error* *close-in-parent* *handlers-installed* proc) @@ -566,10 +576,10 @@ (cdr entry))) env)) (let ((child-pid - (without-gcing - (spawn (unix::unix-namestring program) - argv envp pty-name - stdin stdout stderr)))) + (without-gcing + (spawn program + argv envp pty-name + stdin stdout stderr)))) (when (< child-pid 0) (error (intl:gettext "Could not fork child process: ~A") (unix:get-unix-error-msg))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/87c07e5d7b5c882422bf3089d… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/87c07e5d7b5c882422bf3089d… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch rtoy-fix-49-clm-crash
by Raymond Toy 27 Jan '18

27 Jan '18

Raymond Toy pushed new branch rtoy-fix-49-clm-crash at cmucl / cmucl --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/tree/rtoy-fix-49-clm-crash You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 13 commits: Import "telent" clx
by Raymond Toy 27 Jan '18

27 Jan '18

Raymond Toy pushed to branch master at cmucl / cmucl Commits: c8ebc741 by Raymond Toy at 2018-01-23T19:48:49-08:00 Import "telent" clx This is an import from https://github.com/sharplispers/clx, revision 6e39a0d, unchanged. git describe --tags says: 0.7.4-19-g6e39a0d Not yet tested with cmucl. - - - - - a5964448 by Raymond Toy at 2018-01-23T20:20:54-08:00 Fixes for cmucl bin/build-utils.sh: * Temporarily turn off -batch clx/dependent.lisp: * WITH-ARRAY-DATA is in the LISP package, not KERNEL clx/provide.lisp: * For cmucl, don't compile anything else after (provide :clx) - - - - - c54f706e by Raymond Toy at 2018-01-24T09:40:50-08:00 Put back open-x-stream. Brought back from the master branch. - - - - - c802a375 by Raymond Toy at 2018-01-24T09:41:32-08:00 Disable arglist declaration for cmucl Don't know why this doesn't work, but removing it makes the macro compile correctly. - - - - - 6ea45079 by Raymond Toy at 2018-01-27T09:06:25-08:00 Move these files extensions dir to match upstream clx. [skip-ci] - - - - - e6f4c980 by Raymond Toy at 2018-01-27T09:08:11-08:00 Merge upstream changes. [skip-ci] - - - - - 286801fd by Raymond Toy at 2018-01-27T09:09:49-08:00 Merge branch 'rtoy-update-clx' into rtoy-update-clx-with-cmucl-fixes - - - - - 560af621 by Raymond Toy at 2018-01-27T09:19:42-08:00 Update file paths for clx/extensions Some files were moved to clx/extensions, so need to update the build paths appropriately. - - - - - c1864fe6 by Raymond Toy at 2018-01-27T09:23:20-08:00 Merge upstream demo files [skip-ci] - - - - - f09962e2 by Raymond Toy at 2018-01-27T09:24:57-08:00 Merge branch 'rtoy-update-clx' into rtoy-update-clx-with-cmucl-fixes - - - - - 87bd6d9d by Raymond Toy at 2018-01-27T09:30:02-08:00 Update comments to reflect what we've done. - - - - - d10aa4a6 by Raymond Toy at 2018-01-27T11:42:22-08:00 Add -batch flag back, as it used to be. - - - - - b464fc94 by Raymond Toy at 2018-01-27T19:52:26+00:00 Merge branch 'rtoy-update-clx-with-cmucl-fixes' into 'master' Update clx from upstream Closes #50 See merge request cmucl/cmucl!31 - - - - - 30 changed files: - src/clx/README-CMUCL - src/clx/attributes.lisp - src/clx/buffer.lisp - src/clx/bufmac.lisp - src/clx/build-clx.lisp - src/clx/clx-module.lisp - src/clx/clx.lisp - src/clx/cmudep.lisp - src/clx/defsystem.lisp - src/clx/demo/bezier.lisp - src/clx/demo/beziertest.lisp - src/clx/demo/clclock.lisp - src/clx/demo/clipboard.lisp - src/clx/demo/clx-demos.lisp - src/clx/demo/gl-test.lisp - src/clx/demo/hello.lisp - src/clx/demo/mandel.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/display.lisp - src/clx/excldefsys.lisp - src/clx/excldep.lisp - src/clx/big-requests.lisp → src/clx/extensions/big-requests.lisp - src/clx/dpms.lisp → src/clx/extensions/dpms.lisp - src/clx/gl.lisp → src/clx/extensions/gl.lisp - src/clx/glx.lisp → src/clx/extensions/glx.lisp - src/clx/screensaver.lisp → src/clx/extensions/screensaver.lisp The diff was not included because it is too large. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/631990102d817923c0fadcda… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/631990102d817923c0fadcda… 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] Add -batch flag back, as it used to be.
by Raymond Toy 27 Jan '18

27 Jan '18

Raymond Toy pushed to branch rtoy-update-clx-with-cmucl-fixes at cmucl / cmucl Commits: d10aa4a6 by Raymond Toy at 2018-01-27T11:42:22-08:00 Add -batch flag back, as it used to be. - - - - - 1 changed file: - bin/build-utils.sh Changes: ===================================== bin/build-utils.sh ===================================== --- a/bin/build-utils.sh +++ b/bin/build-utils.sh @@ -16,7 +16,7 @@ TARGET="`echo $1 | sed 's:/*$::'`" shift $TARGET/lisp/lisp \ - -noinit -nositeinit "$@" <<EOF || exit 3 + -noinit -nositeinit -batch "$@" <<EOF || exit 3 (in-package :cl-user) (setf lisp::*enable-package-locked-errors* nil) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/d10aa4a6e7edcf8e6254cb889… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/d10aa4a6e7edcf8e6254cb889… 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: Merge upstream demo files
by Raymond Toy 27 Jan '18

27 Jan '18

Raymond Toy pushed to branch rtoy-update-clx-with-cmucl-fixes at cmucl / cmucl Commits: c1864fe6 by Raymond Toy at 2018-01-27T09:23:20-08:00 Merge upstream demo files [skip-ci] - - - - - f09962e2 by Raymond Toy at 2018-01-27T09:24:57-08:00 Merge branch 'rtoy-update-clx' into rtoy-update-clx-with-cmucl-fixes - - - - - 87bd6d9d by Raymond Toy at 2018-01-27T09:30:02-08:00 Update comments to reflect what we've done. - - - - - 9 changed files: - src/clx/README-CMUCL - src/clx/demo/bezier.lisp - src/clx/demo/beziertest.lisp - src/clx/demo/clclock.lisp - src/clx/demo/clipboard.lisp - src/clx/demo/clx-demos.lisp - src/clx/demo/gl-test.lisp - src/clx/demo/hello.lisp - src/clx/demo/mandel.lisp Changes: ===================================== src/clx/README-CMUCL ===================================== --- a/src/clx/README-CMUCL +++ b/src/clx/README-CMUCL @@ -1,40 +1,9 @@ -$Id: README-CMUCL,v 1.2 2009/06/11 16:03:56 rtoy Rel $ +This is an import of Telent-CLX from the fork +https://github.com/sharplispers/clx, version +6e39a0df2a0a1d083166f405d4b8bbc463d54d85. -This is an import of Telent-CLX as of 0.7.3. +All (almost?) files are included. A few changes to fix bugs related +to CMUCL have been added, as well as the CVS id. I've tried to make +few changes so it will be easy to merge again when desired. -All files are included. A few changes to fix bugs related to CMUCL -have been added, as well as the CVS id. I've tried to make few -changes so it will be easy to merge again when desired. - -The following files from this directory are compiled and loaded by -CMUCL when it builds utilities: - -clx-library.lisp -package.lisp -depdefs.lisp -clx.lisp -dependent.lisp -macros.lisp -bufmac.lisp -buffer.lisp -display.lisp -gcontext.lisp -input.lisp -requests.lisp -fonts.lisp -graphics.lisp -text.lisp -attributes.lisp -translate.lisp -keysyms.lisp -manager.lisp -image.lisp -resource.lisp -shape.lisp -big-requests.lisp -xvidmode.lisp -xrender.lisp -glx.lisp -gl.lisp -dpms.lisp -provide.lisp +See src/tools/clxcom.lisp to see what files are compiled. ===================================== src/clx/demo/bezier.lisp ===================================== --- a/src/clx/demo/bezier.lisp +++ b/src/clx/demo/bezier.lisp @@ -18,9 +18,6 @@ ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment "$Id: bezier.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) (export 'draw-curves) ===================================== src/clx/demo/beziertest.lisp ===================================== --- a/src/clx/demo/beziertest.lisp +++ b/src/clx/demo/beziertest.lisp @@ -18,9 +18,6 @@ ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment "$Id: beziertest.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) (defun bezier-test (host &optional (pathname "/usr/X.V11R1/extensions/test/datafile")) ===================================== src/clx/demo/clclock.lisp ===================================== --- a/src/clx/demo/clclock.lisp +++ b/src/clx/demo/clclock.lisp @@ -1,11 +1,8 @@ -#+cmu -(ext:file-comment "$Id: clclock.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage "XCLCLOCK" +(defpackage #:xlib-demo/clclock (:use "CL") (:export "CLOCK")) -(in-package "XCLCLOCK") +(in-package #:xlib-demo/clclock) (defvar *display* (xlib:open-default-display)) (defvar *screen* (xlib:display-default-screen *display*)) ===================================== src/clx/demo/clipboard.lisp ===================================== --- a/src/clx/demo/clipboard.lisp +++ b/src/clx/demo/clipboard.lisp @@ -59,14 +59,11 @@ ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. -#+cmu -(ext:file-comment "$Id: clipboard.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage "CLIPBOARD" +(defpackage #:xlib-demo/clipboard (:use "CL" "XLIB") (:export "MAIN")) -(in-package "CLIPBOARD") +(in-package #:xlib-demo/clipboard) ;;; This is "traditional" XLIB style; I don't really know if it's the ;;; best way -- in developing this program, style of XLIB programming ===================================== src/clx/demo/clx-demos.lisp ===================================== --- a/src/clx/demo/clx-demos.lisp +++ b/src/clx/demo/clx-demos.lisp @@ -6,13 +6,10 @@ ;;; This file should be portable to any valid Common Lisp with CLX -- DEC 88. ;;; -#+cmu -(ext:file-comment "$Id: clx-demos.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage :demos (:use :common-lisp) +(defpackage #:xlib-demo/demos (:use :common-lisp) (:export do-all-demos demo)) -(in-package :demos) +(in-package :xlib-demo/demos) ;;;; Graphic demos wrapper macro. @@ -39,11 +36,11 @@ (unless *display* #+:cmu (multiple-value-setq (*display* *screen*) (ext:open-clx-display)) - #+(or sbcl allegro clisp) + #+(or sbcl allegro clisp lispworks) (progn (setf *display* (xlib::open-default-display)) (setf *screen* (xlib:display-default-screen *display*))) - #-(or cmu sbcl allegro clisp) + #-(or cmu sbcl allegro clisp lispworks) (progn ;; Portable method (setf *display* (xlib:open-display (machine-instance))) ===================================== src/clx/demo/gl-test.lisp ===================================== --- a/src/clx/demo/gl-test.lisp +++ b/src/clx/demo/gl-test.lisp @@ -1,11 +1,8 @@ -#+cmu -(ext:file-comment "$Id: gl-test.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage :gl-test - (:use :common-lisp :xlib) +(defpackage #:xlib-demo/gl-test + (:use :common-lisp :xlib :xlib/gl) (:export "TEST" "CLX-TEST")) -(in-package :gl-test) +(in-package #:xlib-demo/gl-test) (defun test (function &key (host "localhost") (display 1) (width 200) (height 200)) @@ -16,19 +13,19 @@ (unwind-protect (progn ;;; Inform the server about us. - (glx::client-info display) - (let* ((visual (glx:choose-visual screen '(:glx-rgba + (xlib/glx::client-info display) + (let* ((visual (xlib/glx:choose-visual screen '(:glx-rgba (:glx-red-size 1) (:glx-green-size 1) (:glx-blue-size 1) :glx-double-buffer))) - (colormap (create-colormap (glx:visual-id visual) root)) + (colormap (create-colormap (xlib/glx:visual-id visual) root)) (window (create-window :parent root :x 10 :y 10 :width width :height height :class :input-output :background (screen-black-pixel screen) :border (screen-black-pixel screen) - :visual (glx:visual-id visual) + :visual (xlib/glx:visual-id visual) :depth 24 :colormap colormap :event-mask '(:structure-notify :exposure))) @@ -44,16 +41,16 @@ :min-width width :min-height height :initial-state :normal) - (setf ctx (glx:create-context screen (glx:visual-id visual))) + (setf ctx (xlib/glx:create-context screen (xlib/glx:visual-id visual))) (map-window window) - (glx:make-current window ctx) + (xlib/glx:make-current window ctx) (funcall function display window) (unmap-window window) (free-gcontext gc))) - (when ctx (glx:destroy-context ctx)) + (when ctx (xlib/glx:destroy-context ctx)) (close-display display)))) @@ -62,76 +59,76 @@ (defun no-floats (display window) (declare (ignore display window)) - (gl:color-3s #x7fff #x7fff 0) - (gl:begin gl:+polygon+) - (gl:vertex-2s 0 0) - (gl:vertex-2s 1 0) - (gl:vertex-2s 1 1) - (gl:vertex-2s 0 1) - (gl:end) - (glx:swap-buffers) + (color-3s #x7fff #x7fff 0) + (begin +polygon+) + (vertex-2s 0 0) + (vertex-2s 1 0) + (vertex-2s 1 1) + (vertex-2s 0 1) + (end) + (xlib/glx:swap-buffers) (sleep 5)) (defun anim (display window) (declare (ignore display window)) - (gl:ortho 0.0d0 1.0d0 0.0d0 1.0d0 -1.0d0 1.0d0) - (gl:clear-color 0.0s0 0.0s0 0.0s0 0.0s0) - (gl:line-width 2.0s0) + (ortho 0.0d0 1.0d0 0.0d0 1.0d0 -1.0d0 1.0d0) + (clear-color 0.0s0 0.0s0 0.0s0 0.0s0) + (line-width 2.0s0) (loop repeat 361 for angle upfrom 0.0s0 by 1.0s0 do (progn - (gl:clear gl:+color-buffer-bit+) - (gl:push-matrix) - (gl:translate-f 0.5s0 0.5s0 0.0s0) - (gl:rotate-f angle 0.0s0 0.0s0 1.0s0) - (gl:translate-f -0.5s0 -0.5s0 0.0s0) - (gl:begin gl:+polygon+ #-(and) gl:+line-loop+) - (gl:color-3ub 255 0 0) - (gl:vertex-2f 0.25s0 0.25s0) - (gl:color-3ub 0 255 0) - (gl:vertex-2f 0.75s0 0.25s0) - (gl:color-3ub 0 0 255) - (gl:vertex-2f 0.75s0 0.75s0) - (gl:color-3ub 255 255 255) - (gl:vertex-2f 0.25s0 0.75s0) - (gl:end) - (gl:pop-matrix) - (glx:swap-buffers) + (clear +color-buffer-bit+) + (push-matrix) + (translate-f 0.5s0 0.5s0 0.0s0) + (rotate-f angle 0.0s0 0.0s0 1.0s0) + (translate-f -0.5s0 -0.5s0 0.0s0) + (begin +polygon+ #-(and) +line-loop+) + (color-3ub 255 0 0) + (vertex-2f 0.25s0 0.25s0) + (color-3ub 0 255 0) + (vertex-2f 0.75s0 0.25s0) + (color-3ub 0 0 255) + (vertex-2f 0.75s0 0.75s0) + (color-3ub 255 255 255) + (vertex-2f 0.25s0 0.75s0) + (end) + (pop-matrix) + (xlib/glx:swap-buffers) (sleep 0.02))) (sleep 3)) (defun anim/list (display window) (declare (ignore display window)) - (gl:ortho 0.0d0 1.0d0 0.0d0 1.0d0 -1.0d0 1.0d0) - (gl:clear-color 0.0s0 0.0s0 0.0s0 0.0s0) - (let ((list (gl:gen-lists 1))) - (gl:new-list list gl:+compile+) - (gl:begin gl:+polygon+) - (gl:color-3ub 255 0 0) - (gl:vertex-2f 0.25s0 0.25s0) - (gl:color-3ub 0 255 0) - (gl:vertex-2f 0.75s0 0.25s0) - (gl:color-3ub 0 0 255) - (gl:vertex-2f 0.75s0 0.75s0) - (gl:color-3ub 255 255 255) - (gl:vertex-2f 0.25s0 0.75s0) - (gl:end) - (glx:render) - (gl:end-list) + (ortho 0.0d0 1.0d0 0.0d0 1.0d0 -1.0d0 1.0d0) + (clear-color 0.0s0 0.0s0 0.0s0 0.0s0) + (let ((list (gen-lists 1))) + (new-list list +compile+) + (begin +polygon+) + (color-3ub 255 0 0) + (vertex-2f 0.25s0 0.25s0) + (color-3ub 0 255 0) + (vertex-2f 0.75s0 0.25s0) + (color-3ub 0 0 255) + (vertex-2f 0.75s0 0.75s0) + (color-3ub 255 255 255) + (vertex-2f 0.25s0 0.75s0) + (end) + (xlib/glx:render) + (end-list) (loop repeat 361 for angle upfrom 0.0s0 by 1.0s0 do (progn - (gl:clear gl:+color-buffer-bit+) - (gl:push-matrix) - (gl:rotate-f angle 0.0s0 0.0s0 1.0s0) - (gl:call-list list) - (gl:pop-matrix) - (glx:swap-buffers) + (clear +color-buffer-bit+) + (push-matrix) + (rotate-f angle 0.0s0 0.0s0 1.0s0) + (call-list list) + (pop-matrix) + (xlib/glx:swap-buffers) (sleep 0.02)))) (sleep 3)) @@ -148,101 +145,101 @@ (r1 (/ (- outer-radius tooth-depth) 2.0s0)) (r2 (/ (+ outer-radius tooth-depth) 2.0s0)) (da (/ (* 2.0s0 +pi+) teeth 4.0s0))) - (gl:shade-model gl:+flat+) - (gl:normal-3f 0.0s0 0.0s0 1.0s0) + (shade-model +flat+) + (normal-3f 0.0s0 0.0s0 1.0s0) ;; Front face. - (gl:begin gl:+quad-strip+) + (begin +quad-strip+) (dotimes (i (1+ teeth)) (let ((angle (/ (* i 2.0 +pi+) teeth))) (declare (type single-float angle)) - (gl:vertex-3f (* r0 (cos angle)) + (vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5s0)) - (gl:vertex-3f (* r1 (cos angle)) + (vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5s0)) (when (< i teeth) - (gl:vertex-3f (* r0 (cos angle)) + (vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5s0)) - (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) + (vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5s0))))) - (gl:end) + (end) ;; Draw front sides of teeth. - (gl:begin gl:+quads+) + (begin +quads+) (setf da (/ (* 2.0s0 +pi+) teeth 4.0s0)) (dotimes (i teeth) (let ((angle (/ (* i 2.0s0 +pi+) teeth))) (declare (type single-float angle)) - (gl:vertex-3f (* r1 (cos angle)) + (vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5s0)) - (gl:vertex-3f (* r2 (cos (+ angle da))) + (vertex-3f (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width 0.5s0)) - (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) + (vertex-3f (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width 0.5s0)) - (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) + (vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5s0)))) - (gl:end) + (end) - (gl:normal-3f 0.0s0 0.0s0 -1.0s0) + (normal-3f 0.0s0 0.0s0 -1.0s0) ;; Draw back face. - (gl:begin gl:+quad-strip+) + (begin +quad-strip+) (dotimes (i (1+ teeth)) (let ((angle (/ (* i 2.0s0 +pi+) teeth))) (declare (type single-float angle)) - (gl:vertex-3f (* r1 (cos angle)) + (vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5s0)) - (gl:vertex-3f (* r0 (cos angle)) + (vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5s0)) (when (< i teeth) - (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) + (vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width -0.5s0)) - (gl:vertex-3f (* r0 (cos angle)) + (vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5s0))))) - (gl:end) + (end) ;; Draw back sides of teeth. - (gl:begin gl:+quads+) + (begin +quads+) (setf da (/ (* 2.0s0 +pi+) teeth 4.0s0)) (dotimes (i teeth) (let ((angle (/ (* i 2.0s0 +pi+) teeth))) (declare (type single-float angle)) - (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) + (vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width -0.5s0)) - (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) + (vertex-3f (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width -0.5s0)) - (gl:vertex-3f (* r2 (cos (+ angle da))) + (vertex-3f (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width -0.5s0)) - (gl:vertex-3f (* r1 (cos angle)) + (vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5s0)))) - (gl:end) + (end) ;; Draw outward faces of teeth. - (gl:begin gl:+quad-strip+) + (begin +quad-strip+) (dotimes (i teeth) (let ((angle (/ (* i 2.0s0 +pi+) teeth))) (declare (type single-float angle)) - (gl:vertex-3f (* r1 (cos angle)) + (vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5s0)) - (gl:vertex-3f (* r1 (cos angle)) + (vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5s0)) (let* ((u (- (* r2 (cos (+ angle da))) (* r1 (cos angle)))) @@ -250,118 +247,118 @@ (len (sqrt (+ (* u u) (* v v))))) (setf u (/ u len) v (/ v len)) - (gl:normal-3f v u 0.0s0) - (gl:vertex-3f (* r2 (cos (+ angle da))) + (normal-3f v u 0.0s0) + (vertex-3f (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width 0.5s0)) - (gl:vertex-3f (* r2 (cos (+ angle da))) + (vertex-3f (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width -0.5s0)) - (gl:normal-3f (cos angle) (sin angle) 0.0s0) - (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) + (normal-3f (cos angle) (sin angle) 0.0s0) + (vertex-3f (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width 0.5s0)) - (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) + (vertex-3f (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width -0.5s0)) (setf u (- (* r1 (cos (+ angle (* 3 da)))) (* r2 (cos (+ angle (* 2 da))))) v (- (* r1 (sin (+ angle (* 3 da)))) (* r2 (sin (+ angle (* 2 da)))))) - (gl:normal-3f v (- u) 0.0s0) - (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) + (normal-3f v (- u) 0.0s0) + (vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5s0)) - (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) + (vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width -0.5s0)) - (gl:normal-3f (cos angle) (sin angle) 0.0s0)))) + (normal-3f (cos angle) (sin angle) 0.0s0)))) - (gl:vertex-3f (* r1 (cos 0)) (* r1 (sin 0)) (* width 0.5s0)) - (gl:vertex-3f (* r1 (cos 0)) (* r1 (sin 0)) (* width -0.5s0)) + (vertex-3f (* r1 (cos 0)) (* r1 (sin 0)) (* width 0.5s0)) + (vertex-3f (* r1 (cos 0)) (* r1 (sin 0)) (* width -0.5s0)) - (gl:end) + (end) - (gl:shade-model gl:+smooth+) + (shade-model +smooth+) ;; Draw inside radius cylinder. - (gl:begin gl:+quad-strip+) + (begin +quad-strip+) (dotimes (i (1+ teeth)) (let ((angle (/ (* i 2.0s0 +pi+) teeth))) (declare (type single-float angle)) - (gl:normal-3f (- (cos angle)) (- (sin angle)) 0.0s0) - (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5s0)) - (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5s0)))) - (gl:end))) + (normal-3f (- (cos angle)) (- (sin angle)) 0.0s0) + (vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5s0)) + (vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5s0)))) + (end))) (defun draw (gear-1 gear-2 gear-3 view-rotx view-roty view-rotz angle) - (gl:clear (logior gl:+color-buffer-bit+ gl:+depth-buffer-bit+)) + (clear (logior +color-buffer-bit+ +depth-buffer-bit+)) - (gl:push-matrix) - (gl:rotate-f view-rotx 1.0s0 0.0s0 0.0s0) - (gl:rotate-f view-roty 0.0s0 1.0s0 0.0s0) - (gl:rotate-f view-rotz 0.0s0 0.0s0 1.0s0) + (push-matrix) + (rotate-f view-rotx 1.0s0 0.0s0 0.0s0) + (rotate-f view-roty 0.0s0 1.0s0 0.0s0) + (rotate-f view-rotz 0.0s0 0.0s0 1.0s0) - (gl:push-matrix) - (gl:translate-f -3.0s0 -2.0s0 0.0s0) - (gl:rotate-f angle 0.0s0 0.0s0 1.0s0) - (gl:call-list gear-1) - (gl:pop-matrix) + (push-matrix) + (translate-f -3.0s0 -2.0s0 0.0s0) + (rotate-f angle 0.0s0 0.0s0 1.0s0) + (call-list gear-1) + (pop-matrix) - (gl:push-matrix) - (gl:translate-f 3.1s0 -2.0s0 0.0s0) - (gl:rotate-f (- (* angle -2.0s0) 9.0s0) 0.0s0 0.0s0 1.0s0) - (gl:call-list gear-2) - (gl:pop-matrix) + (push-matrix) + (translate-f 3.1s0 -2.0s0 0.0s0) + (rotate-f (- (* angle -2.0s0) 9.0s0) 0.0s0 0.0s0 1.0s0) + (call-list gear-2) + (pop-matrix) - (gl:push-matrix) - (gl:translate-f -3.1s0 4.2s0 0.0s0) - (gl:rotate-f (- (* angle -2.s0) 25.0s0) 0.0s0 0.0s0 1.0s0) - (gl:call-list gear-3) - (gl:pop-matrix) + (push-matrix) + (translate-f -3.1s0 4.2s0 0.0s0) + (rotate-f (- (* angle -2.s0) 25.0s0) 0.0s0 0.0s0 1.0s0) + (call-list gear-3) + (pop-matrix) - (gl:pop-matrix)) + (pop-matrix)) (defun reshape (width height) - (gl:viewport 0 0 width height) + (viewport 0 0 width height) (let ((h (coerce (/ height width) 'double-float))) - (gl:matrix-mode gl:+projection+) - (gl:load-identity) - (gl:frustum -1.0d0 1.0d0 (- h) h 5.0d0 60.0d0)) + (matrix-mode +projection+) + (load-identity) + (frustum -1.0d0 1.0d0 (- h) h 5.0d0 60.0d0)) - (gl:matrix-mode gl:+modelview+) - (gl:load-identity) - (gl:translate-f 0.0s0 0.0s0 -40.0s0)) + (matrix-mode +modelview+) + (load-identity) + (translate-f 0.0s0 0.0s0 -40.0s0)) (defun init () (let (gear-1 gear-2 gear-3) - ;;(gl:light-fv gl:+light0+ gl:+position+ '(5.0s0 5.0s0 10.0s0 0.0s0)) - ;;(gl:enable gl:+cull-face+) - ;;(gl:enable gl:+lighting+) - ;;(gl:enable gl:+light0+) - ;;(gl:enable gl:+depth-test+) + ;;(light-fv +light0+ +position+ '(5.0s0 5.0s0 10.0s0 0.0s0)) + ;;(enable +cull-face+) + ;;(enable +lighting+) + ;;(enable +light0+) + ;;(enable +depth-test+) ;; Make the gears. - (setf gear-1 (gl:gen-lists 1)) - (gl:new-list gear-1 gl:+compile+) - (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) + (setf gear-1 (gen-lists 1)) + (new-list gear-1 +compile+) + (material-fv +front+ +ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) (gear 1.0s0 4.0s0 1.0s0 20 0.7s0) - (gl:end-list) + (end-list) - (setf gear-2 (gl:gen-lists 1)) - (gl:new-list gear-2 gl:+compile+) - (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.0s0 0.8s0 0.2s0 1.0s0)) + (setf gear-2 (gen-lists 1)) + (new-list gear-2 +compile+) + (material-fv +front+ +ambient-and-diffuse+ '(0.0s0 0.8s0 0.2s0 1.0s0)) (gear 0.5s0 2.0s0 2.0s0 10 0.7s0) - (gl:end-list) + (end-list) - (setf gear-3 (gl:gen-lists 1)) - (gl:new-list gear-3 gl:+compile+) - (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.2s0 0.2s0 1.0s0 1.0s0)) + (setf gear-3 (gen-lists 1)) + (new-list gear-3 +compile+) + (material-fv +front+ +ambient-and-diffuse+ '(0.2s0 0.2s0 1.0s0 1.0s0)) (gear 1.3s0 2.0s0 0.5s0 10 0.7s0) - (gl:end-list) + (end-list) - ;;(gl:enable gl:+normalize+) + ;;(enable +normalize+) (values gear-1 gear-2 gear-3))) @@ -369,31 +366,31 @@ (defun gears* (display window) (declare (ignore display window)) - (gl:enable gl:+cull-face+) - (gl:enable gl:+lighting+) - (gl:enable gl:+light0+) - (gl:enable gl:+normalize+) - (gl:enable gl:+depth-test+) + (enable +cull-face+) + (enable +lighting+) + (enable +light0+) + (enable +normalize+) + (enable +depth-test+) (reshape 300 300) - ;;(gl:light-fv gl:+light0+ gl:+position+ #(5.0s0 5.0s0 10.0s0 0.0s0)) + ;;(light-fv +light0+ +position+ #(5.0s0 5.0s0 10.0s0 0.0s0)) (let (list) (declare (ignore list)) #-(and) (progn - (setf list (gl:gen-lists 1)) - (gl:new-list list gl:+compile+) - ;;(gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) + (setf list (gen-lists 1)) + (new-list list +compile+) + ;;(material-fv +front+ +ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) (gear 1.0s0 4.0s0 1.0s0 20 0.7s0) - (glx:render) - (gl:end-list)) + (xlib/glx:render) + (end-list)) (loop ;;for angle from 0.0s0 below 361.0s0 by 1.0s0 - with angle single-float = 0.0s0 + with angle of-type single-float = 0.0s0 with dt = 0.004s0 repeat 2500 do (progn @@ -402,39 +399,39 @@ (when (< 3600.0s0 angle) (decf angle 3600.0s0)) - (gl:clear (logior gl:+color-buffer-bit+ gl:+depth-buffer-bit+)) + (clear (logior +color-buffer-bit+ +depth-buffer-bit+)) - (gl:push-matrix) - (gl:rotate-f 20.0s0 0.0s0 1.0s0 0.0s0) + (push-matrix) + (rotate-f 20.0s0 0.0s0 1.0s0 0.0s0) - (gl:push-matrix) - (gl:translate-f -3.0s0 -2.0s0 0.0s0) - (gl:rotate-f angle 0.0s0 0.0s0 1.0s0) - (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) + (push-matrix) + (translate-f -3.0s0 -2.0s0 0.0s0) + (rotate-f angle 0.0s0 0.0s0 1.0s0) + (material-fv +front+ +ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) (gear 1.0s0 4.0s0 1.0s0 20 0.7s0) - (gl:pop-matrix) + (pop-matrix) - (gl:push-matrix) - (gl:translate-f 3.1s0 -2.0s0 0.0s0) - (gl:rotate-f (- (* angle -2.0s0) 9.0s0) 0.0s0 0.0s0 1.0s0) - (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.0s0 0.8s0 0.2s0 1.0s0)) + (push-matrix) + (translate-f 3.1s0 -2.0s0 0.0s0) + (rotate-f (- (* angle -2.0s0) 9.0s0) 0.0s0 0.0s0 1.0s0) + (material-fv +front+ +ambient-and-diffuse+ '(0.0s0 0.8s0 0.2s0 1.0s0)) (gear 0.5s0 2.0s0 2.0s0 10 0.7s0) - (gl:pop-matrix) + (pop-matrix) - (gl:push-matrix) - (gl:translate-f -3.1s0 4.2s0 0.0s0) - (gl:rotate-f (- (* angle -2.s0) 25.0s0) 0.0s0 0.0s0 1.0s0) - (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.2s0 0.2s0 1.0s0 1.0s0)) + (push-matrix) + (translate-f -3.1s0 4.2s0 0.0s0) + (rotate-f (- (* angle -2.s0) 25.0s0) 0.0s0 0.0s0 1.0s0) + (material-fv +front+ +ambient-and-diffuse+ '(0.2s0 0.2s0 1.0s0 1.0s0)) (gear 1.3s0 2.0s0 0.5s0 10 0.7s0) - (gl:pop-matrix) + (pop-matrix) - (gl:pop-matrix) + (pop-matrix) - (glx:swap-buffers) + (xlib/glx:swap-buffers) ;;(sleep 0.025) ))) @@ -472,7 +469,7 @@ (decf angle 3600.0s0)) (draw gear-1 gear-2 gear-3 view-rotx view-roty view-rotz angle) - (glx:swap-buffers) + (xlib/glx:swap-buffers) (incf frames) ===================================== src/clx/demo/hello.lisp ===================================== --- a/src/clx/demo/hello.lisp +++ b/src/clx/demo/hello.lisp @@ -1,8 +1,5 @@ ;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*- -#+cmu -(ext:file-comment "$Id: hello.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) (defun hello-world (host &rest args &key (string "Hello World") (font "fixed")) ===================================== src/clx/demo/mandel.lisp ===================================== --- a/src/clx/demo/mandel.lisp +++ b/src/clx/demo/mandel.lisp @@ -1,11 +1,8 @@ -#+cmu -(ext:file-comment "$Id: mandel.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage "XMANDEL" +(defpackage #:xlib-demo/mandel (:use "CL") (:export "NEW-WINDOW" "EVENT-LOOP")) -(in-package "XMANDEL") +(in-package #:xlib-demo/mandel) (defvar *display* (xlib:open-default-display)) (defvar *screen* (xlib:display-default-screen *display*)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/560af6217ba3f486ad084886… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/560af6217ba3f486ad084886… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-update-clx] Merge upstream demo files
by Raymond Toy 27 Jan '18

27 Jan '18

Raymond Toy pushed to branch rtoy-update-clx at cmucl / cmucl Commits: c1864fe6 by Raymond Toy at 2018-01-27T09:23:20-08:00 Merge upstream demo files [skip-ci] - - - - - 8 changed files: - src/clx/demo/bezier.lisp - src/clx/demo/beziertest.lisp - src/clx/demo/clclock.lisp - src/clx/demo/clipboard.lisp - src/clx/demo/clx-demos.lisp - src/clx/demo/gl-test.lisp - src/clx/demo/hello.lisp - src/clx/demo/mandel.lisp Changes: ===================================== src/clx/demo/bezier.lisp ===================================== --- a/src/clx/demo/bezier.lisp +++ b/src/clx/demo/bezier.lisp @@ -18,9 +18,6 @@ ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment "$Id: bezier.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) (export 'draw-curves) ===================================== src/clx/demo/beziertest.lisp ===================================== --- a/src/clx/demo/beziertest.lisp +++ b/src/clx/demo/beziertest.lisp @@ -18,9 +18,6 @@ ;;; express or implied warranty. ;;; -#+cmu -(ext:file-comment "$Id: beziertest.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) (defun bezier-test (host &optional (pathname "/usr/X.V11R1/extensions/test/datafile")) ===================================== src/clx/demo/clclock.lisp ===================================== --- a/src/clx/demo/clclock.lisp +++ b/src/clx/demo/clclock.lisp @@ -1,11 +1,8 @@ -#+cmu -(ext:file-comment "$Id: clclock.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage "XCLCLOCK" +(defpackage #:xlib-demo/clclock (:use "CL") (:export "CLOCK")) -(in-package "XCLCLOCK") +(in-package #:xlib-demo/clclock) (defvar *display* (xlib:open-default-display)) (defvar *screen* (xlib:display-default-screen *display*)) ===================================== src/clx/demo/clipboard.lisp ===================================== --- a/src/clx/demo/clipboard.lisp +++ b/src/clx/demo/clipboard.lisp @@ -59,14 +59,11 @@ ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;;; DEALINGS IN THE SOFTWARE. -#+cmu -(ext:file-comment "$Id: clipboard.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage "CLIPBOARD" +(defpackage #:xlib-demo/clipboard (:use "CL" "XLIB") (:export "MAIN")) -(in-package "CLIPBOARD") +(in-package #:xlib-demo/clipboard) ;;; This is "traditional" XLIB style; I don't really know if it's the ;;; best way -- in developing this program, style of XLIB programming ===================================== src/clx/demo/clx-demos.lisp ===================================== --- a/src/clx/demo/clx-demos.lisp +++ b/src/clx/demo/clx-demos.lisp @@ -6,13 +6,10 @@ ;;; This file should be portable to any valid Common Lisp with CLX -- DEC 88. ;;; -#+cmu -(ext:file-comment "$Id: clx-demos.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage :demos (:use :common-lisp) +(defpackage #:xlib-demo/demos (:use :common-lisp) (:export do-all-demos demo)) -(in-package :demos) +(in-package :xlib-demo/demos) ;;;; Graphic demos wrapper macro. @@ -39,11 +36,11 @@ (unless *display* #+:cmu (multiple-value-setq (*display* *screen*) (ext:open-clx-display)) - #+(or sbcl allegro clisp) + #+(or sbcl allegro clisp lispworks) (progn (setf *display* (xlib::open-default-display)) (setf *screen* (xlib:display-default-screen *display*))) - #-(or cmu sbcl allegro clisp) + #-(or cmu sbcl allegro clisp lispworks) (progn ;; Portable method (setf *display* (xlib:open-display (machine-instance))) ===================================== src/clx/demo/gl-test.lisp ===================================== --- a/src/clx/demo/gl-test.lisp +++ b/src/clx/demo/gl-test.lisp @@ -1,11 +1,8 @@ -#+cmu -(ext:file-comment "$Id: gl-test.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage :gl-test - (:use :common-lisp :xlib) +(defpackage #:xlib-demo/gl-test + (:use :common-lisp :xlib :xlib/gl) (:export "TEST" "CLX-TEST")) -(in-package :gl-test) +(in-package #:xlib-demo/gl-test) (defun test (function &key (host "localhost") (display 1) (width 200) (height 200)) @@ -16,19 +13,19 @@ (unwind-protect (progn ;;; Inform the server about us. - (glx::client-info display) - (let* ((visual (glx:choose-visual screen '(:glx-rgba + (xlib/glx::client-info display) + (let* ((visual (xlib/glx:choose-visual screen '(:glx-rgba (:glx-red-size 1) (:glx-green-size 1) (:glx-blue-size 1) :glx-double-buffer))) - (colormap (create-colormap (glx:visual-id visual) root)) + (colormap (create-colormap (xlib/glx:visual-id visual) root)) (window (create-window :parent root :x 10 :y 10 :width width :height height :class :input-output :background (screen-black-pixel screen) :border (screen-black-pixel screen) - :visual (glx:visual-id visual) + :visual (xlib/glx:visual-id visual) :depth 24 :colormap colormap :event-mask '(:structure-notify :exposure))) @@ -44,16 +41,16 @@ :min-width width :min-height height :initial-state :normal) - (setf ctx (glx:create-context screen (glx:visual-id visual))) + (setf ctx (xlib/glx:create-context screen (xlib/glx:visual-id visual))) (map-window window) - (glx:make-current window ctx) + (xlib/glx:make-current window ctx) (funcall function display window) (unmap-window window) (free-gcontext gc))) - (when ctx (glx:destroy-context ctx)) + (when ctx (xlib/glx:destroy-context ctx)) (close-display display)))) @@ -62,76 +59,76 @@ (defun no-floats (display window) (declare (ignore display window)) - (gl:color-3s #x7fff #x7fff 0) - (gl:begin gl:+polygon+) - (gl:vertex-2s 0 0) - (gl:vertex-2s 1 0) - (gl:vertex-2s 1 1) - (gl:vertex-2s 0 1) - (gl:end) - (glx:swap-buffers) + (color-3s #x7fff #x7fff 0) + (begin +polygon+) + (vertex-2s 0 0) + (vertex-2s 1 0) + (vertex-2s 1 1) + (vertex-2s 0 1) + (end) + (xlib/glx:swap-buffers) (sleep 5)) (defun anim (display window) (declare (ignore display window)) - (gl:ortho 0.0d0 1.0d0 0.0d0 1.0d0 -1.0d0 1.0d0) - (gl:clear-color 0.0s0 0.0s0 0.0s0 0.0s0) - (gl:line-width 2.0s0) + (ortho 0.0d0 1.0d0 0.0d0 1.0d0 -1.0d0 1.0d0) + (clear-color 0.0s0 0.0s0 0.0s0 0.0s0) + (line-width 2.0s0) (loop repeat 361 for angle upfrom 0.0s0 by 1.0s0 do (progn - (gl:clear gl:+color-buffer-bit+) - (gl:push-matrix) - (gl:translate-f 0.5s0 0.5s0 0.0s0) - (gl:rotate-f angle 0.0s0 0.0s0 1.0s0) - (gl:translate-f -0.5s0 -0.5s0 0.0s0) - (gl:begin gl:+polygon+ #-(and) gl:+line-loop+) - (gl:color-3ub 255 0 0) - (gl:vertex-2f 0.25s0 0.25s0) - (gl:color-3ub 0 255 0) - (gl:vertex-2f 0.75s0 0.25s0) - (gl:color-3ub 0 0 255) - (gl:vertex-2f 0.75s0 0.75s0) - (gl:color-3ub 255 255 255) - (gl:vertex-2f 0.25s0 0.75s0) - (gl:end) - (gl:pop-matrix) - (glx:swap-buffers) + (clear +color-buffer-bit+) + (push-matrix) + (translate-f 0.5s0 0.5s0 0.0s0) + (rotate-f angle 0.0s0 0.0s0 1.0s0) + (translate-f -0.5s0 -0.5s0 0.0s0) + (begin +polygon+ #-(and) +line-loop+) + (color-3ub 255 0 0) + (vertex-2f 0.25s0 0.25s0) + (color-3ub 0 255 0) + (vertex-2f 0.75s0 0.25s0) + (color-3ub 0 0 255) + (vertex-2f 0.75s0 0.75s0) + (color-3ub 255 255 255) + (vertex-2f 0.25s0 0.75s0) + (end) + (pop-matrix) + (xlib/glx:swap-buffers) (sleep 0.02))) (sleep 3)) (defun anim/list (display window) (declare (ignore display window)) - (gl:ortho 0.0d0 1.0d0 0.0d0 1.0d0 -1.0d0 1.0d0) - (gl:clear-color 0.0s0 0.0s0 0.0s0 0.0s0) - (let ((list (gl:gen-lists 1))) - (gl:new-list list gl:+compile+) - (gl:begin gl:+polygon+) - (gl:color-3ub 255 0 0) - (gl:vertex-2f 0.25s0 0.25s0) - (gl:color-3ub 0 255 0) - (gl:vertex-2f 0.75s0 0.25s0) - (gl:color-3ub 0 0 255) - (gl:vertex-2f 0.75s0 0.75s0) - (gl:color-3ub 255 255 255) - (gl:vertex-2f 0.25s0 0.75s0) - (gl:end) - (glx:render) - (gl:end-list) + (ortho 0.0d0 1.0d0 0.0d0 1.0d0 -1.0d0 1.0d0) + (clear-color 0.0s0 0.0s0 0.0s0 0.0s0) + (let ((list (gen-lists 1))) + (new-list list +compile+) + (begin +polygon+) + (color-3ub 255 0 0) + (vertex-2f 0.25s0 0.25s0) + (color-3ub 0 255 0) + (vertex-2f 0.75s0 0.25s0) + (color-3ub 0 0 255) + (vertex-2f 0.75s0 0.75s0) + (color-3ub 255 255 255) + (vertex-2f 0.25s0 0.75s0) + (end) + (xlib/glx:render) + (end-list) (loop repeat 361 for angle upfrom 0.0s0 by 1.0s0 do (progn - (gl:clear gl:+color-buffer-bit+) - (gl:push-matrix) - (gl:rotate-f angle 0.0s0 0.0s0 1.0s0) - (gl:call-list list) - (gl:pop-matrix) - (glx:swap-buffers) + (clear +color-buffer-bit+) + (push-matrix) + (rotate-f angle 0.0s0 0.0s0 1.0s0) + (call-list list) + (pop-matrix) + (xlib/glx:swap-buffers) (sleep 0.02)))) (sleep 3)) @@ -148,101 +145,101 @@ (r1 (/ (- outer-radius tooth-depth) 2.0s0)) (r2 (/ (+ outer-radius tooth-depth) 2.0s0)) (da (/ (* 2.0s0 +pi+) teeth 4.0s0))) - (gl:shade-model gl:+flat+) - (gl:normal-3f 0.0s0 0.0s0 1.0s0) + (shade-model +flat+) + (normal-3f 0.0s0 0.0s0 1.0s0) ;; Front face. - (gl:begin gl:+quad-strip+) + (begin +quad-strip+) (dotimes (i (1+ teeth)) (let ((angle (/ (* i 2.0 +pi+) teeth))) (declare (type single-float angle)) - (gl:vertex-3f (* r0 (cos angle)) + (vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5s0)) - (gl:vertex-3f (* r1 (cos angle)) + (vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5s0)) (when (< i teeth) - (gl:vertex-3f (* r0 (cos angle)) + (vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5s0)) - (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) + (vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5s0))))) - (gl:end) + (end) ;; Draw front sides of teeth. - (gl:begin gl:+quads+) + (begin +quads+) (setf da (/ (* 2.0s0 +pi+) teeth 4.0s0)) (dotimes (i teeth) (let ((angle (/ (* i 2.0s0 +pi+) teeth))) (declare (type single-float angle)) - (gl:vertex-3f (* r1 (cos angle)) + (vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5s0)) - (gl:vertex-3f (* r2 (cos (+ angle da))) + (vertex-3f (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width 0.5s0)) - (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) + (vertex-3f (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width 0.5s0)) - (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) + (vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5s0)))) - (gl:end) + (end) - (gl:normal-3f 0.0s0 0.0s0 -1.0s0) + (normal-3f 0.0s0 0.0s0 -1.0s0) ;; Draw back face. - (gl:begin gl:+quad-strip+) + (begin +quad-strip+) (dotimes (i (1+ teeth)) (let ((angle (/ (* i 2.0s0 +pi+) teeth))) (declare (type single-float angle)) - (gl:vertex-3f (* r1 (cos angle)) + (vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5s0)) - (gl:vertex-3f (* r0 (cos angle)) + (vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5s0)) (when (< i teeth) - (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) + (vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width -0.5s0)) - (gl:vertex-3f (* r0 (cos angle)) + (vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5s0))))) - (gl:end) + (end) ;; Draw back sides of teeth. - (gl:begin gl:+quads+) + (begin +quads+) (setf da (/ (* 2.0s0 +pi+) teeth 4.0s0)) (dotimes (i teeth) (let ((angle (/ (* i 2.0s0 +pi+) teeth))) (declare (type single-float angle)) - (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) + (vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width -0.5s0)) - (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) + (vertex-3f (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width -0.5s0)) - (gl:vertex-3f (* r2 (cos (+ angle da))) + (vertex-3f (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width -0.5s0)) - (gl:vertex-3f (* r1 (cos angle)) + (vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5s0)))) - (gl:end) + (end) ;; Draw outward faces of teeth. - (gl:begin gl:+quad-strip+) + (begin +quad-strip+) (dotimes (i teeth) (let ((angle (/ (* i 2.0s0 +pi+) teeth))) (declare (type single-float angle)) - (gl:vertex-3f (* r1 (cos angle)) + (vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5s0)) - (gl:vertex-3f (* r1 (cos angle)) + (vertex-3f (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5s0)) (let* ((u (- (* r2 (cos (+ angle da))) (* r1 (cos angle)))) @@ -250,118 +247,118 @@ (len (sqrt (+ (* u u) (* v v))))) (setf u (/ u len) v (/ v len)) - (gl:normal-3f v u 0.0s0) - (gl:vertex-3f (* r2 (cos (+ angle da))) + (normal-3f v u 0.0s0) + (vertex-3f (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width 0.5s0)) - (gl:vertex-3f (* r2 (cos (+ angle da))) + (vertex-3f (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width -0.5s0)) - (gl:normal-3f (cos angle) (sin angle) 0.0s0) - (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) + (normal-3f (cos angle) (sin angle) 0.0s0) + (vertex-3f (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width 0.5s0)) - (gl:vertex-3f (* r2 (cos (+ angle (* 2 da)))) + (vertex-3f (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width -0.5s0)) (setf u (- (* r1 (cos (+ angle (* 3 da)))) (* r2 (cos (+ angle (* 2 da))))) v (- (* r1 (sin (+ angle (* 3 da)))) (* r2 (sin (+ angle (* 2 da)))))) - (gl:normal-3f v (- u) 0.0s0) - (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) + (normal-3f v (- u) 0.0s0) + (vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5s0)) - (gl:vertex-3f (* r1 (cos (+ angle (* 3 da)))) + (vertex-3f (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width -0.5s0)) - (gl:normal-3f (cos angle) (sin angle) 0.0s0)))) + (normal-3f (cos angle) (sin angle) 0.0s0)))) - (gl:vertex-3f (* r1 (cos 0)) (* r1 (sin 0)) (* width 0.5s0)) - (gl:vertex-3f (* r1 (cos 0)) (* r1 (sin 0)) (* width -0.5s0)) + (vertex-3f (* r1 (cos 0)) (* r1 (sin 0)) (* width 0.5s0)) + (vertex-3f (* r1 (cos 0)) (* r1 (sin 0)) (* width -0.5s0)) - (gl:end) + (end) - (gl:shade-model gl:+smooth+) + (shade-model +smooth+) ;; Draw inside radius cylinder. - (gl:begin gl:+quad-strip+) + (begin +quad-strip+) (dotimes (i (1+ teeth)) (let ((angle (/ (* i 2.0s0 +pi+) teeth))) (declare (type single-float angle)) - (gl:normal-3f (- (cos angle)) (- (sin angle)) 0.0s0) - (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5s0)) - (gl:vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5s0)))) - (gl:end))) + (normal-3f (- (cos angle)) (- (sin angle)) 0.0s0) + (vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5s0)) + (vertex-3f (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5s0)))) + (end))) (defun draw (gear-1 gear-2 gear-3 view-rotx view-roty view-rotz angle) - (gl:clear (logior gl:+color-buffer-bit+ gl:+depth-buffer-bit+)) + (clear (logior +color-buffer-bit+ +depth-buffer-bit+)) - (gl:push-matrix) - (gl:rotate-f view-rotx 1.0s0 0.0s0 0.0s0) - (gl:rotate-f view-roty 0.0s0 1.0s0 0.0s0) - (gl:rotate-f view-rotz 0.0s0 0.0s0 1.0s0) + (push-matrix) + (rotate-f view-rotx 1.0s0 0.0s0 0.0s0) + (rotate-f view-roty 0.0s0 1.0s0 0.0s0) + (rotate-f view-rotz 0.0s0 0.0s0 1.0s0) - (gl:push-matrix) - (gl:translate-f -3.0s0 -2.0s0 0.0s0) - (gl:rotate-f angle 0.0s0 0.0s0 1.0s0) - (gl:call-list gear-1) - (gl:pop-matrix) + (push-matrix) + (translate-f -3.0s0 -2.0s0 0.0s0) + (rotate-f angle 0.0s0 0.0s0 1.0s0) + (call-list gear-1) + (pop-matrix) - (gl:push-matrix) - (gl:translate-f 3.1s0 -2.0s0 0.0s0) - (gl:rotate-f (- (* angle -2.0s0) 9.0s0) 0.0s0 0.0s0 1.0s0) - (gl:call-list gear-2) - (gl:pop-matrix) + (push-matrix) + (translate-f 3.1s0 -2.0s0 0.0s0) + (rotate-f (- (* angle -2.0s0) 9.0s0) 0.0s0 0.0s0 1.0s0) + (call-list gear-2) + (pop-matrix) - (gl:push-matrix) - (gl:translate-f -3.1s0 4.2s0 0.0s0) - (gl:rotate-f (- (* angle -2.s0) 25.0s0) 0.0s0 0.0s0 1.0s0) - (gl:call-list gear-3) - (gl:pop-matrix) + (push-matrix) + (translate-f -3.1s0 4.2s0 0.0s0) + (rotate-f (- (* angle -2.s0) 25.0s0) 0.0s0 0.0s0 1.0s0) + (call-list gear-3) + (pop-matrix) - (gl:pop-matrix)) + (pop-matrix)) (defun reshape (width height) - (gl:viewport 0 0 width height) + (viewport 0 0 width height) (let ((h (coerce (/ height width) 'double-float))) - (gl:matrix-mode gl:+projection+) - (gl:load-identity) - (gl:frustum -1.0d0 1.0d0 (- h) h 5.0d0 60.0d0)) + (matrix-mode +projection+) + (load-identity) + (frustum -1.0d0 1.0d0 (- h) h 5.0d0 60.0d0)) - (gl:matrix-mode gl:+modelview+) - (gl:load-identity) - (gl:translate-f 0.0s0 0.0s0 -40.0s0)) + (matrix-mode +modelview+) + (load-identity) + (translate-f 0.0s0 0.0s0 -40.0s0)) (defun init () (let (gear-1 gear-2 gear-3) - ;;(gl:light-fv gl:+light0+ gl:+position+ '(5.0s0 5.0s0 10.0s0 0.0s0)) - ;;(gl:enable gl:+cull-face+) - ;;(gl:enable gl:+lighting+) - ;;(gl:enable gl:+light0+) - ;;(gl:enable gl:+depth-test+) + ;;(light-fv +light0+ +position+ '(5.0s0 5.0s0 10.0s0 0.0s0)) + ;;(enable +cull-face+) + ;;(enable +lighting+) + ;;(enable +light0+) + ;;(enable +depth-test+) ;; Make the gears. - (setf gear-1 (gl:gen-lists 1)) - (gl:new-list gear-1 gl:+compile+) - (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) + (setf gear-1 (gen-lists 1)) + (new-list gear-1 +compile+) + (material-fv +front+ +ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) (gear 1.0s0 4.0s0 1.0s0 20 0.7s0) - (gl:end-list) + (end-list) - (setf gear-2 (gl:gen-lists 1)) - (gl:new-list gear-2 gl:+compile+) - (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.0s0 0.8s0 0.2s0 1.0s0)) + (setf gear-2 (gen-lists 1)) + (new-list gear-2 +compile+) + (material-fv +front+ +ambient-and-diffuse+ '(0.0s0 0.8s0 0.2s0 1.0s0)) (gear 0.5s0 2.0s0 2.0s0 10 0.7s0) - (gl:end-list) + (end-list) - (setf gear-3 (gl:gen-lists 1)) - (gl:new-list gear-3 gl:+compile+) - (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.2s0 0.2s0 1.0s0 1.0s0)) + (setf gear-3 (gen-lists 1)) + (new-list gear-3 +compile+) + (material-fv +front+ +ambient-and-diffuse+ '(0.2s0 0.2s0 1.0s0 1.0s0)) (gear 1.3s0 2.0s0 0.5s0 10 0.7s0) - (gl:end-list) + (end-list) - ;;(gl:enable gl:+normalize+) + ;;(enable +normalize+) (values gear-1 gear-2 gear-3))) @@ -369,31 +366,31 @@ (defun gears* (display window) (declare (ignore display window)) - (gl:enable gl:+cull-face+) - (gl:enable gl:+lighting+) - (gl:enable gl:+light0+) - (gl:enable gl:+normalize+) - (gl:enable gl:+depth-test+) + (enable +cull-face+) + (enable +lighting+) + (enable +light0+) + (enable +normalize+) + (enable +depth-test+) (reshape 300 300) - ;;(gl:light-fv gl:+light0+ gl:+position+ #(5.0s0 5.0s0 10.0s0 0.0s0)) + ;;(light-fv +light0+ +position+ #(5.0s0 5.0s0 10.0s0 0.0s0)) (let (list) (declare (ignore list)) #-(and) (progn - (setf list (gl:gen-lists 1)) - (gl:new-list list gl:+compile+) - ;;(gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) + (setf list (gen-lists 1)) + (new-list list +compile+) + ;;(material-fv +front+ +ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) (gear 1.0s0 4.0s0 1.0s0 20 0.7s0) - (glx:render) - (gl:end-list)) + (xlib/glx:render) + (end-list)) (loop ;;for angle from 0.0s0 below 361.0s0 by 1.0s0 - with angle single-float = 0.0s0 + with angle of-type single-float = 0.0s0 with dt = 0.004s0 repeat 2500 do (progn @@ -402,39 +399,39 @@ (when (< 3600.0s0 angle) (decf angle 3600.0s0)) - (gl:clear (logior gl:+color-buffer-bit+ gl:+depth-buffer-bit+)) + (clear (logior +color-buffer-bit+ +depth-buffer-bit+)) - (gl:push-matrix) - (gl:rotate-f 20.0s0 0.0s0 1.0s0 0.0s0) + (push-matrix) + (rotate-f 20.0s0 0.0s0 1.0s0 0.0s0) - (gl:push-matrix) - (gl:translate-f -3.0s0 -2.0s0 0.0s0) - (gl:rotate-f angle 0.0s0 0.0s0 1.0s0) - (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) + (push-matrix) + (translate-f -3.0s0 -2.0s0 0.0s0) + (rotate-f angle 0.0s0 0.0s0 1.0s0) + (material-fv +front+ +ambient-and-diffuse+ '(0.8s0 0.1s0 0.0s0 1.0s0)) (gear 1.0s0 4.0s0 1.0s0 20 0.7s0) - (gl:pop-matrix) + (pop-matrix) - (gl:push-matrix) - (gl:translate-f 3.1s0 -2.0s0 0.0s0) - (gl:rotate-f (- (* angle -2.0s0) 9.0s0) 0.0s0 0.0s0 1.0s0) - (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.0s0 0.8s0 0.2s0 1.0s0)) + (push-matrix) + (translate-f 3.1s0 -2.0s0 0.0s0) + (rotate-f (- (* angle -2.0s0) 9.0s0) 0.0s0 0.0s0 1.0s0) + (material-fv +front+ +ambient-and-diffuse+ '(0.0s0 0.8s0 0.2s0 1.0s0)) (gear 0.5s0 2.0s0 2.0s0 10 0.7s0) - (gl:pop-matrix) + (pop-matrix) - (gl:push-matrix) - (gl:translate-f -3.1s0 4.2s0 0.0s0) - (gl:rotate-f (- (* angle -2.s0) 25.0s0) 0.0s0 0.0s0 1.0s0) - (gl:material-fv gl:+front+ gl:+ambient-and-diffuse+ '(0.2s0 0.2s0 1.0s0 1.0s0)) + (push-matrix) + (translate-f -3.1s0 4.2s0 0.0s0) + (rotate-f (- (* angle -2.s0) 25.0s0) 0.0s0 0.0s0 1.0s0) + (material-fv +front+ +ambient-and-diffuse+ '(0.2s0 0.2s0 1.0s0 1.0s0)) (gear 1.3s0 2.0s0 0.5s0 10 0.7s0) - (gl:pop-matrix) + (pop-matrix) - (gl:pop-matrix) + (pop-matrix) - (glx:swap-buffers) + (xlib/glx:swap-buffers) ;;(sleep 0.025) ))) @@ -472,7 +469,7 @@ (decf angle 3600.0s0)) (draw gear-1 gear-2 gear-3 view-rotx view-roty view-rotz angle) - (glx:swap-buffers) + (xlib/glx:swap-buffers) (incf frames) ===================================== src/clx/demo/hello.lisp ===================================== --- a/src/clx/demo/hello.lisp +++ b/src/clx/demo/hello.lisp @@ -1,8 +1,5 @@ ;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*- -#+cmu -(ext:file-comment "$Id: hello.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) (defun hello-world (host &rest args &key (string "Hello World") (font "fixed")) ===================================== src/clx/demo/mandel.lisp ===================================== --- a/src/clx/demo/mandel.lisp +++ b/src/clx/demo/mandel.lisp @@ -1,11 +1,8 @@ -#+cmu -(ext:file-comment "$Id: mandel.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage "XMANDEL" +(defpackage #:xlib-demo/mandel (:use "CL") (:export "NEW-WINDOW" "EVENT-LOOP")) -(in-package "XMANDEL") +(in-package #:xlib-demo/mandel) (defvar *display* (xlib:open-default-display)) (defvar *screen* (xlib:display-default-screen *display*)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/c1864fe663ec7f33f216d57ff… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/c1864fe663ec7f33f216d57ff… 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] 4 commits: Move these files extensions dir to match upstream clx.
by Raymond Toy 27 Jan '18

27 Jan '18

Raymond Toy pushed to branch rtoy-update-clx-with-cmucl-fixes at cmucl / cmucl Commits: 6ea45079 by Raymond Toy at 2018-01-27T09:06:25-08:00 Move these files extensions dir to match upstream clx. [skip-ci] - - - - - e6f4c980 by Raymond Toy at 2018-01-27T09:08:11-08:00 Merge upstream changes. [skip-ci] - - - - - 286801fd by Raymond Toy at 2018-01-27T09:09:49-08:00 Merge branch 'rtoy-update-clx' into rtoy-update-clx-with-cmucl-fixes - - - - - 560af621 by Raymond Toy at 2018-01-27T09:19:42-08:00 Update file paths for clx/extensions Some files were moved to clx/extensions, so need to update the build paths appropriately. - - - - - 11 changed files: - src/clx/big-requests.lisp → src/clx/extensions/big-requests.lisp - src/clx/dpms.lisp → src/clx/extensions/dpms.lisp - src/clx/gl.lisp → src/clx/extensions/gl.lisp - src/clx/glx.lisp → src/clx/extensions/glx.lisp - src/clx/screensaver.lisp → src/clx/extensions/screensaver.lisp - src/clx/shape.lisp → src/clx/extensions/shape.lisp - src/clx/xinerama.lisp → src/clx/extensions/xinerama.lisp - src/clx/xrender.lisp → src/clx/extensions/xrender.lisp - src/clx/xtest.lisp → src/clx/extensions/xtest.lisp - src/clx/xvidmode.lisp → src/clx/extensions/xvidmode.lisp - src/tools/clxcom.lisp Changes: ===================================== src/clx/big-requests.lisp → src/clx/extensions/big-requests.lisp ===================================== --- a/src/clx/big-requests.lisp +++ b/src/clx/extensions/big-requests.lisp @@ -12,9 +12,6 @@ ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -#+cmu -(ext:file-comment "$Id: big-requests.lisp,v 1.2 2009/06/17 18:22:45 rtoy Rel $") - (in-package "XLIB") ;;; No new events or errors are defined by this extension. (Big ===================================== src/clx/dpms.lisp → src/clx/extensions/dpms.lisp ===================================== --- a/src/clx/dpms.lisp +++ b/src/clx/extensions/dpms.lisp @@ -13,10 +13,7 @@ ;;;; any purpose of the information in this document. This documentation is ;;;; provided ``as is'' without express or implied warranty. -#+cmu -(ext:file-comment "$Id: dpms.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage :dpms +(defpackage #:xlib/dpms (:use :common-lisp) (:import-from :xlib "DEFINE-EXTENSION" @@ -39,7 +36,7 @@ "DPMS-FORCE-LEVEL" "DPMS-INFO")) -(in-package :dpms) +(in-package #:xlib/dpms) (define-extension "DPMS") ===================================== src/clx/gl.lisp → src/clx/extensions/gl.lisp ===================================== --- a/src/clx/gl.lisp +++ b/src/clx/extensions/gl.lisp @@ -1,9 +1,6 @@ -#+cmu -(ext:file-comment "$Id: gl.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage :gl +(defpackage #:xlib/gl (:use :common-lisp :xlib) - (:import-from :glx + (:import-from :xlib/glx "*CURRENT-CONTEXT*" "CONTEXT" "CONTEXT-P" @@ -1156,7 +1153,7 @@ )) -(in-package :gl) +(in-package #:xlib/gl) @@ -2138,6 +2135,27 @@ value) +#+lispworks +(progn + (defun %single-float-bits (x) + (declare (type single-float x)) + (fli:with-dynamic-foreign-objects ((bits :int32)) + (fli:with-coerced-pointer (pointer :type :lisp-single-float) bits + (setf (fli:dereference pointer) x)) + (fli:dereference bits))) + + (declaim (notinline aset-float32)) + (defun aset-float32 (value array index) + (declare (type (or short-float single-float) value) + (type buffer-bytes array) + (type array-index index)) + #.(declare-buffun) + (let ((bits (%single-float-bits (coerce value 'single-float)))) + (declare (type (unsigned-byte 32) bits)) + (aset-card32 bits array index)) + value)) + + #+sbcl (defun aset-float64 (value array index) (declare (type double-float value) @@ -2180,6 +2198,36 @@ value) +#+lispworks +(progn + (fli:define-c-struct %uint64 + (high :uint32) + (low :uint32)) + + (defun %double-float-bits (x) + (declare (type double-float x)) + (fli:with-dynamic-foreign-objects ((bits %uint64)) + (fli:with-coerced-pointer (pointer :type :lisp-double-float) bits + (setf (fli:dereference pointer) x)) + + (values (fli:foreign-slot-value bits 'low :type :uint32 :object-type '%uint64) + (fli:foreign-slot-value bits 'high :type :uint32 :object-type '%uint64)))) + + (declaim (notinline aset-float64)) + (defun aset-float64 (value array index) + (declare (type double-float value) + (type buffer-bytes array) + (type array-index index)) + #.(declare-buffun) + (multiple-value-bind (low high) + (%double-float-bits value) + (declare (type (unsigned-byte 32) low high)) + + (aset-card32 low array index) + (aset-card32 high array (the array-index (+ index 4)))) + value)) + + (eval-when (:compile-toplevel :load-toplevel :execute) (defun byte-width (type) (ecase type @@ -2593,7 +2641,7 @@ #.+convolution-width+ #.+convolution-height+ #.+max-convolution-width+ - #.+max-convolution-width+) + #.+max-convolution-height+) 1) ((#.+convolution-filter-scale+ #.+convolution-filter-bias+) @@ -2619,7 +2667,7 @@ #.+convolution-width+ #.+convolution-height+ #.+max-convolution-width+ - #.+max-convolution-width+) + #.+max-convolution-height+) 1) ((#.+convolution-filter-scale+ #.+convolution-filter-bias+) ===================================== src/clx/glx.lisp → src/clx/extensions/glx.lisp ===================================== --- a/src/clx/glx.lisp +++ b/src/clx/extensions/glx.lisp @@ -1,7 +1,4 @@ -#+cmu -(ext:file-comment "$Id: glx.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage :glx +(defpackage #:xlib/glx (:use :common-lisp :xlib) (:import-from :xlib "DEFINE-ACCESSOR" @@ -72,11 +69,11 @@ )) -(in-package :glx) - - -(declaim (optimize (debug 3) (safety 3))) +(in-package #:xlib/glx) +;;; Generally don't want this declamation to have load-time effects +(eval-when (:compile-toplevel) + (declaim (optimize (debug 3) (safety 3)))) (define-extension "GLX" :events (:glx-pbuffer-clobber) @@ -599,7 +596,7 @@ Example: '(:glx-rgba (:glx-alpha-size 4) :glx-double-buffer (:glx-class 4 =)." (let* ((ctx *current-context*) (display (context-display ctx))) ;; Make sure all rendering commands are sent away. - (glx:render) + (render) (with-buffer-request (display (extension-opcode display "GLX")) (data +swap-buffers+) ;; *** GLX_CONTEXT_TAG ===================================== src/clx/screensaver.lisp → src/clx/extensions/screensaver.lisp ===================================== ===================================== src/clx/shape.lisp → src/clx/extensions/shape.lisp ===================================== --- a/src/clx/shape.lisp +++ b/src/clx/extensions/shape.lisp @@ -20,9 +20,6 @@ ;;; Use xc/doc/hardcopy/Xext/shape.PS.gz obtainable from e.g. ;; ftp://ftp.xfree86.org/pub/XFree86/current/untarred/xc/hardcopy/Xext/shape.P… -#+cmu -(ext:file-comment "$Id: shape.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) (export '(shape-query-version ===================================== src/clx/xinerama.lisp → src/clx/extensions/xinerama.lisp ===================================== --- a/src/clx/xinerama.lisp +++ b/src/clx/extensions/xinerama.lisp @@ -12,7 +12,7 @@ ;;; This is an implementation of the XINERAMA extension. It does not ;;; include the obsolete PanoramiX calls. -(defpackage "XLIB.XINERAMA" +(defpackage #:xlib/xinerama (:use "COMMON-LISP" "XLIB") (:nicknames "XINERAMA") (:import-from "XLIB" @@ -33,7 +33,7 @@ "XINERAMA-QUERY-VERSION" "XINERAMA-IS-ACTIVE" "XINERAMA-QUERY-SCREENS")) -(in-package "XINERAMA") +(in-package #:xlib/xinerama) (define-extension "XINERAMA") ===================================== src/clx/xrender.lisp → src/clx/extensions/xrender.lisp ===================================== --- a/src/clx/xrender.lisp +++ b/src/clx/extensions/xrender.lisp @@ -3,8 +3,7 @@ ;;; Title: The X Render Extension ;;; Created: 2002-08-03 ;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> -#+cmu -(ext:file-comment "$Id: xrender.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") +;;; $Id: xrender.lisp,v 1.5 2004/12/06 11:48:57 csr21 Exp $ ;;; --------------------------------------------------------------------------- ;;; ;;; (c) copyright 2002, 2003 by Gilbert Baumann @@ -128,6 +127,8 @@ render-query-version ;; render-query-picture-formats render-fill-rectangle + render-triangles + render-trapezoids render-composite render-create-glyph-set render-reference-glyph-set @@ -196,6 +197,24 @@ ;; We do away with the distinction between pict-format and ;; picture-format-info. That is we cache picture-format-infos. +(defstruct picture-format + display + (id 0 :type (unsigned-byte 29)) + type + depth + red-byte + green-byte + blue-byte + alpha-byte + colormap) + +(def-clx-class (glyph-set (:copier nil) + ) + (id 0 :type resource-id) + (display nil :type (or null display)) + (plist nil :type list) ; Extension hook + (format)) + (defstruct render-info major-version minor-version @@ -298,17 +317,6 @@ by every function, which attempts to generate RENDER requests." ;;; picture format -(defstruct picture-format - display - (id 0 :type (unsigned-byte 29)) - type - depth - red-byte - green-byte - blue-byte - alpha-byte - colormap) - (defmethod print-object ((object picture-format) stream) (let ((abbrev (with-output-to-string (bag) @@ -517,13 +525,15 @@ by every function, which attempts to generate RENDER requests." (let ((display (picture-display picture))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderFreePicture+) - (picture picture)))) + (picture picture)) + (deallocate-resource-id display (picture-id picture) 'picture))) (defun render-free-glyph-set (glyph-set) (let ((display (glyph-set-display glyph-set))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderFreeGlyphSet+) - (glyph-set glyph-set)))) + (glyph-set glyph-set)) + (deallocate-resource-id display (glyph-set-id glyph-set) 'glyph-set))) (defun render-query-version (display) (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil) @@ -570,16 +580,16 @@ by every function, which attempts to generate RENDER requests." (synchronise-picture-state picture) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderFillRectangles+) - (render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad + (render-op op) + (pad8 0) + (pad16 0) (resource-id (picture-id picture)) (card16 (elt color 0)) (card16 (elt color 1)) (card16 (elt color 2)) (card16 (elt color 3)) (int16 x1) (int16 y1) (card16 w) (card16 h)))) ;; fill rectangles, colors. -(defun render-triangles-1 (picture op source src-x src-y format coord-sequence) +(defun render-triangles (picture op source src-x src-y format coord-sequence) ;; For performance reasons we do a special typecase on (simple-array ;; (unsigned-byte 32) (*)), so that it'll be possible to have high ;; performance rasters. @@ -587,17 +597,18 @@ by every function, which attempts to generate RENDER requests." '(let ((display (picture-display picture))) (synchronise-picture-state picture) (synchronise-picture-state source) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderTriangles+) - (render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad - (resource-id (picture-id source)) - (resource-id (picture-id picture)) - (picture-format format) - (int16 src-x) - (int16 src-y) - ((sequence :format int32) coord-sequence) )))) + (labels ((funk (x) (ash x 16))) + (with-buffer-request (display (extension-opcode display "RENDER")) + (data +X-RenderTriangles+) + (render-op op) + (pad8 0) + (pad16 0) + (resource-id (picture-id source)) + (resource-id (picture-id picture)) + (picture-format format) + (int16 src-x) + (int16 src-y) + ((sequence :format int32 :transform #'funk) coord-sequence)))))) (typecase coord-sequence ((simple-array (unsigned-byte 32) (*)) (locally @@ -694,7 +705,7 @@ by every function, which attempts to generate RENDER requests." (data +X-RenderSetPictureFilter+) (resource-id (picture-id picture)) (card16 (length filter)) - (card16 0) ;pad + (pad16 0) ((sequence :format card8) (map 'vector #'char-code filter))))) @@ -705,25 +716,26 @@ by every function, which attempts to generate RENDER requests." ) ||# -(defun render-trapezoids-1 (picture op source src-x src-y mask-format coord-sequence) +(defun render-trapezoids (picture op source src-x src-y mask-format coord-sequence) ;; coord-sequence is top bottom - ;; line-1-x1 line-1-y1 line-1-x2 line-1-y2 - ;; line-2-x1 line-2-y1 line-2-x2 line-2-y2 ... + ;; left-x1 left-y1 left-x2 left-y2 + ;; right-x1 right-y1 right-x2 right-y2 ... ;; (let ((display (picture-display picture))) (synchronise-picture-state picture) (synchronise-picture-state source) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderTrapezoids+) - (render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad - (resource-id (picture-id source)) - (resource-id (picture-id picture)) - ((or (member :none) picture-format) mask-format) - (int16 src-x) - (int16 src-y) - ((sequence :format int32) coord-sequence) ))) + (labels ((funk (x) (ash x 16))) + (with-buffer-request (display (extension-opcode display "RENDER")) + (data +X-RenderTrapezoids+) + (render-op op) + (pad8 0) + (pad16 0) + (resource-id (picture-id source)) + (resource-id (picture-id picture)) + ((or (member :none) picture-format) mask-format) + (int16 src-x) + (int16 src-y) + ((sequence :format int32 :transform #'funk) coord-sequence))))) (defun render-composite (op source mask dest @@ -735,9 +747,9 @@ by every function, which attempts to generate RENDER requests." (synchronise-picture-state dest) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderComposite+) - (render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad + (render-op op) + (pad8 0) + (pad16 0) (resource-id (picture-id source)) (resource-id (if mask (picture-id mask) 0)) (resource-id (picture-id dest)) @@ -750,13 +762,6 @@ by every function, which attempts to generate RENDER requests." (card16 width) (card16 height)))) -(def-clx-class (glyph-set (:copier nil) - ) - (id 0 :type resource-id) - (display nil :type (or null display)) - (plist nil :type list) ; Extension hook - (format)) - (defun render-create-glyph-set (format &key glyph-set) (let ((display (picture-format-display format))) (let* ((glyph-set (or glyph-set (make-glyph-set :display display))) @@ -803,14 +808,16 @@ by every function, which attempts to generate RENDER requests." (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderCompositeGlyphs8+) (render-op alu) - (card8 0) (card16 0) ;padding + (pad8 0) + (pad16 0) (picture source) (picture dest) ((or (member :none) picture-format) mask-format) (glyph-set glyph-set) (int16 src-x) (int16 src-y) (card8 (- end start)) ;length of glyph elt - (card8 0) (card16 0) ;padding + (pad8 0) + (pad16 0) (int16 dest-x) (int16 dest-y) ;dx, dy ((sequence :format card8) sequence)))) @@ -832,7 +839,8 @@ by every function, which attempts to generate RENDER requests." (data ,opcode) (length request-length) (render-op ,alu) - (card8 0) (card16 0) ;padding + (pad8 0) + (pad16 0) (picture ,source) (picture ,dest) ((or (member :none) picture-format) ,mask-format) @@ -931,17 +939,27 @@ by every function, which attempts to generate RENDER requests." (unit (bitmap-format-unit bitmap-format)) (byte-lsb-first-p (display-image-lsb-first-p display)) (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) - (let* ((byte-per-line (* 4 (ceiling - (* w (picture-format-depth (glyph-set-format glyph-set))) - 32))) - (request-length (+ 28 - (* h byte-per-line)))) + (let* ((padded-bytes-per-line + (index* (index-ceiling + (index* w (picture-format-depth + (glyph-set-format glyph-set))) + 32) + 4)) + (request-bytes + (index+ 28 (index* h padded-bytes-per-line))) + (max-bytes-per-request + (index* (index- (display-max-request-length display) 6) 4))) + ;; INV: we can do better – if at least one scanline of the + ;; image fits in the request, we may render glyph in a loop + ;; like it's done in a function `put-image' in `image.lisp'. + (when (> request-bytes max-bytes-per-request) + (error "Glyph won't fit in a single request")) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderAddGlyphs+) - (length (ceiling request-length 4)) + (length (ceiling request-bytes 4)) (glyph-set glyph-set) - (card32 1) ;number glyphs - (card32 id) ;id + (card32 1) ;number glyphs + (card32 id) ;id (card16 w) (card16 h) (int16 x-origin) @@ -952,7 +970,7 @@ by every function, which attempts to generate RENDER requests." (setf (buffer-boffset display) (advance-buffer-offset 28)) (let ((im (create-image :width w :height h :depth 8 :data data))) (write-image-z display im 0 0 w h - byte-per-line ;padded bytes per line + padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p)) ))) ))) (defun render-add-glyph-from-picture (glyph-set picture @@ -1153,3 +1171,21 @@ by every function, which attempts to generate RENDER requests." (card16 x) (card16 y)) cursor))) + +(defun render-create-anim-cursor (cursors delays) + "Create animated cursor. cursors length must be the same as delays length." + (let ((display (cursor-display (first cursors)))) + (ensure-render-initialized display) + (let* ((cursor (make-cursor :display display)) + (cid (allocate-resource-id display cursor 'cursor)) + (cursors-length (length cursors)) + (cursors-delays (make-list (* 2 (length cursors))))) + (setf (xlib:cursor-id cursor) cid) + (dotimes (i cursors-length) + (setf (elt cursors-delays (* 2 i)) (cursor-id (elt cursors i)) + (elt cursors-delays (1+ (* 2 i))) (elt delays i))) + (xlib::with-buffer-request (display (extension-opcode display "RENDER")) + (data +X-RenderCreateAnimCursor+) + (resource-id cid) + ((sequence :format card32) cursors-delays)) + cursor))) ===================================== src/clx/xtest.lisp → src/clx/extensions/xtest.lisp ===================================== --- a/src/clx/xtest.lisp +++ b/src/clx/extensions/xtest.lisp @@ -10,7 +10,7 @@ ;;; * Implement XTestSetVisualIDOfVisual and XTestDiscard ;;; * Add the missing (declare (type ... -(defpackage :xtest +(defpackage #:xlib/xtest (:use :common-lisp :xlib) (:import-from :xlib #:data @@ -44,7 +44,7 @@ #:fake-key-event #:grab-control)) -(in-package :xtest) +(in-package #:xlib/xtest) (define-extension "XTEST") ===================================== src/clx/xvidmode.lisp → src/clx/extensions/xvidmode.lisp ===================================== --- a/src/clx/xvidmode.lisp +++ b/src/clx/extensions/xvidmode.lisp @@ -35,9 +35,6 @@ ;;; constructed as well as to indentify any obsolete/wrong ;;; functions I made. -#+cmu -(ext:file-comment "$Id: xvidmode.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) (export '(mode-info @@ -176,6 +173,14 @@ (error "screen ~A not found in display ~A" screen display) position))) +(declaim (inline __card32->card16__)) +(defun __card32->card16__ (i) + (declare (type card32 i)) + #+clx-little-endian + (progn (values (ldb (byte 16 0) i) (ldb (byte 32 16) i))) + #-clx-little-endian + (progn (values (ldb (byte 32 16) i) (ldb (byte 16 0) i)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; ;;;; public XFree86-VidMode Extension routines ;;;; @@ -723,11 +728,3 @@ x and y keyword parameters value (zero will be theire default value)." (setf (svref v (incf index)) w1 (svref v (incf index)) w2)))) v))) - -(declaim (inline __card32->card16__)) -(defun __card32->card16__ (i) - (declare (type card32 i)) - #+clx-little-endian - (progn (values (ldb (byte 16 0) i) (ldb (byte 32 16) i))) - #-clx-little-endian - (progn (values (ldb (byte 32 16) i) (ldb (byte 16 0) i)))) ===================================== src/tools/clxcom.lisp ===================================== --- a/src/tools/clxcom.lisp +++ b/src/tools/clxcom.lisp @@ -68,16 +68,16 @@ (comf "target:clx/manager" :load t) (comf "target:clx/image" :load t) (comf "target:clx/resource" :load t) - (comf "target:clx/shape" :load t) - (comf "target:clx/big-requests" :load t) - (comf "target:clx/xvidmode" :load t) - (comf "target:clx/xrender" :load t) - (comf "target:clx/glx" :load t) - (comf "target:clx/gl" :load t) - (comf "target:clx/dpms" :load t) - (comf "target:clx/screensaver" :load t) - (comf "target:clx/xinerama" :load t) - (comf "target:clx/xtest" :load t)) + (comf "target:clx/extensions/shape" :load t) + (comf "target:clx/extensions/big-requests" :load t) + (comf "target:clx/extensions/xvidmode" :load t) + (comf "target:clx/extensions/xrender" :load t) + (comf "target:clx/extensions/glx" :load t) + (comf "target:clx/extensions/gl" :load t) + (comf "target:clx/extensions/dpms" :load t) + (comf "target:clx/extensions/screensaver" :load t) + (comf "target:clx/extensions/xinerama" :load t) + (comf "target:clx/extensions/xtest" :load t)) (comf "target:code/clx-ext") (comf "target:hemlock/charmacs" :load t) (comf "target:hemlock/key-event" :load t) @@ -109,16 +109,16 @@ "target:clx/manager" "target:clx/image" "target:clx/resource" - "target:clx/shape" - "target:clx/big-requests" - "target:clx/xvidmode" - "target:clx/xrender" - "target:clx/glx" - "target:clx/gl" - "target:clx/dpms" - "target:clx/screensaver" - "target:clx/xinerama" - "target:clx/xtest" + "target:clx/extensions/shape" + "target:clx/extensions/big-requests" + "target:clx/extensions/xvidmode" + "target:clx/extensions/xrender" + "target:clx/extensions/glx" + "target:clx/extensions/gl" + "target:clx/extensions/dpms" + "target:clx/extensions/screensaver" + "target:clx/extensions/xinerama" + "target:clx/extensions/xtest" "target:code/clx-ext" "target:hemlock/charmacs" "target:hemlock/key-event" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/c802a375af8c28462d8d1bfc… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/c802a375af8c28462d8d1bfc… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][rtoy-update-clx] 2 commits: Move these files extensions dir to match upstream clx.
by Raymond Toy 27 Jan '18

27 Jan '18

Raymond Toy pushed to branch rtoy-update-clx at cmucl / cmucl Commits: 6ea45079 by Raymond Toy at 2018-01-27T09:06:25-08:00 Move these files extensions dir to match upstream clx. [skip-ci] - - - - - e6f4c980 by Raymond Toy at 2018-01-27T09:08:11-08:00 Merge upstream changes. [skip-ci] - - - - - 10 changed files: - src/clx/big-requests.lisp → src/clx/extensions/big-requests.lisp - src/clx/dpms.lisp → src/clx/extensions/dpms.lisp - src/clx/gl.lisp → src/clx/extensions/gl.lisp - src/clx/glx.lisp → src/clx/extensions/glx.lisp - src/clx/screensaver.lisp → src/clx/extensions/screensaver.lisp - src/clx/shape.lisp → src/clx/extensions/shape.lisp - src/clx/xinerama.lisp → src/clx/extensions/xinerama.lisp - src/clx/xrender.lisp → src/clx/extensions/xrender.lisp - src/clx/xtest.lisp → src/clx/extensions/xtest.lisp - src/clx/xvidmode.lisp → src/clx/extensions/xvidmode.lisp Changes: ===================================== src/clx/big-requests.lisp → src/clx/extensions/big-requests.lisp ===================================== --- a/src/clx/big-requests.lisp +++ b/src/clx/extensions/big-requests.lisp @@ -12,9 +12,6 @@ ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -#+cmu -(ext:file-comment "$Id: big-requests.lisp,v 1.2 2009/06/17 18:22:45 rtoy Rel $") - (in-package "XLIB") ;;; No new events or errors are defined by this extension. (Big ===================================== src/clx/dpms.lisp → src/clx/extensions/dpms.lisp ===================================== --- a/src/clx/dpms.lisp +++ b/src/clx/extensions/dpms.lisp @@ -13,10 +13,7 @@ ;;;; any purpose of the information in this document. This documentation is ;;;; provided ``as is'' without express or implied warranty. -#+cmu -(ext:file-comment "$Id: dpms.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage :dpms +(defpackage #:xlib/dpms (:use :common-lisp) (:import-from :xlib "DEFINE-EXTENSION" @@ -39,7 +36,7 @@ "DPMS-FORCE-LEVEL" "DPMS-INFO")) -(in-package :dpms) +(in-package #:xlib/dpms) (define-extension "DPMS") ===================================== src/clx/gl.lisp → src/clx/extensions/gl.lisp ===================================== --- a/src/clx/gl.lisp +++ b/src/clx/extensions/gl.lisp @@ -1,9 +1,6 @@ -#+cmu -(ext:file-comment "$Id: gl.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage :gl +(defpackage #:xlib/gl (:use :common-lisp :xlib) - (:import-from :glx + (:import-from :xlib/glx "*CURRENT-CONTEXT*" "CONTEXT" "CONTEXT-P" @@ -1156,7 +1153,7 @@ )) -(in-package :gl) +(in-package #:xlib/gl) @@ -2138,6 +2135,27 @@ value) +#+lispworks +(progn + (defun %single-float-bits (x) + (declare (type single-float x)) + (fli:with-dynamic-foreign-objects ((bits :int32)) + (fli:with-coerced-pointer (pointer :type :lisp-single-float) bits + (setf (fli:dereference pointer) x)) + (fli:dereference bits))) + + (declaim (notinline aset-float32)) + (defun aset-float32 (value array index) + (declare (type (or short-float single-float) value) + (type buffer-bytes array) + (type array-index index)) + #.(declare-buffun) + (let ((bits (%single-float-bits (coerce value 'single-float)))) + (declare (type (unsigned-byte 32) bits)) + (aset-card32 bits array index)) + value)) + + #+sbcl (defun aset-float64 (value array index) (declare (type double-float value) @@ -2180,6 +2198,36 @@ value) +#+lispworks +(progn + (fli:define-c-struct %uint64 + (high :uint32) + (low :uint32)) + + (defun %double-float-bits (x) + (declare (type double-float x)) + (fli:with-dynamic-foreign-objects ((bits %uint64)) + (fli:with-coerced-pointer (pointer :type :lisp-double-float) bits + (setf (fli:dereference pointer) x)) + + (values (fli:foreign-slot-value bits 'low :type :uint32 :object-type '%uint64) + (fli:foreign-slot-value bits 'high :type :uint32 :object-type '%uint64)))) + + (declaim (notinline aset-float64)) + (defun aset-float64 (value array index) + (declare (type double-float value) + (type buffer-bytes array) + (type array-index index)) + #.(declare-buffun) + (multiple-value-bind (low high) + (%double-float-bits value) + (declare (type (unsigned-byte 32) low high)) + + (aset-card32 low array index) + (aset-card32 high array (the array-index (+ index 4)))) + value)) + + (eval-when (:compile-toplevel :load-toplevel :execute) (defun byte-width (type) (ecase type @@ -2593,7 +2641,7 @@ #.+convolution-width+ #.+convolution-height+ #.+max-convolution-width+ - #.+max-convolution-width+) + #.+max-convolution-height+) 1) ((#.+convolution-filter-scale+ #.+convolution-filter-bias+) @@ -2619,7 +2667,7 @@ #.+convolution-width+ #.+convolution-height+ #.+max-convolution-width+ - #.+max-convolution-width+) + #.+max-convolution-height+) 1) ((#.+convolution-filter-scale+ #.+convolution-filter-bias+) ===================================== src/clx/glx.lisp → src/clx/extensions/glx.lisp ===================================== --- a/src/clx/glx.lisp +++ b/src/clx/extensions/glx.lisp @@ -1,7 +1,4 @@ -#+cmu -(ext:file-comment "$Id: glx.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - -(defpackage :glx +(defpackage #:xlib/glx (:use :common-lisp :xlib) (:import-from :xlib "DEFINE-ACCESSOR" @@ -72,11 +69,11 @@ )) -(in-package :glx) - - -(declaim (optimize (debug 3) (safety 3))) +(in-package #:xlib/glx) +;;; Generally don't want this declamation to have load-time effects +(eval-when (:compile-toplevel) + (declaim (optimize (debug 3) (safety 3)))) (define-extension "GLX" :events (:glx-pbuffer-clobber) @@ -599,7 +596,7 @@ Example: '(:glx-rgba (:glx-alpha-size 4) :glx-double-buffer (:glx-class 4 =)." (let* ((ctx *current-context*) (display (context-display ctx))) ;; Make sure all rendering commands are sent away. - (glx:render) + (render) (with-buffer-request (display (extension-opcode display "GLX")) (data +swap-buffers+) ;; *** GLX_CONTEXT_TAG ===================================== src/clx/screensaver.lisp → src/clx/extensions/screensaver.lisp ===================================== ===================================== src/clx/shape.lisp → src/clx/extensions/shape.lisp ===================================== --- a/src/clx/shape.lisp +++ b/src/clx/extensions/shape.lisp @@ -20,9 +20,6 @@ ;;; Use xc/doc/hardcopy/Xext/shape.PS.gz obtainable from e.g. ;; ftp://ftp.xfree86.org/pub/XFree86/current/untarred/xc/hardcopy/Xext/shape.P… -#+cmu -(ext:file-comment "$Id: shape.lisp,v 1.3 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) (export '(shape-query-version ===================================== src/clx/xinerama.lisp → src/clx/extensions/xinerama.lisp ===================================== --- a/src/clx/xinerama.lisp +++ b/src/clx/extensions/xinerama.lisp @@ -12,7 +12,7 @@ ;;; This is an implementation of the XINERAMA extension. It does not ;;; include the obsolete PanoramiX calls. -(defpackage "XLIB.XINERAMA" +(defpackage #:xlib/xinerama (:use "COMMON-LISP" "XLIB") (:nicknames "XINERAMA") (:import-from "XLIB" @@ -33,7 +33,7 @@ "XINERAMA-QUERY-VERSION" "XINERAMA-IS-ACTIVE" "XINERAMA-QUERY-SCREENS")) -(in-package "XINERAMA") +(in-package #:xlib/xinerama) (define-extension "XINERAMA") ===================================== src/clx/xrender.lisp → src/clx/extensions/xrender.lisp ===================================== --- a/src/clx/xrender.lisp +++ b/src/clx/extensions/xrender.lisp @@ -3,8 +3,7 @@ ;;; Title: The X Render Extension ;;; Created: 2002-08-03 ;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> -#+cmu -(ext:file-comment "$Id: xrender.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") +;;; $Id: xrender.lisp,v 1.5 2004/12/06 11:48:57 csr21 Exp $ ;;; --------------------------------------------------------------------------- ;;; ;;; (c) copyright 2002, 2003 by Gilbert Baumann @@ -128,6 +127,8 @@ render-query-version ;; render-query-picture-formats render-fill-rectangle + render-triangles + render-trapezoids render-composite render-create-glyph-set render-reference-glyph-set @@ -196,6 +197,24 @@ ;; We do away with the distinction between pict-format and ;; picture-format-info. That is we cache picture-format-infos. +(defstruct picture-format + display + (id 0 :type (unsigned-byte 29)) + type + depth + red-byte + green-byte + blue-byte + alpha-byte + colormap) + +(def-clx-class (glyph-set (:copier nil) + ) + (id 0 :type resource-id) + (display nil :type (or null display)) + (plist nil :type list) ; Extension hook + (format)) + (defstruct render-info major-version minor-version @@ -298,17 +317,6 @@ by every function, which attempts to generate RENDER requests." ;;; picture format -(defstruct picture-format - display - (id 0 :type (unsigned-byte 29)) - type - depth - red-byte - green-byte - blue-byte - alpha-byte - colormap) - (defmethod print-object ((object picture-format) stream) (let ((abbrev (with-output-to-string (bag) @@ -517,13 +525,15 @@ by every function, which attempts to generate RENDER requests." (let ((display (picture-display picture))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderFreePicture+) - (picture picture)))) + (picture picture)) + (deallocate-resource-id display (picture-id picture) 'picture))) (defun render-free-glyph-set (glyph-set) (let ((display (glyph-set-display glyph-set))) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderFreeGlyphSet+) - (glyph-set glyph-set)))) + (glyph-set glyph-set)) + (deallocate-resource-id display (glyph-set-id glyph-set) 'glyph-set))) (defun render-query-version (display) (with-buffer-request-and-reply (display (extension-opcode display "RENDER") nil) @@ -570,16 +580,16 @@ by every function, which attempts to generate RENDER requests." (synchronise-picture-state picture) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderFillRectangles+) - (render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad + (render-op op) + (pad8 0) + (pad16 0) (resource-id (picture-id picture)) (card16 (elt color 0)) (card16 (elt color 1)) (card16 (elt color 2)) (card16 (elt color 3)) (int16 x1) (int16 y1) (card16 w) (card16 h)))) ;; fill rectangles, colors. -(defun render-triangles-1 (picture op source src-x src-y format coord-sequence) +(defun render-triangles (picture op source src-x src-y format coord-sequence) ;; For performance reasons we do a special typecase on (simple-array ;; (unsigned-byte 32) (*)), so that it'll be possible to have high ;; performance rasters. @@ -587,17 +597,18 @@ by every function, which attempts to generate RENDER requests." '(let ((display (picture-display picture))) (synchronise-picture-state picture) (synchronise-picture-state source) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderTriangles+) - (render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad - (resource-id (picture-id source)) - (resource-id (picture-id picture)) - (picture-format format) - (int16 src-x) - (int16 src-y) - ((sequence :format int32) coord-sequence) )))) + (labels ((funk (x) (ash x 16))) + (with-buffer-request (display (extension-opcode display "RENDER")) + (data +X-RenderTriangles+) + (render-op op) + (pad8 0) + (pad16 0) + (resource-id (picture-id source)) + (resource-id (picture-id picture)) + (picture-format format) + (int16 src-x) + (int16 src-y) + ((sequence :format int32 :transform #'funk) coord-sequence)))))) (typecase coord-sequence ((simple-array (unsigned-byte 32) (*)) (locally @@ -694,7 +705,7 @@ by every function, which attempts to generate RENDER requests." (data +X-RenderSetPictureFilter+) (resource-id (picture-id picture)) (card16 (length filter)) - (card16 0) ;pad + (pad16 0) ((sequence :format card8) (map 'vector #'char-code filter))))) @@ -705,25 +716,26 @@ by every function, which attempts to generate RENDER requests." ) ||# -(defun render-trapezoids-1 (picture op source src-x src-y mask-format coord-sequence) +(defun render-trapezoids (picture op source src-x src-y mask-format coord-sequence) ;; coord-sequence is top bottom - ;; line-1-x1 line-1-y1 line-1-x2 line-1-y2 - ;; line-2-x1 line-2-y1 line-2-x2 line-2-y2 ... + ;; left-x1 left-y1 left-x2 left-y2 + ;; right-x1 right-y1 right-x2 right-y2 ... ;; (let ((display (picture-display picture))) (synchronise-picture-state picture) (synchronise-picture-state source) - (with-buffer-request (display (extension-opcode display "RENDER")) - (data +X-RenderTrapezoids+) - (render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad - (resource-id (picture-id source)) - (resource-id (picture-id picture)) - ((or (member :none) picture-format) mask-format) - (int16 src-x) - (int16 src-y) - ((sequence :format int32) coord-sequence) ))) + (labels ((funk (x) (ash x 16))) + (with-buffer-request (display (extension-opcode display "RENDER")) + (data +X-RenderTrapezoids+) + (render-op op) + (pad8 0) + (pad16 0) + (resource-id (picture-id source)) + (resource-id (picture-id picture)) + ((or (member :none) picture-format) mask-format) + (int16 src-x) + (int16 src-y) + ((sequence :format int32 :transform #'funk) coord-sequence))))) (defun render-composite (op source mask dest @@ -735,9 +747,9 @@ by every function, which attempts to generate RENDER requests." (synchronise-picture-state dest) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderComposite+) - (render-op op) ;op - (card8 0) ;pad - (card16 0) ;pad + (render-op op) + (pad8 0) + (pad16 0) (resource-id (picture-id source)) (resource-id (if mask (picture-id mask) 0)) (resource-id (picture-id dest)) @@ -750,13 +762,6 @@ by every function, which attempts to generate RENDER requests." (card16 width) (card16 height)))) -(def-clx-class (glyph-set (:copier nil) - ) - (id 0 :type resource-id) - (display nil :type (or null display)) - (plist nil :type list) ; Extension hook - (format)) - (defun render-create-glyph-set (format &key glyph-set) (let ((display (picture-format-display format))) (let* ((glyph-set (or glyph-set (make-glyph-set :display display))) @@ -803,14 +808,16 @@ by every function, which attempts to generate RENDER requests." (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderCompositeGlyphs8+) (render-op alu) - (card8 0) (card16 0) ;padding + (pad8 0) + (pad16 0) (picture source) (picture dest) ((or (member :none) picture-format) mask-format) (glyph-set glyph-set) (int16 src-x) (int16 src-y) (card8 (- end start)) ;length of glyph elt - (card8 0) (card16 0) ;padding + (pad8 0) + (pad16 0) (int16 dest-x) (int16 dest-y) ;dx, dy ((sequence :format card8) sequence)))) @@ -832,7 +839,8 @@ by every function, which attempts to generate RENDER requests." (data ,opcode) (length request-length) (render-op ,alu) - (card8 0) (card16 0) ;padding + (pad8 0) + (pad16 0) (picture ,source) (picture ,dest) ((or (member :none) picture-format) ,mask-format) @@ -931,17 +939,27 @@ by every function, which attempts to generate RENDER requests." (unit (bitmap-format-unit bitmap-format)) (byte-lsb-first-p (display-image-lsb-first-p display)) (bit-lsb-first-p (bitmap-format-lsb-first-p bitmap-format))) - (let* ((byte-per-line (* 4 (ceiling - (* w (picture-format-depth (glyph-set-format glyph-set))) - 32))) - (request-length (+ 28 - (* h byte-per-line)))) + (let* ((padded-bytes-per-line + (index* (index-ceiling + (index* w (picture-format-depth + (glyph-set-format glyph-set))) + 32) + 4)) + (request-bytes + (index+ 28 (index* h padded-bytes-per-line))) + (max-bytes-per-request + (index* (index- (display-max-request-length display) 6) 4))) + ;; INV: we can do better – if at least one scanline of the + ;; image fits in the request, we may render glyph in a loop + ;; like it's done in a function `put-image' in `image.lisp'. + (when (> request-bytes max-bytes-per-request) + (error "Glyph won't fit in a single request")) (with-buffer-request (display (extension-opcode display "RENDER")) (data +X-RenderAddGlyphs+) - (length (ceiling request-length 4)) + (length (ceiling request-bytes 4)) (glyph-set glyph-set) - (card32 1) ;number glyphs - (card32 id) ;id + (card32 1) ;number glyphs + (card32 id) ;id (card16 w) (card16 h) (int16 x-origin) @@ -952,7 +970,7 @@ by every function, which attempts to generate RENDER requests." (setf (buffer-boffset display) (advance-buffer-offset 28)) (let ((im (create-image :width w :height h :depth 8 :data data))) (write-image-z display im 0 0 w h - byte-per-line ;padded bytes per line + padded-bytes-per-line unit byte-lsb-first-p bit-lsb-first-p)) ))) ))) (defun render-add-glyph-from-picture (glyph-set picture @@ -1153,3 +1171,21 @@ by every function, which attempts to generate RENDER requests." (card16 x) (card16 y)) cursor))) + +(defun render-create-anim-cursor (cursors delays) + "Create animated cursor. cursors length must be the same as delays length." + (let ((display (cursor-display (first cursors)))) + (ensure-render-initialized display) + (let* ((cursor (make-cursor :display display)) + (cid (allocate-resource-id display cursor 'cursor)) + (cursors-length (length cursors)) + (cursors-delays (make-list (* 2 (length cursors))))) + (setf (xlib:cursor-id cursor) cid) + (dotimes (i cursors-length) + (setf (elt cursors-delays (* 2 i)) (cursor-id (elt cursors i)) + (elt cursors-delays (1+ (* 2 i))) (elt delays i))) + (xlib::with-buffer-request (display (extension-opcode display "RENDER")) + (data +X-RenderCreateAnimCursor+) + (resource-id cid) + ((sequence :format card32) cursors-delays)) + cursor))) ===================================== src/clx/xtest.lisp → src/clx/extensions/xtest.lisp ===================================== --- a/src/clx/xtest.lisp +++ b/src/clx/extensions/xtest.lisp @@ -10,7 +10,7 @@ ;;; * Implement XTestSetVisualIDOfVisual and XTestDiscard ;;; * Add the missing (declare (type ... -(defpackage :xtest +(defpackage #:xlib/xtest (:use :common-lisp :xlib) (:import-from :xlib #:data @@ -44,7 +44,7 @@ #:fake-key-event #:grab-control)) -(in-package :xtest) +(in-package #:xlib/xtest) (define-extension "XTEST") ===================================== src/clx/xvidmode.lisp → src/clx/extensions/xvidmode.lisp ===================================== --- a/src/clx/xvidmode.lisp +++ b/src/clx/extensions/xvidmode.lisp @@ -35,9 +35,6 @@ ;;; constructed as well as to indentify any obsolete/wrong ;;; functions I made. -#+cmu -(ext:file-comment "$Id: xvidmode.lisp,v 1.2 2009/06/17 18:22:46 rtoy Rel $") - (in-package :xlib) (export '(mode-info @@ -176,6 +173,14 @@ (error "screen ~A not found in display ~A" screen display) position))) +(declaim (inline __card32->card16__)) +(defun __card32->card16__ (i) + (declare (type card32 i)) + #+clx-little-endian + (progn (values (ldb (byte 16 0) i) (ldb (byte 32 16) i))) + #-clx-little-endian + (progn (values (ldb (byte 32 16) i) (ldb (byte 16 0) i)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; ;;;; public XFree86-VidMode Extension routines ;;;; @@ -723,11 +728,3 @@ x and y keyword parameters value (zero will be theire default value)." (setf (svref v (incf index)) w1 (svref v (incf index)) w2)))) v))) - -(declaim (inline __card32->card16__)) -(defun __card32->card16__ (i) - (declare (type card32 i)) - #+clx-little-endian - (progn (values (ldb (byte 16 0) i) (ldb (byte 32 16) i))) - #-clx-little-endian - (progn (values (ldb (byte 32 16) i) (ldb (byte 16 0) i)))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/c8ebc741ea5a442b55d13170… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/c8ebc741ea5a442b55d13170… 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] 2 commits: Put back open-x-stream.
by Raymond Toy 27 Jan '18

27 Jan '18

Raymond Toy pushed to branch rtoy-update-clx-with-cmucl-fixes at cmucl / cmucl Commits: c54f706e by Raymond Toy at 2018-01-24T09:40:50-08:00 Put back open-x-stream. Brought back from the master branch. - - - - - c802a375 by Raymond Toy at 2018-01-24T09:41:32-08:00 Disable arglist declaration for cmucl Don't know why this doesn't work, but removing it makes the macro compile correctly. - - - - - 2 changed files: - src/clx/dependent.lisp - src/clx/macros.lisp Changes: ===================================== src/clx/dependent.lisp ===================================== --- a/src/clx/dependent.lisp +++ b/src/clx/dependent.lisp @@ -1582,6 +1582,47 @@ :element-type '(unsigned-byte 8) :input t :output t :buffering :none)) +#+cmu +(defun open-x-stream (host display protocol) + (let ((stream-fd + (ecase protocol + ;; establish a TCP connection to the X11 server, which is + ;; listening on port 6000 + display-number + ((:internet :tcp nil) + (let ((fd (ext:connect-to-inet-socket host (+ *x-tcp-port* display)))) + (unless (plusp fd) + (error 'connection-failure + :major-version *protocol-major-version* + :minor-version *protocol-minor-version* + :host host + :display display + :reason (format nil "Cannot connect to internet socket: ~S" + (unix:get-unix-error-msg)))) + fd)) + ;; establish a connection to the X11 server over a Unix + ;; socket. (:|| comes from Darwin's weird DISPLAY + ;; environment variable) + ((:unix :local :||) + (let ((path (unix-socket-path-from-host host display))) + (unless (probe-file path) + (error 'connection-failure + :major-version *protocol-major-version* + :minor-version *protocol-minor-version* + :host host + :display display + :reason (format nil "Unix socket ~s does not exist" path))) + (let ((fd (ext:connect-to-unix-socket (namestring path)))) + (unless (plusp fd) + (error 'connection-failure + :major-version *protocol-major-version* + :minor-version *protocol-minor-version* + :host host + :display display + :reason (format nil "Can't connect to unix socket: ~S" + (unix:get-unix-error-msg)))) + fd)))))) + (system:make-fd-stream stream-fd :input t :output t :element-type '(unsigned-byte 8)))) + ;;; BUFFER-READ-DEFAULT - read data from the X stream #+(or Genera explorer) @@ -3355,11 +3396,11 @@ Returns a list of (host display-number screen protocol)." height width) (declare (type array-index source-width sx sy dest-width dx dy height width)) #.(declare-buffun) - (kernel::with-array-data ((sdata source) + (lisp::with-array-data ((sdata source) (sstart) (send)) (declare (ignore send)) - (kernel::with-array-data ((ddata dest) + (lisp::with-array-data ((ddata dest) (dstart) (dend)) (declare (ignore dend)) ===================================== src/clx/macros.lisp ===================================== --- a/src/clx/macros.lisp +++ b/src/clx/macros.lisp @@ -85,6 +85,7 @@ ;; If no third body form is present, then these macros assume that ;; (AND (TYPEP ,thing 'type) (PUT-type ,thing)) can be generated. ;; these predicating puts are used by the OR accessor. + #-cmu (declare (arglist name (width) get-macro put-macro &optional predicating-put-macro)) (when (cdddr get-put-macros) (error "Too many parameters to define-accessor: ~s" (cdddr get-put-macros))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/a596444836a656fd62f0b565… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/a596444836a656fd62f0b565… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch rtoy-update-clx-with-cmucl-fixes
by Raymond Toy 24 Jan '18

24 Jan '18

Raymond Toy pushed new branch rtoy-update-clx-with-cmucl-fixes at cmucl / cmucl --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/tree/rtoy-update-clx-with-cmucl-… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch rtoy-update-clx
by Raymond Toy 24 Jan '18

24 Jan '18

Raymond Toy pushed new branch rtoy-update-clx at cmucl / cmucl --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/tree/rtoy-update-clx You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Simplify script by adding variables.
by Raymond Toy 21 Jan '18

21 Jan '18

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 1cbde1a1 by Raymond Toy at 2018-01-21T13:31:37-08:00 Simplify script by adding variables. Add variables to the download url and for the version so we can share them across linux and osx builds. - - - - - 63199010 by Raymond Toy at 2018-01-21T22:44:23+00:00 Merge branch 'rtoy-simplify-ci' into 'master' Simplify script by adding variables. See merge request cmucl/cmucl!30 - - - - - 1 changed file: - .gitlab-ci.yml Changes: ===================================== .gitlab-ci.yml ===================================== --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1,12 +1,16 @@ +variables: + download_url: "https://common-lisp.net/project/cmucl/downloads/snapshots/2018/01" + version: "2018-01-x86" + linux-runner: tags: - linux before_script: - apt-get update -qq && apt-get install -y wget bzip2 make gcc gcc-multilib time bc git - - wget -nv https://common-lisp.net/project/cmucl/downloads/snapshots/2018/01/cmucl-201… - - wget -nv https://common-lisp.net/project/cmucl/downloads/snapshots/2018/01/cmucl-201… + - wget -nv $download_url/cmucl-$version-linux.tar.bz2 + - wget -nv $download_url/cmucl-$version-linux.extra.tar.bz2 - mkdir snapshot - - (cd snapshot; tar xjf ../cmucl-2018-01-x86-linux.tar.bz2; tar xjf ../cmucl-2018-01-x86-linux.extra.tar.bz2) + - (cd snapshot; tar xjf ../cmucl-$version-linux.tar.bz2; tar xjf ../cmucl-$version-linux.extra.tar.bz2) script: - bin/build.sh -C "" -o snapshot/bin/lisp - bin/make-dist.sh -I dist linux-4 @@ -16,9 +20,9 @@ osx-runner: tags: - osx before_script: - - curl -s -o cmucl-2018-01-x86-darwin.tar.bz2 https://common-lisp.net/project/cmucl/downloads/snapshots/2018/01//cmucl-20… + - curl -s -o cmucl-$version-darwin.tar.bz2 $download_url/cmucl-$version-darwin.tar.bz2 - mkdir snapshot - - (cd snapshot; tar xjf ../cmucl-2018-01-x86-darwin.tar.bz2) + - (cd snapshot; tar xjf ../cmucl-$version-darwin.tar.bz2) script: - bin/build.sh -C "" -o snapshot/bin/lisp - bin/make-dist.sh -I dist darwin-4 View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/5df2081377d7f79f5e289275… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/5df2081377d7f79f5e289275… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch rtoy-simplify-ci
by Raymond Toy 21 Jan '18

21 Jan '18

Raymond Toy pushed new branch rtoy-simplify-ci at cmucl / cmucl --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/tree/rtoy-simplify-ci You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Don't show progress meter with curl
by Raymond Toy 21 Jan '18

21 Jan '18

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 5df20813 by Raymond Toy at 2018-01-21T09:35:16-08:00 Don't show progress meter with curl Don't need the progress meter; it just clutters up the logs with useless stuff [skip-ci] - - - - - 1 changed file: - .gitlab-ci.yml Changes: ===================================== .gitlab-ci.yml ===================================== --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -16,7 +16,7 @@ osx-runner: tags: - osx before_script: - - curl -o cmucl-2018-01-x86-darwin.tar.bz2 https://common-lisp.net/project/cmucl/downloads/snapshots/2018/01//cmucl-20… + - curl -s -o cmucl-2018-01-x86-darwin.tar.bz2 https://common-lisp.net/project/cmucl/downloads/snapshots/2018/01//cmucl-20… - mkdir snapshot - (cd snapshot; tar xjf ../cmucl-2018-01-x86-darwin.tar.bz2) script: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/5df2081377d7f79f5e2892756… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/5df2081377d7f79f5e2892756… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Fix typo in building on darwin.
by Raymond Toy 21 Jan '18

21 Jan '18

Raymond Toy pushed to branch master at cmucl / cmucl Commits: ab27781b by Raymond Toy at 2018-01-21T08:55:56-08:00 Fix typo in building on darwin. Should be snapshot/bin/lisp - - - - - 1 changed file: - .gitlab-ci.yml Changes: ===================================== .gitlab-ci.yml ===================================== --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -20,6 +20,6 @@ osx-runner: - mkdir snapshot - (cd snapshot; tar xjf ../cmucl-2018-01-x86-darwin.tar.bz2) script: - - bin/build.sh -C "" -o snapshot/lisp/lisp + - bin/build.sh -C "" -o snapshot/bin/lisp - bin/make-dist.sh -I dist darwin-4 - bin/run-tests.sh -l dist/bin/lisp 2>&1 | tee test.log View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/ab27781ba923fff4144c5919b… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/ab27781ba923fff4144c5919b… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Update CI to use 2018-01 snapshot
by Raymond Toy 21 Jan '18

21 Jan '18

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 91c26cba by Raymond Toy at 2018-01-21T08:50:35-08:00 Update CI to use 2018-01 snapshot - - - - - 1 changed file: - .gitlab-ci.yml Changes: ===================================== .gitlab-ci.yml ===================================== --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -3,15 +3,12 @@ linux-runner: - linux before_script: - apt-get update -qq && apt-get install -y wget bzip2 make gcc gcc-multilib time bc git - - wget -nv https://common-lisp.net/project/cmucl/downloads/release/21c/cmucl-21c-x86-l… - - wget -nv https://common-lisp.net/project/cmucl/downloads/release/21c/cmucl-21c-x86-l… + - wget -nv https://common-lisp.net/project/cmucl/downloads/snapshots/2018/01/cmucl-201… + - wget -nv https://common-lisp.net/project/cmucl/downloads/snapshots/2018/01/cmucl-201… - mkdir snapshot - - (cd snapshot; tar xjf ../cmucl-21c-x86-linux.tar.bz2; tar xjf ../cmucl-21c-x86-linux.extra.tar.bz2) + - (cd snapshot; tar xjf ../cmucl-2018-01-x86-linux.tar.bz2; tar xjf ../cmucl-2018-01-x86-linux.extra.tar.bz2) script: - - bin/create-target.sh xtarget x86_linux x86 - - bin/create-target.sh xcross x86_linux x86 - - bin/cross-build-world.sh -crl xtarget xcross src/bootfiles/21c/boot-21c-cross.lisp ./snapshot/bin/lisp - - bin/build.sh -C "" -o xtarget/lisp/lisp + - bin/build.sh -C "" -o snapshot/bin/lisp - bin/make-dist.sh -I dist linux-4 - bin/run-tests.sh -l dist/bin/lisp 2>&1 | tee test.log @@ -19,13 +16,10 @@ osx-runner: tags: - osx before_script: - - curl -o cmucl-21c-x86-darwin.tar.bz2 https://common-lisp.net/project/cmucl/downloads/release/21c/cmucl-21c-x86-d… + - curl -o cmucl-2018-01-x86-darwin.tar.bz2 https://common-lisp.net/project/cmucl/downloads/snapshots/2018/01//cmucl-20… - mkdir snapshot - - (cd snapshot; tar xjf ../cmucl-21c-x86-darwin.tar.bz2) + - (cd snapshot; tar xjf ../cmucl-2018-01-x86-darwin.tar.bz2) script: - - bin/create-target.sh xtarget x86_darwin - - bin/create-target.sh xcross x86_darwin - - bin/cross-build-world.sh -crl xtarget xcross src/bootfiles/21c/boot-21c-cross.lisp ./snapshot/bin/lisp - - bin/build.sh -C "" -o xtarget/lisp/lisp + - bin/build.sh -C "" -o snapshot/lisp/lisp - bin/make-dist.sh -I dist darwin-4 - bin/run-tests.sh -l dist/bin/lisp 2>&1 | tee test.log View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/91c26cba71fecb8b8e0b3c822… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/91c26cba71fecb8b8e0b3c822… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][sparc64-dev] 2 commits: Regenerate
by Raymond Toy 20 Jan '18

20 Jan '18

Raymond Toy pushed to branch sparc64-dev at cmucl / cmucl Commits: f19dd877 by Raymond Toy at 2018-01-13T08:22:44-08:00 Regenerate - - - - - 9ce8a07e by Raymond Toy at 2018-01-20T09:20:19-08:00 Merge branch 'master' into sparc64-dev - - - - - 2 changed files: - src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po - src/i18n/locale/ko/LC_MESSAGES/cmucl.po Changes: ===================================== src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po ===================================== --- a/src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po +++ b/src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po @@ -34,7 +34,7 @@ msgstr "Ethay izesay ofway away eamstray inway-ufferbay." #: src/code/intl.lisp src/compiler/globaldb.lisp src/code/defstruct.lisp #: src/code/remote.lisp src/code/wire.lisp src/code/internet.lisp #: src/code/loop.lisp src/code/run-program.lisp src/code/parse-time.lisp -#: src/code/profile.lisp src/code/ntrace.lisp src/code/rand-mt19937.lisp +#: src/code/profile.lisp src/code/ntrace.lisp src/code/rand-xoroshiro.lisp #: src/code/debug.lisp src/code/debug-int.lisp src/code/debug-info.lisp #: src/code/eval.lisp src/code/filesys.lisp src/code/pathname.lisp #: src/code/fd-stream.lisp src/code/extfmts.lisp src/code/serve-event.lisp @@ -17335,17 +17335,18 @@ msgstr "" msgid "Type \"yes\" for yes or \"no\" for no. " msgstr "Ypetay \"esyay\" orfay esyay orway \"onay\" orfay onay. " -#: src/code/rand-mt19937.lisp +#: src/code/rand-xoroshiro.lisp +#, fuzzy msgid "" "Generate an random state vector from the given SEED. The seed can be\n" -" either an integer or a vector of (unsigned-byte 32)" +" either an integer or a vector of (unsigned-byte 64)" msgstr "" "Enerategay anway andomray tatesay ectorvay omfray ethay ivengay SEED. Ethay " "eedsay ancay ebay\n" " eitherway anway integerway orway away ectorvay ofway (unsignedway-ytebay " "32)" -#: src/code/rand-mt19937.lisp +#: src/code/rand-xoroshiro.lisp msgid "" "Make a random state object. If STATE is not supplied, return a copy\n" " of the default random state. If STATE is a random state, then return a\n" @@ -17360,11 +17361,12 @@ msgstr "" "tatesay eneratedgay omfray\n" " ethay universalway imetay orway /evday/urandomway ifway availableway." -#: src/code/rand-mt19937.lisp -msgid "Argument is not a RANDOM-STATE, T or NIL: ~S" +#: src/code/rand-xoroshiro.lisp +#, fuzzy +msgid "Argument is not a RANDOM-STATE, T, or NIL: ~S" msgstr "Argumentway isway otnay away RANDOM-STATE, T orway NIL: ~S" -#: src/code/rand-mt19937.lisp +#: src/code/rand-xoroshiro.lisp msgid "" "Generate a uniformly distributed pseudo-random number between zero\n" " and Arg. State, if supplied, is the random state to use." @@ -17374,12 +17376,19 @@ msgstr "" " andway Argway. Tatesay, ifway uppliedsay, isway ethay andomray tatesay " "otay useway." -#: src/code/rand-mt19937.lisp +#: src/code/rand-xoroshiro.lisp msgid "Argument is not a positive integer or a positive float: ~S" msgstr "" "Argumentway isway otnay away ositivepay integerway orway away ositivepay " "oatflay: ~S" +#: src/code/rand-xoroshiro.lisp +msgid "" +"Jump the RNG-STATE. This is equivalent to 2^64 calls to the\n" +" xoroshiro128+ generator. It can be used to generate 2^64\n" +" non-overlapping subsequences for parallel computations." +msgstr "" + #: src/code/ntrace.lisp msgid "" "This is bound to the returned values when evaluating :BREAK-AFTER and\n" @@ -27348,10 +27357,6 @@ msgid "use inline (unsigned-byte 32) operations" msgstr "useway inlineway (unsignedway-ytebay 32) operationsway" #: src/compiler/float-tran.lisp -msgid "Shouldn't happen" -msgstr "Ouldnshay't appenhay" - -#: src/compiler/float-tran.lisp msgid "Can't open-code float to rational comparison." msgstr "Ancay't openway-odecay oatflay otay ationalray omparisoncay." @@ -30979,6 +30984,9 @@ msgstr "" "eplacedray ybay ethay\n" "Unicodeway eplacementray aracterchay." +#~ msgid "Shouldn't happen" +#~ msgstr "Ouldnshay't appenhay" + #~ msgid "No such program: ~S" #~ msgstr "Onay uchsay ogrampray: ~S" ===================================== src/i18n/locale/ko/LC_MESSAGES/cmucl.po ===================================== --- a/src/i18n/locale/ko/LC_MESSAGES/cmucl.po +++ b/src/i18n/locale/ko/LC_MESSAGES/cmucl.po @@ -34,7 +34,7 @@ msgstr "스트림 인 버퍼의 크기." #: src/code/intl.lisp src/compiler/globaldb.lisp src/code/defstruct.lisp #: src/code/remote.lisp src/code/wire.lisp src/code/internet.lisp #: src/code/loop.lisp src/code/run-program.lisp src/code/parse-time.lisp -#: src/code/profile.lisp src/code/ntrace.lisp src/code/rand-mt19937.lisp +#: src/code/profile.lisp src/code/ntrace.lisp src/code/rand-xoroshiro.lisp #: src/code/debug.lisp src/code/debug-int.lisp src/code/debug-info.lisp #: src/code/eval.lisp src/code/filesys.lisp src/code/pathname.lisp #: src/code/fd-stream.lisp src/code/extfmts.lisp src/code/serve-event.lisp @@ -12130,13 +12130,13 @@ msgstr "" msgid "Type \"yes\" for yes or \"no\" for no. " msgstr "" -#: src/code/rand-mt19937.lisp +#: src/code/rand-xoroshiro.lisp msgid "" "Generate an random state vector from the given SEED. The seed can be\n" -" either an integer or a vector of (unsigned-byte 32)" +" either an integer or a vector of (unsigned-byte 64)" msgstr "" -#: src/code/rand-mt19937.lisp +#: src/code/rand-xoroshiro.lisp msgid "" "Make a random state object. If STATE is not supplied, return a copy\n" " of the default random state. If STATE is a random state, then return a\n" @@ -12144,20 +12144,27 @@ msgid "" " the universal time or /dev/urandom if available." msgstr "" -#: src/code/rand-mt19937.lisp -msgid "Argument is not a RANDOM-STATE, T or NIL: ~S" +#: src/code/rand-xoroshiro.lisp +msgid "Argument is not a RANDOM-STATE, T, or NIL: ~S" msgstr "" -#: src/code/rand-mt19937.lisp +#: src/code/rand-xoroshiro.lisp msgid "" "Generate a uniformly distributed pseudo-random number between zero\n" " and Arg. State, if supplied, is the random state to use." msgstr "" -#: src/code/rand-mt19937.lisp +#: src/code/rand-xoroshiro.lisp msgid "Argument is not a positive integer or a positive float: ~S" msgstr "" +#: src/code/rand-xoroshiro.lisp +msgid "" +"Jump the RNG-STATE. This is equivalent to 2^64 calls to the\n" +" xoroshiro128+ generator. It can be used to generate 2^64\n" +" non-overlapping subsequences for parallel computations." +msgstr "" + #: src/code/ntrace.lisp msgid "" "This is bound to the returned values when evaluating :BREAK-AFTER and\n" @@ -18909,10 +18916,6 @@ msgid "use inline (unsigned-byte 32) operations" msgstr "" #: src/compiler/float-tran.lisp -msgid "Shouldn't happen" -msgstr "" - -#: src/compiler/float-tran.lisp msgid "Can't open-code float to rational comparison." msgstr "" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/11e8aafe5be25c1ad2b99854… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/11e8aafe5be25c1ad2b99854… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new tag snapshot-2018-01
by Raymond Toy 15 Jan '18

15 Jan '18

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

1 0

[Git][cmucl/cmucl][master] Regenerate
by Raymond Toy 13 Jan '18

13 Jan '18

Raymond Toy pushed to branch master at cmucl / cmucl Commits: f19dd877 by Raymond Toy at 2018-01-13T08:22:44-08:00 Regenerate - - - - - 2 changed files: - src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po - src/i18n/locale/ko/LC_MESSAGES/cmucl.po Changes: ===================================== src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po ===================================== --- a/src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po +++ b/src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po @@ -34,7 +34,7 @@ msgstr "Ethay izesay ofway away eamstray inway-ufferbay." #: src/code/intl.lisp src/compiler/globaldb.lisp src/code/defstruct.lisp #: src/code/remote.lisp src/code/wire.lisp src/code/internet.lisp #: src/code/loop.lisp src/code/run-program.lisp src/code/parse-time.lisp -#: src/code/profile.lisp src/code/ntrace.lisp src/code/rand-mt19937.lisp +#: src/code/profile.lisp src/code/ntrace.lisp src/code/rand-xoroshiro.lisp #: src/code/debug.lisp src/code/debug-int.lisp src/code/debug-info.lisp #: src/code/eval.lisp src/code/filesys.lisp src/code/pathname.lisp #: src/code/fd-stream.lisp src/code/extfmts.lisp src/code/serve-event.lisp @@ -17335,17 +17335,18 @@ msgstr "" msgid "Type \"yes\" for yes or \"no\" for no. " msgstr "Ypetay \"esyay\" orfay esyay orway \"onay\" orfay onay. " -#: src/code/rand-mt19937.lisp +#: src/code/rand-xoroshiro.lisp +#, fuzzy msgid "" "Generate an random state vector from the given SEED. The seed can be\n" -" either an integer or a vector of (unsigned-byte 32)" +" either an integer or a vector of (unsigned-byte 64)" msgstr "" "Enerategay anway andomray tatesay ectorvay omfray ethay ivengay SEED. Ethay " "eedsay ancay ebay\n" " eitherway anway integerway orway away ectorvay ofway (unsignedway-ytebay " "32)" -#: src/code/rand-mt19937.lisp +#: src/code/rand-xoroshiro.lisp msgid "" "Make a random state object. If STATE is not supplied, return a copy\n" " of the default random state. If STATE is a random state, then return a\n" @@ -17360,11 +17361,12 @@ msgstr "" "tatesay eneratedgay omfray\n" " ethay universalway imetay orway /evday/urandomway ifway availableway." -#: src/code/rand-mt19937.lisp -msgid "Argument is not a RANDOM-STATE, T or NIL: ~S" +#: src/code/rand-xoroshiro.lisp +#, fuzzy +msgid "Argument is not a RANDOM-STATE, T, or NIL: ~S" msgstr "Argumentway isway otnay away RANDOM-STATE, T orway NIL: ~S" -#: src/code/rand-mt19937.lisp +#: src/code/rand-xoroshiro.lisp msgid "" "Generate a uniformly distributed pseudo-random number between zero\n" " and Arg. State, if supplied, is the random state to use." @@ -17374,12 +17376,19 @@ msgstr "" " andway Argway. Tatesay, ifway uppliedsay, isway ethay andomray tatesay " "otay useway." -#: src/code/rand-mt19937.lisp +#: src/code/rand-xoroshiro.lisp msgid "Argument is not a positive integer or a positive float: ~S" msgstr "" "Argumentway isway otnay away ositivepay integerway orway away ositivepay " "oatflay: ~S" +#: src/code/rand-xoroshiro.lisp +msgid "" +"Jump the RNG-STATE. This is equivalent to 2^64 calls to the\n" +" xoroshiro128+ generator. It can be used to generate 2^64\n" +" non-overlapping subsequences for parallel computations." +msgstr "" + #: src/code/ntrace.lisp msgid "" "This is bound to the returned values when evaluating :BREAK-AFTER and\n" @@ -27348,10 +27357,6 @@ msgid "use inline (unsigned-byte 32) operations" msgstr "useway inlineway (unsignedway-ytebay 32) operationsway" #: src/compiler/float-tran.lisp -msgid "Shouldn't happen" -msgstr "Ouldnshay't appenhay" - -#: src/compiler/float-tran.lisp msgid "Can't open-code float to rational comparison." msgstr "Ancay't openway-odecay oatflay otay ationalray omparisoncay." @@ -30979,6 +30984,9 @@ msgstr "" "eplacedray ybay ethay\n" "Unicodeway eplacementray aracterchay." +#~ msgid "Shouldn't happen" +#~ msgstr "Ouldnshay't appenhay" + #~ msgid "No such program: ~S" #~ msgstr "Onay uchsay ogrampray: ~S" ===================================== src/i18n/locale/ko/LC_MESSAGES/cmucl.po ===================================== --- a/src/i18n/locale/ko/LC_MESSAGES/cmucl.po +++ b/src/i18n/locale/ko/LC_MESSAGES/cmucl.po @@ -34,7 +34,7 @@ msgstr "스트림 인 버퍼의 크기." #: src/code/intl.lisp src/compiler/globaldb.lisp src/code/defstruct.lisp #: src/code/remote.lisp src/code/wire.lisp src/code/internet.lisp #: src/code/loop.lisp src/code/run-program.lisp src/code/parse-time.lisp -#: src/code/profile.lisp src/code/ntrace.lisp src/code/rand-mt19937.lisp +#: src/code/profile.lisp src/code/ntrace.lisp src/code/rand-xoroshiro.lisp #: src/code/debug.lisp src/code/debug-int.lisp src/code/debug-info.lisp #: src/code/eval.lisp src/code/filesys.lisp src/code/pathname.lisp #: src/code/fd-stream.lisp src/code/extfmts.lisp src/code/serve-event.lisp @@ -12130,13 +12130,13 @@ msgstr "" msgid "Type \"yes\" for yes or \"no\" for no. " msgstr "" -#: src/code/rand-mt19937.lisp +#: src/code/rand-xoroshiro.lisp msgid "" "Generate an random state vector from the given SEED. The seed can be\n" -" either an integer or a vector of (unsigned-byte 32)" +" either an integer or a vector of (unsigned-byte 64)" msgstr "" -#: src/code/rand-mt19937.lisp +#: src/code/rand-xoroshiro.lisp msgid "" "Make a random state object. If STATE is not supplied, return a copy\n" " of the default random state. If STATE is a random state, then return a\n" @@ -12144,20 +12144,27 @@ msgid "" " the universal time or /dev/urandom if available." msgstr "" -#: src/code/rand-mt19937.lisp -msgid "Argument is not a RANDOM-STATE, T or NIL: ~S" +#: src/code/rand-xoroshiro.lisp +msgid "Argument is not a RANDOM-STATE, T, or NIL: ~S" msgstr "" -#: src/code/rand-mt19937.lisp +#: src/code/rand-xoroshiro.lisp msgid "" "Generate a uniformly distributed pseudo-random number between zero\n" " and Arg. State, if supplied, is the random state to use." msgstr "" -#: src/code/rand-mt19937.lisp +#: src/code/rand-xoroshiro.lisp msgid "Argument is not a positive integer or a positive float: ~S" msgstr "" +#: src/code/rand-xoroshiro.lisp +msgid "" +"Jump the RNG-STATE. This is equivalent to 2^64 calls to the\n" +" xoroshiro128+ generator. It can be used to generate 2^64\n" +" non-overlapping subsequences for parallel computations." +msgstr "" + #: src/code/ntrace.lisp msgid "" "This is bound to the returned values when evaluating :BREAK-AFTER and\n" @@ -18909,10 +18916,6 @@ msgid "use inline (unsigned-byte 32) operations" msgstr "" #: src/compiler/float-tran.lisp -msgid "Shouldn't happen" -msgstr "" - -#: src/compiler/float-tran.lisp msgid "Can't open-code float to rational comparison." msgstr "" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/f19dd8773ef50989907e1e6c4… --- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/f19dd8773ef50989907e1e6c4… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0