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

[Git][cmucl/cmucl][issue-157-directory-no-magic-wildcarding] Need to merge the directory pathname with defaults
by Raymond Toy (＠rtoy) 08 Mar '23

08 Mar '23

Raymond Toy pushed to branch issue-157-directory-no-magic-wildcarding at cmucl / cmucl Commits: d5b02338 by Raymond Toy at 2023-03-08T08:43:59-08:00 Need to merge the directory pathname with defaults If we don't then logical pathnames don't work, among other things. In particular the following ansi-tests were failling: DIRECTORY.8, OPEN.OUTPUT.28, OPEN.OUTPUT.35, OPEN.IO.28, OPEN.IO.35, OPEN.PROBE.12, OPEN.PROBE.13, OPEN.PROBE.14, OPEN.PROBE.15, OPEN.PROBE.16, OPEN.PROBE.17, OPEN.PROBE.18, OPEN.PROBE.19, OPEN.PROBE.20, OPEN.ERROR.4, OPEN.ERROR.5, OPEN.ERROR.6, OPEN.ERROR.7, OPEN.ERROR.8, OPEN.ERROR.9, OPEN.ERROR.10, OPEN.ERROR.11, OPEN.ERROR.12, OPEN.ERROR.13, OPEN.ERROR.14. With this change, the ansi-tests suite passes. - - - - - 1 changed file: - src/code/filesys.lisp Changes: ===================================== src/code/filesys.lisp ===================================== @@ -1120,7 +1120,9 @@ optionally keeping some of the most recent old versions." (setf prev elem)) (nreverse results)))) (let ((results nil)) - (enumerate-search-list (pathname pathname) + (enumerate-search-list + (pathname (merge-pathnames pathname + *default-pathname-defaults*)) (enumerate-matches (name pathname nil :follow-links follow-links) (when (or all (let ((slash (position #\/ name :from-end t))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d5b023387b05012738abd70… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d5b023387b05012738abd70… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-156-take-2-nan-comparison] Use existing function to compute >= and <=
by Raymond Toy (＠rtoy) 08 Mar '23

08 Mar '23

Raymond Toy pushed to branch issue-156-take-2-nan-comparison at cmucl / cmucl Commits: bd505bab by Raymond Toy at 2023-03-08T07:56:11-08:00 Use existing function to compute >= and <= The code assumed if a0 >= b0 and a1 >= b1 implied a >= b for a bigfloat. But I forgot that 1.99999...w0 is represented as 2d0 and a tiny negative number. So `(<= 2w0 1.99999...w0)` would return false because, while a0 <= b0, a1 <= b1 is false. So for simplicity just use the obvious replacement that a <= b is the same as a < b or a = b, which we already have. [skip ci] - - - - - 1 changed file: - src/compiler/float-tran-dd.lisp Changes: ===================================== src/compiler/float-tran-dd.lisp ===================================== @@ -670,13 +670,13 @@ (declaim (inline dd<=)) (defun dd<= (a0 a1 b0 b1) - (and (<= a0 b0) - (<= a1 b1))) + (or (dd> a0 a1 b0 b1) + (dd= a0 a1 b0 b1))) (declaim (inline dd>=)) (defun dd>= (a0 a1 b0 b1) - (and (>= a0 b0) - (>= a1 b1))) + (or (dd> a0 a1 b0 b1) + (dd= a0 a1 b0 b1))) (deftransform = ((a b) (vm::double-double-float vm::double-double-float) *) `(dd= (kernel:double-double-hi a) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/bd505bab9b50e50016cea7c… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/bd505bab9b50e50016cea7c… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-156-take-2-nan-comparison
by Raymond Toy (＠rtoy) 07 Mar '23

07 Mar '23

Raymond Toy pushed new branch issue-156-take-2-nan-comparison at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-156-take-2-nan-comp… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #173: Add pprinter for define-assembly-routine
by Raymond Toy (＠rtoy) 06 Mar '23

06 Mar '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: b2f6ab4c by Raymond Toy at 2023-03-06T17:07:46+00:00 Fix #173: Add pprinter for define-assembly-routine - - - - - 7a15c464 by Raymond Toy at 2023-03-06T17:07:49+00:00 Merge branch 'issue-173-pprint-def-assem-routine' into 'master' Fix #173: Add pprinter for define-assembly-routine Closes #173 See merge request cmucl/cmucl!126 - - - - - 1 changed file: - src/code/pprint.lisp Changes: ===================================== src/code/pprint.lisp ===================================== @@ -1920,6 +1920,42 @@ When annotations are present, invoke them at the right positions." (pprint-newline :mandatory stream))) (pprint-exit-if-list-exhausted) (pprint-newline :mandatory stream)))) + +(defun pprint-define-assembly (stream list &rest noise) + (declare (ignore noise)) + (pprint-logical-block (stream list :prefix "(" :suffix ")") + ;; Output "define-assembly-routine" + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (write-char #\space stream) + ;; Output routine name and options. + (pprint-logical-block (stream (pprint-pop) :prefix "(" :suffix ")") + ;; Output the routine name + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (pprint-newline :mandatory stream) + (pprint-indent :block 0 stream) + ;; Output options, one per line, neatly lined up and indented + ;; below the routine name. + (loop + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (pprint-newline :mandatory stream))) + ;; Now output the args, results, and temps used by the assembly + ;; routine. Instead of lining up with the routine name, let's + ;; just indent it 4 spaces from the "define-assembly-routine" so + ;; it doesn't look so top-heavy. + (pprint-indent :block 4 stream) + (pprint-newline :mandatory stream) + (pprint-logical-block (stream (pprint-pop) :prefix "(" :suffix ")") + (loop + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (pprint-newline :mandatory stream))) + ;; Now print out the assembly code as if it were a tagbody. Then + ;; labels are outdented by one to make them easy to see. + (pprint-newline :mandatory stream) + (pprint-tagbody-guts stream))) ;;;; Interface seen by regular (ugly) printer and initialization routines. @@ -2037,7 +2073,8 @@ When annotations are present, invoke them at the right positions." (stream::with-stream-class pprint-with-like) (lisp::with-array-data pprint-with-like) (c:define-vop pprint-define-vop) - (c:sc-case pprint-sc-case))) + (c:sc-case pprint-sc-case) + (c:define-assembly-routine pprint-define-assembly))) (defun pprint-init () (setf *initial-pprint-dispatch* (make-pprint-dispatch-table)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/9d32d69a918d3542444ab3… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/9d32d69a918d3542444ab3… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-157-directory-no-magic-wildcarding
by Raymond Toy (＠rtoy) 06 Mar '23

06 Mar '23

Raymond Toy pushed new branch issue-157-directory-no-magic-wildcarding at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-157-directory-no-ma… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-173-pprint-def-assem-routine
by Raymond Toy (＠rtoy) 05 Mar '23

05 Mar '23

Raymond Toy pushed new branch issue-173-pprint-def-assem-routine at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-173-pprint-def-asse… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Indent let in %time correctly.
by Raymond Toy (＠rtoy) 05 Mar '23

05 Mar '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 9d32d69a by Raymond Toy at 2023-03-05T07:43:06-08:00 Indent let in %time correctly. A `let` sexp in `%time` was not indented correctly. Indent it correctly now. - - - - - 1 changed file: - src/code/time.lisp Changes: ===================================== src/code/time.lisp ===================================== @@ -352,51 +352,51 @@ (old-run-utime old-run-stime old-page-faults old-bytes-consed) (time-get-sys-info)) (let ((start-gc-run-time *gc-run-time*)) - (setq cycle-count (- (cycle-count/float))) - (multiple-value-prog1 - ;; Execute the form and return its values. - (funcall fun) - (incf cycle-count (cycle-count/float)) - (multiple-value-setq - (new-run-utime new-run-stime new-page-faults new-bytes-consed) - (time-get-sys-info)) - (setq new-real-time (- (get-internal-real-time) real-time-overhead)) - (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0)) - (bytes-consed (- new-bytes-consed old-bytes-consed cons-overhead))) - (unless *in-get-time-consing* - (terpri *trace-output*) - (pprint-logical-block (*trace-output* nil :per-line-prefix "; ") - (format *trace-output* - (intl:gettext "Evaluation took:~% ~ + (setq cycle-count (- (cycle-count/float))) + (multiple-value-prog1 + ;; Execute the form and return its values. + (funcall fun) + (incf cycle-count (cycle-count/float)) + (multiple-value-setq + (new-run-utime new-run-stime new-page-faults new-bytes-consed) + (time-get-sys-info)) + (setq new-real-time (- (get-internal-real-time) real-time-overhead)) + (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0)) + (bytes-consed (- new-bytes-consed old-bytes-consed cons-overhead))) + (unless *in-get-time-consing* + (terpri *trace-output*) + (pprint-logical-block (*trace-output* nil :per-line-prefix "; ") + (format *trace-output* + (intl:gettext "Evaluation took:~% ~ ~S seconds of real time~% ~ ~S seconds of user run time~% ~ ~S seconds of system run time~% ") - (max (/ (- new-real-time old-real-time) - (float internal-time-units-per-second)) - 0.0) - (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0) - (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0)) - (format *trace-output* - (intl:ngettext - "~:D ~A cycle~% ~ + (max (/ (- new-real-time old-real-time) + (float internal-time-units-per-second)) + 0.0) + (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0) + (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0)) + (format *trace-output* + (intl:ngettext + "~:D ~A cycle~% ~ ~@[[Run times include ~S seconds GC run time]~% ~]" - "~:D ~A cycles~% ~ + "~:D ~A cycles~% ~ ~@[[Run times include ~S seconds GC run time]~% ~]" - (truncate cycle-count)) - (truncate cycle-count) - "CPU" - (unless (zerop gc-run-time) - (/ (float gc-run-time) - (float internal-time-units-per-second)))) - (format *trace-output* - (intl:ngettext "~S page fault and~% " - "~S page faults and~% " - (max (- new-page-faults old-page-faults) 0)) - (max (- new-page-faults old-page-faults) 0)) - (format *trace-output* - (intl:ngettext "~:D byte consed.~%" - "~:D bytes consed.~%" - (max (- bytes-consed (or *time-consing* 0)) 0)) - (max (- bytes-consed (or *time-consing* 0)) 0))) - (terpri *trace-output*)) - (setq *last-time-consing* bytes-consed)))))) + (truncate cycle-count)) + (truncate cycle-count) + "CPU" + (unless (zerop gc-run-time) + (/ (float gc-run-time) + (float internal-time-units-per-second)))) + (format *trace-output* + (intl:ngettext "~S page fault and~% " + "~S page faults and~% " + (max (- new-page-faults old-page-faults) 0)) + (max (- new-page-faults old-page-faults) 0)) + (format *trace-output* + (intl:ngettext "~:D byte consed.~%" + "~:D bytes consed.~%" + (max (- bytes-consed (or *time-consing* 0)) 0)) + (max (- bytes-consed (or *time-consing* 0)) 0))) + (terpri *trace-output*)) + (setq *last-time-consing* bytes-consed)))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/9d32d69a918d3542444ab30… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/9d32d69a918d3542444ab30… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-157-directory-returns-all-files] Fix typo in version-components-match
by Raymond Toy (＠rtoy) 04 Mar '23

04 Mar '23

Raymond Toy pushed to branch issue-157-directory-returns-all-files at cmucl / cmucl Commits: 5969e65a by Raymond Toy at 2023-03-04T11:54:32-08:00 Fix typo in version-components-match Too much cut'n'paste so we got the wrong variable names. - - - - - 1 changed file: - src/code/pathname.lisp Changes: ===================================== src/code/pathname.lisp ===================================== @@ -1234,10 +1234,10 @@ a host-structure or string." (eq wild :wild) ;; A version component of :newest or :unspecific ;; is equivalent to nil. - (and (null this) (or (eq that :newest) - (eq that :unspecific))) - (and (null that) (or (eq this :newest) - (eq this :unspecific)))))) + (and (null thing) (or (eq wild :newest) + (eq wild :unspecific))) + (and (null wild) (or (eq thing :newest) + (eq thing :unspecific)))))) (and (or (null (%pathname-host wildname)) (eq (%pathname-host wildname) (%pathname-host pathname))) (frob %pathname-device device-components-match) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/5969e65a5bba43a0a37161c… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/5969e65a5bba43a0a37161c… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-157-directory-returns-all-files] 3 commits: Add more tests
by Raymond Toy (＠rtoy) 04 Mar '23

04 Mar '23

Raymond Toy pushed to branch issue-157-directory-returns-all-files at cmucl / cmucl Commits: dd947ca0 by Raymond Toy at 2023-03-04T11:24:35-08:00 Add more tests Add tests that the results of `directory` are consistent with `pathname-match-p`. Add a test where "**/" only returns directories. Add some miscellaneous tests for `pathname-match-p` and logical pathnames. - - - - - 2bf9b39f by Raymond Toy at 2023-03-04T11:33:05-08:00 Treat :unspecific as equivalent to nil for pathname-version. This equivalence is just for `pathname-match-p`. - - - - - 6463e421 by Raymond Toy at 2023-03-04T11:36:07-08:00 Slighltly refactor %%pathname-match-p Put all the flets into one at the beginning. - - - - - 2 changed files: - src/code/pathname.lisp - tests/pathname.lisp Changes: ===================================== src/code/pathname.lisp ===================================== @@ -1222,25 +1222,29 @@ a host-structure or string." (defun %%pathname-match-p (pathname wildname) (macrolet ((frob (field &optional (op 'components-match )) `(,op (,field pathname) (,field wildname)))) + (flet ((device-components-match (thing wild) + (or (eq thing wild) + (eq wild :wild) + ;; A device component of :unspecific matches + ;; nil. + (or (and (null thing) (eq wild :unspecific)) + (and (eq thing :unspecific) (eq wild nil))))) + (version-components-match (thing wild) + (or (eq thing wild) + (eq wild :wild) + ;; A version component of :newest or :unspecific + ;; is equivalent to nil. + (and (null this) (or (eq that :newest) + (eq that :unspecific))) + (and (null that) (or (eq this :newest) + (eq this :unspecific)))))) (and (or (null (%pathname-host wildname)) (eq (%pathname-host wildname) (%pathname-host pathname))) - (flet ((device-components-match (thing wild) - (or (eq thing wild) - (eq wild :wild) - ;; A device component of :unspecific matches - ;; nil. - (or (and (null thing) (eq wild :unspecific)) - (and (eq thing :unspecific) (eq wild nil)))))) - (frob %pathname-device device-components-match)) + (frob %pathname-device device-components-match) (frob %pathname-directory directory-components-match) (frob %pathname-name) (frob %pathname-type) - (flet ((version-components-match (thing wild) - (or (eq thing wild) - (eq wild :wild) - ;; A version component of :newest matches nil. - (compare-version-component thing wild)))) - (frob %pathname-version version-components-match))))) + (frob %pathname-version version-components-match))))) ;; Like PATHNAME-MATCH-P but the pathnames should not be search-lists. ;; Primarily intended for TRANSLATE-LOGICAL-PATHNAME and friends, ===================================== tests/pathname.lisp ===================================== @@ -43,7 +43,7 @@ (assert-true (pathname-match-p "foo:zot/foo.lisp" "/usr/**/*.lisp")) (assert-false (pathname-match-p "foo:foo" "/bin/*")) - + ;; Tests where both args are search-lists. (assert-true (pathname-match-p "foo:foo.lisp" "bar:*.*"))) @@ -68,7 +68,12 @@ :name :wild :type :wild :version nil))) ("**;*" ,(merge-pathnames (make-pathname :directory '(:relative "asdf-src" :wild-inferiors) - :name :wild :type nil :version nil))))))) + :name :wild :type nil :version nil))) + ("tests;**;*.*" + "**/*.*"))) + (setf (logical-pathname-translations "test") + '(("**;*.*" "tests/**/*.*") + ("**;*.*.*" "tests/**/*.*.~*~"))))) (setup-logical-host) (define-test pathname-match-p.logical-pathname @@ -77,4 +82,77 @@ :directory '(:absolute "system2" "module4") :name nil :type nil) (parse-namestring "ASDFTEST:system2;module4;")))) - + + + +(define-test pathname-match-p.unspecific + ;; Test that a field of :unspecific matches nil. + (let ((wild-path #p"**/*.*")) + (assert-true (pathname-match-p (make-pathname :device :unspecific) + wild-path)) + (assert-true (pathname-match-p (make-pathname :name :unspecific) + wild-path)) + (assert-true (pathname-match-p (make-pathname :type :unspecific) + wild-path)) + (assert-true (pathname-match-p (make-pathname :version :unspecific) + wild-path)) + ;; Slightly more complicated pathnames with :unspecific + (assert-true (pathname-match-p (make-pathname :device :unspecific + :name "foo" + :type "bar") + wild-path)) + (assert-true (pathname-match-p (make-pathname :directory '(:relative "a") + :name :unspecific + :type "bar") + wild-path)) + (assert-true (pathname-match-p (make-pathname :directory '(:relative "a") + :name "foo" + :type :unspecific) + wild-path)) + (assert-true (pathname-match-p (make-pathname :directory '(:relative "a") + :name "foo" + :type "bar" + :version :unspecific) + wild-path)))) + +(define-test directory-pathname-match-p + ;; Test that directory and pathname-match-p are consistent + (let* ((wild-path #P"**/*.*") + (dir (directory wild-path :truenamep nil))) + (loop for p in dir + do + (assert-true (pathname-match-p p wild-path))))) + +(define-test directory-pathname-match-p.lpn + ;; Like directory-pathname-match-p but for a logical pathname + (let* ((wild-path #P"ASDFTEST:**;*.*.*") + (dir (directory wild-path :truenamep nil))) + (loop for p in dir + do + (assert-true (pathname-match-p p wild-path))))) + +(define-test directory-consistent-pn-vs-lpn + ;; Test the directory with a physical pathname and a logical + ;; pathname return the same files. + (let ((dir-pn (directory #P"tests/**/*.*" :truenamep nil)) + (dir-lpn (directory #P"test:**;*.*.*" :truenamep nil))) + ;; The number of entries should be the same. + (assert-equal (length dir-pn) (length dir-lpn) + dir-pn dir-lpn) + (loop for pn in dir-pn + for lpn in dir-lpn + do + (assert-equal pn lpn)))) + +(define-test directory-only + ;; Test that we only get directories when requested + (let ((dirs (directory #P"tests/**/" :truenamep nil))) + (loop for p in dirs + do + (assert-false (pathname-name p) p) + (assert-false (pathname-type p) p) + (assert-true (let ((version (pathname-version p))) + (or (null version) + (eq version :newest))) + p)))) + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/30abe6ebd71ba3bcee4438… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/30abe6ebd71ba3bcee4438… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-157-directory-returns-all-files] Fix up test issues for pathnames.
by Raymond Toy (＠rtoy) 04 Mar '23

04 Mar '23

Raymond Toy pushed to branch issue-157-directory-returns-all-files at cmucl / cmucl Commits: 30abe6eb by Raymond Toy at 2023-03-04T10:33:48-08:00 Fix up test issues for pathnames. With the updated pathname-match-p function, some of the existing pathname tests were not correct. For example "/tmp/foo.lisp" should NOT match "foo:*" because only the name is `:WILD`. The type is `NIL`, so "foo.lisp" doesn't match. We change the test to assert it fails and added a version where it should pass. There was also in trying to match different search-lists where we forgot to call `pathname-match-p`. Oops. - - - - - 1 changed file: - tests/pathname.lisp Changes: ===================================== tests/pathname.lisp ===================================== @@ -19,28 +19,33 @@ (:tag :search-list) ;; Basic tests where the wild path is search-list - (assert-true (pathname-match-p "/tmp/foo.lisp" "foo:*")) - (assert-true (pathname-match-p "/tmp/zot/foo.lisp" "foo:**/*")) + (assert-false (pathname-match-p "/tmp/foo.lisp" "foo:*")) + (assert-true (pathname-match-p "/tmp/foo.lisp" "foo:*.*")) + (assert-false (pathname-match-p "/tmp/zot/foo.lisp" "foo:**/*")) + (assert-true (pathname-match-p "/tmp/zot/foo.lisp" "foo:**/*.*")) (assert-true (pathname-match-p "/tmp/zot/foo.lisp" "foo:**/*.lisp")) ;; These match because the second entry of the "foo:" search list is ;; "/usr/". - (assert-true (pathname-match-p "/usr/foo.lisp" "foo:*")) + (assert-false (pathname-match-p "/usr/foo.lisp" "foo:*")) + (assert-true (pathname-match-p "/usr/foo.lisp" "foo:*.*")) (assert-true (pathname-match-p "/usr/bin/foo" "foo:**/*")) (assert-true (pathname-match-p "/usr/bin/foo.lisp" "foo:**/*.lisp")) ;; This fails because "/bin/" doesn't match any path of the search ;; list. - (assert-false (pathname-match-p "/bin/foo.lisp" "foo:*")) + (assert-false (pathname-match-p "/bin/foo.lisp" "foo:*.*")) ;; Basic test where the pathname is a search-list and the wild path is not. - (assert-true (pathname-match-p "foo:foo.lisp" "/tmp/*")) + (assert-false (pathname-match-p "foo:foo.lisp" "/tmp/*")) + (assert-true (pathname-match-p "foo:foo.lisp" "/tmp/*.*")) (assert-true (pathname-match-p "foo:foo" "/usr/*")) + (assert-true (pathname-match-p "foo:foo" "/usr/*.*")) (assert-true (pathname-match-p "foo:zot/foo.lisp" "/usr/**/*.lisp")) (assert-false (pathname-match-p "foo:foo" "/bin/*")) ;; Tests where both args are search-lists. - (assert-true "foo:foo.lisp" "bar:*")) + (assert-true (pathname-match-p "foo:foo.lisp" "bar:*.*"))) ;; Verify PATHNAME-MATCH-P works with logical pathnames. (Issue 27) ;; This test modeled after a test from asdf View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/30abe6ebd71ba3bcee4438f… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/30abe6ebd71ba3bcee4438f… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-157-directory-returns-all-files] Remove commented out debugging code; fix up some comments
by Raymond Toy (＠rtoy) 04 Mar '23

04 Mar '23

Raymond Toy pushed to branch issue-157-directory-returns-all-files at cmucl / cmucl Commits: c3cd7841 by Raymond Toy at 2023-03-04T09:51:45-08:00 Remove commented out debugging code; fix up some comments - - - - - 2 changed files: - src/code/filesys.lisp - src/code/pathname.lisp Changes: ===================================== src/code/filesys.lisp ===================================== @@ -786,10 +786,6 @@ (let ((name (%pathname-name pathname)) (type (%pathname-type pathname)) (version (%pathname-version pathname))) - #+nil - (progn - (format t "name, type = ~A ~A~%" name type) - (describe pathname)) (cond ((member name '(nil :unspecific)) (when (or (not verify-existence) (unix:unix-file-kind directory)) @@ -803,15 +799,11 @@ (dir-path (pathname directory))) (when dir (unwind-protect - (loop + (loop (let ((file (unix:read-dir dir))) (if file (unless (or (string= file ".") (string= file "..")) - #+nil - (progn - (format t "file = ~A~%" file) - (describe pathname)) ;; Use pathname-match-p so that we are ;; guaranteed to have directory and ;; pathname-match-p behave consistently. @@ -820,27 +812,7 @@ (funcall function (concatenate 'string directory - file))) - #+nil - (multiple-value-bind - (file-name file-type file-version) - (let ((*ignore-wildcards* t)) - (extract-name-type-and-version - file 0 (length file))) - ;; Match also happens if the file has - ;; no explicit version and we're asking - ;; for version :NEWEST, since that's - ;; what no version means. - (when (and (components-match file-name name) - (components-match file-type type) - (or (components-match file-version - version) - (and (eq file-version nil) - (eq version :newest)))) - (funcall function - (concatenate 'string - directory - file))))) + file)))) (return)))) (unix:close-dir dir))))) (t ===================================== src/code/pathname.lisp ===================================== @@ -1222,10 +1222,6 @@ a host-structure or string." (defun %%pathname-match-p (pathname wildname) (macrolet ((frob (field &optional (op 'components-match )) `(,op (,field pathname) (,field wildname)))) - #+nil - (progn - (describe pathname) - (describe wildname)) (and (or (null (%pathname-host wildname)) (eq (%pathname-host wildname) (%pathname-host pathname))) (flet ((device-components-match (thing wild) @@ -1236,15 +1232,13 @@ a host-structure or string." (or (and (null thing) (eq wild :unspecific)) (and (eq thing :unspecific) (eq wild nil)))))) (frob %pathname-device device-components-match)) - #+nil - (frob %pathname-device) (frob %pathname-directory directory-components-match) (frob %pathname-name) (frob %pathname-type) (flet ((version-components-match (thing wild) (or (eq thing wild) (eq wild :wild) - ;; A version component matches of :newest matches nil. + ;; A version component of :newest matches nil. (compare-version-component thing wild)))) (frob %pathname-version version-components-match))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/c3cd7841cc500f07a822ef1… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/c3cd7841cc500f07a822ef1… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-157-directory-returns-all-files] 6 commits: Need to handle pathname versions specially
by Raymond Toy (＠rtoy) 04 Mar '23

04 Mar '23

Raymond Toy pushed to branch issue-157-directory-returns-all-files at cmucl / cmucl Commits: 172b5853 by Raymond Toy at 2023-03-03T16:16:06-08:00 Need to handle pathname versions specially Using `components-match` doesn't do the right thing for `pathname-version`. We need to treat `NIL` to mean the same as `:NEWEST`. Fortunately, there's already `compare-version-component` does what we need, so use it. - - - - - 2f544f3d by Raymond Toy at 2023-03-03T16:18:20-08:00 Instead of calling %pathname-match-p call %%pathname-match-p Here in `%enumerate-files`, we don't need the full capability of `%pathname-match-p`. The file we get is a string from reading from the directory. We can just use `parse-nametring` to get a pathname object out of that. Then it can be merged with the directory pathname. Thus, everything is a physical pathname suitable for `%%pathname-match-p`. - - - - - 2e0efffd by Raymond Toy at 2023-03-03T16:41:29-08:00 Need to have special function to match version components. Using `components-match` work and neither does `compare-version-component`. We need a separate method of this. Basically a version matches a wild version if they're `eq, or if the wild version is `:wild`. Also `NIL` and `:NEWEST` are treated as being equal. (Via `compare-version-component`). - - - - - 90e1f949 by Raymond Toy at 2023-03-03T17:07:44-08:00 Handle device component specially for matching. Logical pathnames have a pathname-device of :unspecific. We need to handle that specially when matching logical pathnames. We treat :unspecific as matching nil. - - - - - 3cfc7ef3 by Raymond Toy at 2023-03-03T17:10:04-08:00 Comment out debugging prints - - - - - c14e6ee8 by Raymond Toy at 2023-03-04T07:12:28-08:00 Add some comments. - - - - - 2 changed files: - src/code/filesys.lisp - src/code/pathname.lisp Changes: ===================================== src/code/filesys.lisp ===================================== @@ -812,8 +812,11 @@ (progn (format t "file = ~A~%" file) (describe pathname)) - (when (%pathname-match-p (merge-pathnames file dir-path nil) - pathname) + ;; Use pathname-match-p so that we are + ;; guaranteed to have directory and + ;; pathname-match-p behave consistently. + (when (%%pathname-match-p (merge-pathnames file dir-path) + pathname) (funcall function (concatenate 'string directory ===================================== src/code/pathname.lisp ===================================== @@ -1221,15 +1221,32 @@ a host-structure or string." (defun %%pathname-match-p (pathname wildname) (macrolet ((frob (field &optional (op 'components-match )) - `(or (eq (,field wildname) :wild) - (,op (,field pathname) (,field wildname))))) - (and (or (null (%pathname-host wildname)) - (eq (%pathname-host wildname) (%pathname-host pathname))) - (frob %pathname-device) - (frob %pathname-directory directory-components-match) - (frob %pathname-name) - (frob %pathname-type) - (frob %pathname-version)))) + `(,op (,field pathname) (,field wildname)))) + #+nil + (progn + (describe pathname) + (describe wildname)) + (and (or (null (%pathname-host wildname)) + (eq (%pathname-host wildname) (%pathname-host pathname))) + (flet ((device-components-match (thing wild) + (or (eq thing wild) + (eq wild :wild) + ;; A device component of :unspecific matches + ;; nil. + (or (and (null thing) (eq wild :unspecific)) + (and (eq thing :unspecific) (eq wild nil)))))) + (frob %pathname-device device-components-match)) + #+nil + (frob %pathname-device) + (frob %pathname-directory directory-components-match) + (frob %pathname-name) + (frob %pathname-type) + (flet ((version-components-match (thing wild) + (or (eq thing wild) + (eq wild :wild) + ;; A version component matches of :newest matches nil. + (compare-version-component thing wild)))) + (frob %pathname-version version-components-match))))) ;; Like PATHNAME-MATCH-P but the pathnames should not be search-lists. ;; Primarily intended for TRANSLATE-LOGICAL-PATHNAME and friends, View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/068710573805f004b0d0bc… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/068710573805f004b0d0bc… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-157-directory-returns-all-files
by Raymond Toy (＠rtoy) 03 Mar '23

03 Mar '23

Raymond Toy pushed new branch issue-157-directory-returns-all-files at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-157-directory-retur… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-156-add-two-arg-ge-le] Add x86 reader conditional
by Raymond Toy (＠rtoy) 02 Mar '23

02 Mar '23

Raymond Toy pushed to branch issue-156-add-two-arg-ge-le at cmucl / cmucl Commits: 0b4ec82d by Raymond Toy at 2023-03-02T10:50:47-08:00 Add x86 reader conditional Don't set package to "X86" if we're not building on x86. One less thing to worry about when bootstrapping. - - - - - 1 changed file: - src/bootfiles/21d/boot-2021-07-3.lisp Changes: ===================================== src/bootfiles/21d/boot-2021-07-3.lisp ===================================== @@ -3,7 +3,9 @@ ;; ;; Use bin/build.sh -B boot-2021-07-3 to build this (along with any ;; other bootfiles that are still needed). +#+x86 (in-package :x86) + #+x86 (ext:without-package-locks (defparameter static-functions View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/0b4ec82d2de83ee986b4821… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/0b4ec82d2de83ee986b4821… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Add x86 reader conditional
by Raymond Toy (＠rtoy) 02 Mar '23

02 Mar '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: d55e32fa by Raymond Toy at 2023-03-02T10:48:44-08:00 Add x86 reader conditional This bootstrap file only applies to x86, so add reader conditionals so that this can be loaded for other architectures without having any effect. One less thing to worry about when bootstrapping. - - - - - 1 changed file: - src/bootfiles/21d/boot-2021-07-2.lisp Changes: ===================================== src/bootfiles/21d/boot-2021-07-2.lisp ===================================== @@ -3,8 +3,10 @@ ;; ;; Use bin/build.sh -B boot-2021-07-2 to build this. +#+x86 (in-package :x86) +#+x86 (ext:without-package-locks (handler-bind ((error View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d55e32fab14add3feb30a51… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d55e32fab14add3feb30a51… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-156-add-two-arg-ge-le] Add bootstrap file for CI
by Raymond Toy (＠rtoy) 02 Mar '23

02 Mar '23

Raymond Toy pushed to branch issue-156-add-two-arg-ge-le at cmucl / cmucl Commits: 9ca44f6d by Raymond Toy at 2023-03-02T10:41:16-08:00 Add bootstrap file for CI Forgot to add boot-2021-07-3.lisp that's required to add the new static functions for x86. - - - - - 2 changed files: - .gitlab-ci.yml - + src/bootfiles/21d/boot-2021-07-3.lisp Changes: ===================================== .gitlab-ci.yml ===================================== @@ -1,7 +1,7 @@ variables: download_url: "https://common-lisp.net/project/cmucl/downloads/snapshots/2021/07" version: "2021-07-x86" - bootstrap: "-B boot-2021-07-1 -B boot-2021-07-2" + bootstrap: "-B boot-2021-07-1 -B boot-2021-07-2 -B boot-2021-07-3" stages: - install ===================================== src/bootfiles/21d/boot-2021-07-3.lisp ===================================== @@ -0,0 +1,14 @@ +;; Bootstrap file for x86 to add two-arg->= and two-arg-<= to static +;; functions list. +;; +;; Use bin/build.sh -B boot-2021-07-3 to build this (along with any +;; other bootfiles that are still needed). +(in-package :x86) +#+x86 +(ext:without-package-locks + (defparameter static-functions + '(length + two-arg-+ two-arg-- two-arg-* two-arg-/ two-arg-< two-arg-> two-arg-= eql + %negate two-arg-and two-arg-ior two-arg-xor two-arg-gcd two-arg-lcm + two-arg-<= two-arg->= two-arg-/= + ))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/9ca44f6d211c5e7624f4e89… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/9ca44f6d211c5e7624f4e89… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-156-add-vops-for-ge-le] Fix typo: :naa should be :nae
by Raymond Toy (＠rtoy) 02 Mar '23

02 Mar '23

Raymond Toy pushed to branch issue-156-add-vops-for-ge-le at cmucl / cmucl Commits: 62d141d7 by Raymond Toy at 2023-03-01T17:09:05-08:00 Fix typo: :naa should be :nae - - - - - 1 changed file: - src/compiler/x86/float-sse2.lisp Changes: ===================================== src/compiler/x86/float-sse2.lisp ===================================== @@ -978,7 +978,7 @@ (frob < double comisd :b :nb) (frob <= double comisd :be :nbe) (frob > double comisd :a :na) - (frob >= double comisd :ae :naa)) + (frob >= double comisd :ae :nae)) ;;;; Conversion: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/62d141d795281b5bfe99752… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/62d141d795281b5bfe99752… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-156-add-two-arg-ge-le
by Raymond Toy (＠rtoy) 01 Mar '23

01 Mar '23

Raymond Toy pushed new branch issue-156-add-two-arg-ge-le at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-156-add-two-arg-ge-… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-156-add-vops-for-ge-le
by Raymond Toy (＠rtoy) 01 Mar '23

01 Mar '23

Raymond Toy pushed new branch issue-156-add-vops-for-ge-le at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-156-add-vops-for-ge… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Update cmucl.pot
by Raymond Toy (＠rtoy) 01 Mar '23

01 Mar '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 80f89a62 by Raymond Toy at 2023-02-28T21:20:02-08:00 Update cmucl.pot We forgot to update this when adding --version command line option. - - - - - 1 changed file: - src/i18n/locale/cmucl.pot Changes: ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -6153,6 +6153,10 @@ msgstr "" msgid "Prints the cmucl version and exits" msgstr "" +#: src/code/commandline.lisp +msgid "Prints the cmucl version and exits; same as -version" +msgstr "" + #: src/code/env-access.lisp msgid "" "Returns information about the symbol VAR in the lexical environment ENV.\n" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/80f89a62d10176604e5c664… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/80f89a62d10176604e5c664… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #163: Add -version command line switch
by Raymond Toy (＠rtoy) 01 Mar '23

01 Mar '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: ca9b6e0c by Raymond Toy at 2023-03-01T03:43:18+00:00 Fix #163: Add -version command line switch - - - - - 3f4e2d0c by Raymond Toy at 2023-03-01T03:43:19+00:00 Merge branch 'issue-163-add-command-line-version' into 'master' Fix #163: Add -version command line switch Closes #163 See merge request cmucl/cmucl!112 - - - - - 3 changed files: - src/code/commandline.lisp - src/code/save.lisp - src/i18n/locale/cmucl.pot Changes: ===================================== src/code/commandline.lisp ===================================== @@ -394,3 +394,17 @@ (defswitch "-help" #'help-switch-demon "Same as -help.") + +(defun version-switch-demon (switch) + (declare (ignore switch)) + (format t "~A~%" (lisp-implementation-version)) + (ext:quit)) + +(defswitch "version" #'version-switch-demon + "Prints the cmucl version and exits") + +;; Make --version work for the benefit of those who are accustomed to +;; GNU software. +(defswitch "-version" #'version-switch-demon + "Prints the cmucl version and exits; same as -version") + ===================================== src/code/save.lisp ===================================== @@ -336,8 +336,12 @@ *gc-verbose* nil)) (when (and process-command-line (or (find-switch "help") - (find-switch "-help"))) - ;; Don't load any init files if -help or --help is given + (find-switch "-help") + (find-switch "version") + (find-switch "-version"))) + ;; Don't load any init files if -help, --help, + ;; -version, or --version is given. These exit right + ;; away, so loading the init file is wasteful. (setf site-init nil) (setf load-init-file nil)) (when (and site-init ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -6149,6 +6149,10 @@ msgstr "" msgid "Same as -help." msgstr "" +#: src/code/commandline.lisp +msgid "Prints the cmucl version and exits" +msgstr "" + #: src/code/env-access.lisp msgid "" "Returns information about the symbol VAR in the lexical environment ENV.\n" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/68ef4c5b2708fd3c26e93d… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/68ef4c5b2708fd3c26e93d… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-163-add-command-line-version] Better comment.
by Raymond Toy (＠rtoy) 01 Mar '23

01 Mar '23

Raymond Toy pushed to branch issue-163-add-command-line-version at cmucl / cmucl Commits: 17c15601 by Carl S. Shapiro at 2023-03-01T03:10:22+00:00 Better comment. - - - - - 1 changed file: - src/code/commandline.lisp Changes: ===================================== src/code/commandline.lisp ===================================== @@ -403,8 +403,8 @@ (defswitch "version" #'version-switch-demon "Prints the cmucl version and exits") -;; Make --version work too since that's a common command line option -;; for GNU software. +;; Make --version work for the benefit of those who are accustomed to +;; GNU software. (defswitch "-version" #'version-switch-demon "Prints the cmucl version and exits; same as -version") View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/17c15601aa9e17e7ce79de5… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/17c15601aa9e17e7ce79de5… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #170: reduce duplicated code for x86 float-compares
by Raymond Toy (＠rtoy) 01 Mar '23

01 Mar '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: a25354e9 by Raymond Toy at 2023-03-01T03:08:58+00:00 Fix #170: reduce duplicated code for x86 float-compares - - - - - 68ef4c5b by Raymond Toy at 2023-03-01T03:09:00+00:00 Merge branch 'issue-170-clean-up-x86-float-compare' into 'master' Fix #170: reduce duplicated code for x86 float-compares Closes #170 See merge request cmucl/cmucl!122 - - - - - 1 changed file: - src/compiler/x86/float-sse2.lisp Changes: ===================================== src/compiler/x86/float-sse2.lisp ===================================== @@ -901,130 +901,80 @@ ;;; comiss and comisd can cope with one or other arg in memory: we ;;; could (should, indeed) extend these to cope with descriptor args ;;; and stack args +(macrolet + ((frob (name sc ptype) + `(define-vop (,name float-compare) + (:args (x :scs (,sc)) + (y :scs (,sc descriptor-reg))) + (:arg-types ,ptype ,ptype)))) + (frob single-float-compare single-reg single-float) + (frob double-float-compare double-reg double-float)) -(define-vop (single-float-compare float-compare) - (:args (x :scs (single-reg)) (y :scs (single-reg descriptor-reg))) - (:conditional) - (:arg-types single-float single-float)) -(define-vop (double-float-compare float-compare) - (:args (x :scs (double-reg)) (y :scs (double-reg descriptor-reg))) - (:conditional) - (:arg-types double-float double-float)) - -(define-vop (=/single-float single-float-compare) - (:translate =) - (:info target not-p) - (:vop-var vop) - (:generator 3 - (note-this-location vop :internal-error) - (sc-case y - (single-reg - (inst ucomiss x y)) - (descriptor-reg - (inst ucomiss x (ea-for-sf-desc y)))) - ;; if PF&CF, there was a NaN involved => not equal - ;; otherwise, ZF => equal - (cond (not-p - (inst jmp :p target) - (inst jmp :ne target)) - (t - (let ((not-lab (gen-label))) - (inst jmp :p not-lab) - (inst jmp :e target) - (emit-label not-lab)))))) - -(define-vop (=/double-float double-float-compare) - (:translate =) - (:info target not-p) - (:vop-var vop) - (:generator 3 - (note-this-location vop :internal-error) - (sc-case y - (double-reg - (inst ucomisd x y)) - (descriptor-reg - (inst ucomisd x (ea-for-df-desc y)))) - (cond (not-p - (inst jmp :p target) - (inst jmp :ne target)) - (t - (let ((not-lab (gen-label))) - (inst jmp :p not-lab) - (inst jmp :e target) - (emit-label not-lab)))))) - -(define-vop (</double-float double-float-compare) - (:translate <) - (:info target not-p) - (:generator 3 - (sc-case y - (double-reg - (inst comisd x y)) - (descriptor-reg - (inst comisd x (ea-for-df-desc y)))) - (cond (not-p - (inst jmp :p target) - (inst jmp :nc target)) - (t - (let ((not-lab (gen-label))) - (inst jmp :p not-lab) - (inst jmp :c target) - (emit-label not-lab)))))) - -(define-vop (</single-float single-float-compare) - (:translate <) - (:info target not-p) - (:generator 3 - (sc-case y - (single-reg - (inst comiss x y)) - (descriptor-reg - (inst comiss x (ea-for-sf-desc y)))) - (cond (not-p - (inst jmp :p target) - (inst jmp :nc target)) - (t - (let ((not-lab (gen-label))) - (inst jmp :p not-lab) - (inst jmp :c target) - (emit-label not-lab)))))) - -(define-vop (>/double-float double-float-compare) - (:translate >) - (:info target not-p) - (:generator 3 - (sc-case y - (double-reg - (inst comisd x y)) - (descriptor-reg - (inst comisd x (ea-for-df-desc y)))) - (cond (not-p - (inst jmp :p target) - (inst jmp :na target)) - (t - (let ((not-lab (gen-label))) - (inst jmp :p not-lab) - (inst jmp :a target) - (emit-label not-lab)))))) - -(define-vop (>/single-float single-float-compare) - (:translate >) - (:info target not-p) - (:generator 3 - (sc-case y - (single-reg - (inst comiss x y)) - (descriptor-reg - (inst comiss x (ea-for-sf-desc y)))) - (cond (not-p - (inst jmp :p target) - (inst jmp :na target)) - (t - (let ((not-lab (gen-label))) - (inst jmp :p not-lab) - (inst jmp :a target) - (emit-label not-lab)))))) +(macrolet + ((frob (size inst) + (let ((ea (ecase size + (single + 'ea-for-sf-desc) + (double + 'ea-for-df-desc))) + (name (symbolicate "=/" size "-FLOAT")) + (sc-type (symbolicate size "-REG")) + (inherit (symbolicate size "-FLOAT-COMPARE"))) + `(define-vop (,name ,inherit) + (:translate =) + (:info target not-p) + (:vop-var vop) + (:generator 3 + (note-this-location vop :internal-error) + (sc-case y + (,sc-type + (inst ,inst x y)) + (descriptor-reg + (inst ,inst x (,ea y)))) + ;; if PF&CF, there was a NaN involved => not equal + ;; otherwise, ZF => equal + (cond (not-p + (inst jmp :p target) + (inst jmp :ne target)) + (t + (let ((not-lab (gen-label))) + (inst jmp :p not-lab) + (inst jmp :e target) + (emit-label not-lab))))))))) + (frob single ucomiss) + (frob double ucomisd)) +(macrolet + ((frob (op size inst yep nope) + (let ((ea (ecase size + (single + 'ea-for-sf-desc) + (double + 'ea-for-df-desc))) + (name (symbolicate op "/" size "-FLOAT")) + (sc-type (symbolicate size "-REG")) + (inherit (symbolicate size "-FLOAT-COMPARE"))) + `(define-vop (,name ,inherit) + (:translate ,op) + (:info target not-p) + (:generator 3 + (sc-case y + (,sc-type + (inst ,inst x y)) + (descriptor-reg + (inst ,inst x (,ea y)))) + (cond (not-p + (inst jmp :p target) + (inst jmp ,nope target)) + (t + (let ((not-lab (gen-label))) + (inst jmp :p not-lab) + (inst jmp ,yep target) + (emit-label not-lab))))))))) + (frob < single comiss :b :nb) + (frob > single comiss :a :na) + (frob < double comisd :b :nb) + (frob > double comisd :a :na)) ;;;; Conversion: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/6ba270b2d4b70c37d4bd36… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/6ba270b2d4b70c37d4bd36… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0