August 2009 - XEmacs-Patches - XEmacs Mailing List Archives

[xemacs-base] Make advice work better in keyboard macros 15 years, 4 months

Stephen J. Turnbull

Note: replies redirected to xemacs-patches. Michael Kifer pointed out that advice does not work properly in keyboard macros, see issue556. This is because `(interactive-p)' evaluates to nil when in a keyboard macro. What we really want in this case is what GNU calls `called-interactively-p', maybe. I'm not entirely sure whether that is really appropriate, since `called-interactively-p' can be true in batch-mode! In fact, this patch implements `called-interactively-p' in terms of `interactive-p', and it will be false in batch-mode. This patch fixes it locally to advice, and after light testing I think it should be applied. However, in the longer run we should define `call-interactively' in the core (at least in 21.5), and move the compatibility definition to a package. APEL would be a possibility, but APEL is a real horror because it does compilation conditional on the Emacs compiling it. I think a portability library should focus on correctness first, so I strongly dislike requiring APEL. I thought about creating a better portability library, but that seems unlikely to happen very quickly. Unless there's an objection, I'll commit in a day or so. Index: ChangeLog =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xemacs-base/ChangeLog,v retrieving revision 1.215 diff -u -r1.215 ChangeLog --- ChangeLog 13 Jan 2009 17:25:21 -0000 1.215 +++ ChangeLog 19 Aug 2009 06:12:49 -0000 ＠＠ -0,0 +1,11 ＠＠ +2009-08-19 Stephen J. Turnbull <stephen(a)xemacs.org> + + Conditionally define and use `called-interactively-p'. + + * advice.el (called-interactively-p): defun if not fboundp. + (car): Use it in example. + (ad-enable-regexp): + (ad-disable-regexp): + (ad-make-advised-definition): + Use it instead of `interactive-p'. + Index: advice.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xemacs-base/advice.el,v retrieving revision 1.2 diff -u -r1.2 advice.el --- advice.el 18 Dec 2007 20:54:52 -0000 1.2 +++ advice.el 19 Aug 2009 06:12:50 -0000 ＠＠ -218,7 +218,7 ＠＠ ;; "Make `car' an interactive function." ;; (interactive "xCar of list: ") ;; ad-do-it -;; (if (interactive-p) +;; (if (called-interactively-p) ;; (message "%s" ad-return-value))) ＠＠ -1825,8 +1825,18 ＠＠ (defmacro ad-xemacs-p () ;;Expands into Non-nil constant if we run XEmacs. ;;Unselected conditional code will be optimized away during compilation. - (string-match "XEmacs" emacs-version)) + (or (featurep 'xemacs) (string-match "XEmacs" emacs-version))) +;; #### This compatibility kludge should be moved into a `future' package. +(unless (fboundp 'called-interactively-p) + (defsubst called-interactively-p () + "Non-nil if this function was invoked with `call-interactively'. +`call-interactively' is implicitly applied when a function is invoked as a +command, as well as the occasional explicit use by commands which delegate +argument gathering to other functions. + This implementation is a kludge; semantics are different in batch-mode, +and may subtly differ in an interactive session." + (or (interactive-p) executing-kbd-macro))) ;; ＠＠ Variable definitions: ;; ======================== ＠＠ -2379,7 +2389,7 ＠＠ (interactive (list (ad-read-regexp "Enable advices via regexp: "))) (let ((matched-advices (ad-enable-regexp-internal regexp 'any t))) - (if (interactive-p) + (if (called-interactively-p) (message "%d matching advices enabled" matched-advices)) matched-advices)) ＠＠ -2389,7 +2399,7 ＠＠ (interactive (list (ad-read-regexp "Disable advices via regexp: "))) (let ((matched-advices (ad-enable-regexp-internal regexp 'any nil))) - (if (interactive-p) + (if (called-interactively-p) (message "%d matching advices disabled" matched-advices)) matched-advices)) ＠＠ -3105,7 +3115,7 ＠＠ (not advised-interactive-form)) ;; Check whether we were called interactively ;; in order to do proper prompting: - (` (if (interactive-p) + (` (if (called-interactively-p) (call-interactively '(, origname)) (, (ad-make-mapped-call orig-arglist advised-arglist origname))))) _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches

1 participants
0 comments

[COMMIT] Eliminate 781 funcalls at startup, simple.el 15 years, 4 months

Aidan Kehoe

APPROVE COMMIT NOTE: This patch has been committed. This was some low-hanging fruit from XEMACSDEBUG="(start-profiling)" ./xemacs -vanilla with an immediate (stop-profiling) once the binary came up. # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net> # Date 1250595274 -3600 # Node ID 891381effa11f5533e1bc096fec66f2ef0948dde # Parent 2c64d2bbb316ed5af5b7e536652b0e60701d91fd Eliminate 781 funcalls at startup, simple.el 2009-08-18 Aidan Kehoe <kehoea(a)parhasard.net> * simple.el (handle-pre-motion-command-current-command-is-motion): Replace mapc + #'(lambda ...) with dolist, eliminating 781 funcalls at XEmacs startup and decreasing GC a little. diff -r 2c64d2bbb316 -r 891381effa11 lisp/ChangeLog --- a/lisp/ChangeLog Sun Aug 16 21:00:08 2009 +0100 +++ b/lisp/ChangeLog Tue Aug 18 12:34:34 2009 +0100 ＠＠ -1,3 +1,9 ＠＠ +2009-08-18 Aidan Kehoe <kehoea(a)parhasard.net> + + * simple.el (handle-pre-motion-command-current-command-is-motion): + Replace mapc + #'(lambda ...) with dolist, eliminating 781 + funcalls at XEmacs startup and decreasing GC a little. + 2009-08-16 Aidan Kehoe <kehoea(a)parhasard.net> * faces.el (xpm-color-symbols): diff -r 2c64d2bbb316 -r 891381effa11 lisp/simple.el --- a/lisp/simple.el Sun Aug 16 21:00:08 2009 +0100 +++ b/lisp/simple.el Tue Aug 18 12:34:34 2009 +0100 ＠＠ -2096,15 +2096,13 ＠＠ (if (characterp b) (setq b (intern (char-to-string (downcase b))))) (eq a b))) - (mapc #'(lambda (keysym) - (when (if (listp keysym) - (and (equal mods (butlast keysym)) - (keysyms-equal key (car (last keysym)))) - (keysyms-equal key keysym)) - (throw - 'handle-pre-motion-command-current-command-is-motion - t))) - motion-keys-for-shifted-motion) + (dolist (keysym motion-keys-for-shifted-motion) + (when (if (listp keysym) + (and (equal mods (butlast keysym)) + (keysyms-equal key (car (last keysym)))) + (keysyms-equal key keysym)) + (throw 'handle-pre-motion-command-current-command-is-motion + t))) nil))))) (defun handle-pre-motion-command () -- ¿Dónde estará ahora mi sobrino Yoghurtu Nghe, que tuvo que huir precipitadamente de la aldea por culpa de la escasez de rinocerontes? _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches

1 participants
0 comments

commit: Eliminate 781 funcalls at startup, simple.el 15 years, 4 months

Aidan Kehoe

changeset: 4680:891381effa11 tag: tip user: Aidan Kehoe <kehoea(a)parhasard.net> date: Tue Aug 18 12:34:34 2009 +0100 files: lisp/ChangeLog lisp/simple.el description: Eliminate 781 funcalls at startup, simple.el 2009-08-18 Aidan Kehoe <kehoea(a)parhasard.net> * simple.el (handle-pre-motion-command-current-command-is-motion): Replace mapc + #'(lambda ...) with dolist, eliminating 781 funcalls at XEmacs startup and decreasing GC a little. diff -r 2c64d2bbb316 -r 891381effa11 lisp/ChangeLog --- a/lisp/ChangeLog Sun Aug 16 21:00:08 2009 +0100 +++ b/lisp/ChangeLog Tue Aug 18 12:34:34 2009 +0100 ＠＠ -1,3 +1,9 ＠＠ +2009-08-18 Aidan Kehoe <kehoea(a)parhasard.net> + + * simple.el (handle-pre-motion-command-current-command-is-motion): + Replace mapc + #'(lambda ...) with dolist, eliminating 781 + funcalls at XEmacs startup and decreasing GC a little. + 2009-08-16 Aidan Kehoe <kehoea(a)parhasard.net> * faces.el (xpm-color-symbols): diff -r 2c64d2bbb316 -r 891381effa11 lisp/simple.el --- a/lisp/simple.el Sun Aug 16 21:00:08 2009 +0100 +++ b/lisp/simple.el Tue Aug 18 12:34:34 2009 +0100 ＠＠ -2096,15 +2096,13 ＠＠ (if (characterp b) (setq b (intern (char-to-string (downcase b))))) (eq a b))) - (mapc #'(lambda (keysym) - (when (if (listp keysym) - (and (equal mods (butlast keysym)) - (keysyms-equal key (car (last keysym)))) - (keysyms-equal key keysym)) - (throw - 'handle-pre-motion-command-current-command-is-motion - t))) - motion-keys-for-shifted-motion) + (dolist (keysym motion-keys-for-shifted-motion) + (when (if (listp keysym) + (and (equal mods (butlast keysym)) + (keysyms-equal key (car (last keysym)))) + (keysyms-equal key keysym)) + (throw 'handle-pre-motion-command-current-command-is-motion + t))) nil))))) (defun handle-pre-motion-command () _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches

1 participants
0 comments

[PATCH (pkgs)] APEL 10.7 15 years, 4 months

Jerry James

PATCH packages XEmacs is being excluded from some Fedora work because our APEL package is too old [1]. Here is a sync with upstream version 10.7. I have used it in my daily work for the last two days. That's probably not saying much, because I have no idea what uses APEL. This should be considered only lightly tested. I'll attach the patch because I don't trust a cut & paste into gmail to preserve whitespace. Footnotes: [1] https://bugzilla.redhat.com/show_bug.cgi?id=503185 -- Jerry James http://www.jamezone.org/ _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches

1 participants
2 comments

Re: [PATCH] Support full Common Lisp multiple values in C. 15 years, 4 months

Aidan Kehoe

Ar an dara lá déag de mí Lúnasa, scríobh Michael Sperber: > Neat - does this cause any slowdown in byte-code execution? Nothing noticeable; I haven’t measured it, if you have a minute, please do. (Or suggest a reasonable set of tests test; would hanoi be enough?) This is the crux of it as a performance issue: #define IGNORE_MULTIPLE_VALUES(X) (multiple_value_current_limit == 1 ? (X) : ignore_multiple_values (X)) multiple_value_current_limit will be one, most of the time, since most code is not wrapped with (multiple-value-list ...) or (multiple-value-bind ...), and that will be the end of the conditional. This is what the assembler looks like: movl multiple_value_current_limit(%rip), %eax cmpl $1, %eax jne .L263 An important exception for measuring these things is code executed from *scratch*, which *is* wrapped in #'multiple-value-list, and so the IGNORE_MULTIPLE_VALUES actually needs to inspect objects to verify that they’re not multiple values. OK, I’ve just taken some time, and profile-expression with (hanoi 6) repeatedly gives me 10187 ticks (or thereabouts) in both builds. (No change if I add __builtin_expect in the appropriate place.) This isn’t a great test, though, it’s dominated by redisplay. Suggestions for a better one? -- ¿Dónde estará ahora mi sobrino Yoghurtu Nghe, que tuvo que huir precipitadamente de la aldea por culpa de la escasez de rinocerontes? _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches

1 participants
1 comments

[COMMIT (mh-e)] Don't call #'values from compiled code under 21.4, MH-E 15 years, 4 months

Mike Kupfer

NOTE: This patch has been committed. [APPROVE COMMIT] <19076.17054.8268.649765(a)parhasard.net> ChangeLog addition: 2009-08-13 Aidan Kehoe <kehoea(a)parhasard.net> * mh-e.el: * mh-index.el: * mh-seq.el: If #'values is an alias for #'list, force the compiler to use #'list. This way, code compiled with 21.4 will also work on XEmacs binaries with real support for multiple values. _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches

1 participants
0 comments

[COMMIT] Test the multiple-value functionality. 15 years, 4 months

Aidan Kehoe

APPROVE COMMIT NOTE: This patch has been committed. # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net> # Date 1250452808 -3600 # Node ID 2c64d2bbb316ed5af5b7e536652b0e60701d91fd # Parent b5e1d4f6b66fe7ad0d82f49e443292d9f5f4c550 Test the multiple-value functionality. tests/ChangeLog addition: 2009-08-16 Aidan Kehoe <kehoea(a)parhasard.net> * automated/lisp-tests.el (foo): Test the Common Lisp-compatibile multiple value functionality. diff -r b5e1d4f6b66f -r 2c64d2bbb316 tests/ChangeLog --- a/tests/ChangeLog Tue Aug 11 17:59:23 2009 +0100 +++ b/tests/ChangeLog Sun Aug 16 21:00:08 2009 +0100 ＠＠ -1,3 +1,8 ＠＠ +2009-08-16 Aidan Kehoe <kehoea(a)parhasard.net> + + * automated/lisp-tests.el (foo): + Test the Common Lisp-compatibile multiple value functionality. + 2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net> * automated/lisp-tests.el: diff -r b5e1d4f6b66f -r 2c64d2bbb316 tests/automated/lisp-tests.el --- a/tests/automated/lisp-tests.el Tue Aug 11 17:59:23 2009 +0100 +++ b/tests/automated/lisp-tests.el Sun Aug 16 21:00:08 2009 +0100 ＠＠ -1939,3 +1939,140 ＠＠ (princ (list 'quote (multiple-value-list (ftruncate first)))) (princ " :two-ftruncate-result ") (princ (list 'quote (multiple-value-list (ftruncate first second)))))) + +;; Multiple value tests. + +(flet ((foo (x y) + (floor (+ x y) y)) + (foo-zero (x y) + (values (floor (+ x y) y))) + (multiple-value-function-returning-t () + (values t pi e degrees-to-radians radians-to-degrees)) + (multiple-value-function-returning-nil () + (values t pi e radians-to-degrees degrees-to-radians)) + (function-throwing-multiple-values () + (let* ((listing '(0 3 4 nil "string" symbol)) + (tail listing) + elt) + (while t + (setq tail (cdr listing) + elt (car listing) + listing tail) + (when (null elt) + (throw 'VoN61Lo4Y (multiple-value-function-returning-t))))))) + (Assert + (= (+ (floor 5 3) (floor 19 4)) (+ 1 4) 5) + "Checking that multiple values are discarded correctly as func args") + (Assert + (= 2 (length (multiple-value-list (foo 400 (1+ most-positive-fixnum))))) + "Checking multiple values are passed through correctly as return values") + (Assert + (= 1 (length (multiple-value-list + (foo-zero 400 (1+ most-positive-fixnum))))) + "Checking multiple values are discarded correctly when forced") + (Check-Error setting-constant (setq multiple-values-limit 20)) + (Assert + (equal '(-1 1) + (multiple-value-list (floor -3 4))) + "Checking #'multiple-value-list gives a sane result") + (let ((ey 40000) + (bee "this is a string") + (cee #s(hash-table size 256 data (969 ?\xF9)))) + (Assert + (equal + (multiple-value-list (values ey bee cee)) + (multiple-value-list (values-list (list ey bee cee)))) + "Checking that #'values and #'values-list are correctly related") + (Assert + (equal + (multiple-value-list (values-list (list ey bee cee))) + (multiple-value-list (apply #'values (list ey bee cee)))) + "Checking #'values-list and #'apply with #values are correctly related")) + (Assert + (= (multiple-value-call #'+ (floor 5 3) (floor 19 4)) 10) + "Checking #'multiple-value-call gives reasonable results.") + (Assert + (= (multiple-value-call (values '+ '*) (floor 5 3) (floor 19 4)) 10) + "Checking #'multiple-value-call correct when first arg multiple.") + (Assert + (= 1 (length (multiple-value-list (prog1 (floor pi) "hi there")))) + "Checking #'prog1 does not pass back multiple values") + (Assert + (= 2 (length (multiple-value-list + (multiple-value-prog1 (floor pi) "hi there")))) + "Checking #'multiple-value-prog1 passes back multiple values") + (multiple-value-bind (floored remainder this-is-nil) + (floor pi 1.0) + (Assert (= floored 3) + "Checking floored bound correctly") + (Assert (eql remainder (- pi 3.0)) + "Checking remainder bound correctly") + (Assert (null this-is-nil) + "Checking trailing arg bound but nil")) + (let ((ey 40000) + (bee "this is a string") + (cee #s(hash-table size 256 data (969 ?\xF9)))) + (multiple-value-setq (ey bee cee) + (ffloor e 1.0)) + (Assert (eql 2.0 ey) "Checking ey set correctly") + (Assert (eql bee (- e 2.0)) "Checking bee set correctly") + (Assert (null cee) "Checking cee set to nil correctly")) + (Assert + (= 3 (length (multiple-value-list (eval '(values nil t pi))))) + "Checking #'eval passes back multiple values") + (Assert + (= 2 (length (multiple-value-list (apply #'floor '(5 3))))) + "Checking #'apply passes back multiple values") + (Assert + (= 2 (length (multiple-value-list (funcall #'floor 5 3)))) + "Checking #'funcall passes back multiple values") + (Assert + (equal '(1 2) (multiple-value-list + (multiple-value-call #'floor (values 5 3)))) + "Checking #'multiple-value-call passes back multiple values correctly") + (Assert + (= 1 (length (multiple-value-list + (and (multiple-value-function-returning-nil) t)))) + "Checking multiple values from non-trailing forms discarded by #'and") + (Assert + (= 5 (length (multiple-value-list + (and t (multiple-value-function-returning-nil))))) + "Checking multiple values from final forms not discarded by #'and") + (Assert + (= 1 (length (multiple-value-list + (or (multiple-value-function-returning-t) t)))) + "Checking multiple values from non-trailing forms discarded by #'and") + (Assert + (= 5 (length (multiple-value-list + (or nil (multiple-value-function-returning-t))))) + "Checking multiple values from final forms not discarded by #'and") + (Assert + (= 1 (length (multiple-value-list + (cond ((multiple-value-function-returning-t)))))) + "Checking cond doesn't pass back multiple values in tests.") + (Assert + (equal (list t pi e degrees-to-radians radians-to-degrees) + (multiple-value-list + (cond (t (multiple-value-function-returning-nil))))) + "Checking cond passes back multiple values in clauses.") + (Assert + (= 1 (length (multiple-value-list + (prog1 (multiple-value-function-returning-nil))))) + "Checking prog1 discards multiple values correctly.") + (Assert + (= 5 (length (multiple-value-list + (multiple-value-prog1 + (multiple-value-function-returning-nil))))) + "Checking multiple-value-prog1 passes back multiple values correctly.") + (Assert + (equal (list t pi e degrees-to-radians radians-to-degrees) + (multiple-value-list + (catch 'VoN61Lo4Y (function-throwing-multiple-values))))) + (Assert + (equal (list t pi e radians-to-degrees degrees-to-radians) + (multiple-value-list + (loop + for eye in `(a b c d ,e f g ,nil ,pi) + do (when (null eye) + (return (multiple-value-function-returning-t)))))) + "Checking #'loop passes back multiple values correctly.")) -- ¿Dónde estará ahora mi sobrino Yoghurtu Nghe, que tuvo que huir precipitadamente de la aldea por culpa de la escasez de rinocerontes? _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches

1 participants
0 comments

[PATCH] Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. 15 years, 4 months

Aidan Kehoe

Depends on the multiple-value support of http://mid.gmane.org/19073.42189.496305.702986＠parhasard.net ; also supports #'ffloor, #'fceiling, #'fround, #'ftruncate. Prospective tests for the multiple-value patch would depend on this change. Jerry, am I making any obvious mistakes in the number types code? It all runs here, but that might not necessarily mean a whole lot :-) . # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net> # Date 1250009963 -3600 # Node ID c2270b7d8c9a5daddf514c807d0cc80d87165417 # Parent e9880ed9d81228f9452a30249bea9ea6692adb7e Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. lisp/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net> * cl-extra.el (ceiling*, floor*, round*, truncate*): Implement these in terms of the C functions; mark them as obsolete. (mod*, rem*): Use #'nth-value with the C functions, not #'nth with the CL emulation functions. man/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net> * lispref/numbers.texi (Bigfloat Basics): Correct this documentation (ignoring for the moment that it breaks off in mid-sentence). tests/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net> * automated/lisp-tests.el: Test the new Common Lisp-compatible rounding functions available in C. (generate-rounding-output): Provide a function useful for generating the data for the rounding functions tests. src/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net> * floatfns.c (ROUNDING_CONVERT, CONVERT_WITH_NUMBER_TYPES) (CONVERT_WITHOUT_NUMBER_TYPES, MAYBE_TWO_ARGS_BIGNUM) (MAYBE_ONE_ARG_BIGNUM, MAYBE_TWO_ARGS_RATIO) (MAYBE_ONE_ARG_RATIO, MAYBE_TWO_ARGS_BIGFLOAT) (MAYBE_ONE_ARG_BIGFLOAT, MAYBE_EFF, MAYBE_CHAR_OR_MARKER): New macros, used in the implementation of the rounding functions. (ceiling_two_fixnum, ceiling_two_bignum, ceiling_two_ratio) (ceiling_two_bigfloat, ceiling_one_ratio, ceiling_one_bigfloat) (ceiling_two_float, ceiling_one_float, ceiling_one_mundane_arg) (floor_two_fixnum, floor_two_bignum, floor_two_ratio) (floor_two_bigfloat, floor_one_ratio, floor_one_bigfloat) (floor_two_float, floor_one_mundane_arg, round_two_fixnum) (round_two_bignum_1, round_two_bignum, round_two_ratio) (round_one_bigfloat_1, round_two_bigfloat, round_one_ratio) (round_one_bigfloat, round_two_float, round_one_float) (round_one_mundane_arg, truncate_two_fixnum) (truncate_two_bignum, truncate_two_ratio, truncate_two_bigfloat) (truncate_one_ratio, truncate_one_bigfloat, truncate_two_float) (truncate_one_float, truncate_one_mundane_arg): New functions, used in the implementation of the rounding functions. (Fceiling, Ffloor, Fround, Ftruncate, Ffceiling, Fffloor) (Ffround, Fftruncate): Revise to fully support Common Lisp conventions. This means: -- All functions have optional DIVISOR arguments -- All functions return multiple values; see #'values -- All functions do their arithmetic with the correct number types according to the contamination rules. -- #'round and #'fround always round towards the even number in ambiguous cases. * doprnt.c (emacs_doprnt_1): * number.c (internal_coerce_number): Call Ftruncate with two arguments, not one. * floatfns.c (Ffloat): Correct this, if NUMBER is a bignum. * lisp.h: Declare Ftruncate as taking two arguments. * number.c: Provide scratch_ratio2, init it appropriately. * number.h: Make scratch_ratio2 available. * number.h (BIGFLOAT_ARITH_RETURN): * number.h (BIGFLOAT_ARITH_RETURN1): Correct these functions. diff -r e9880ed9d812 -r c2270b7d8c9a lisp/ChangeLog --- a/lisp/ChangeLog Tue Aug 11 17:31:43 2009 +0100 +++ b/lisp/ChangeLog Tue Aug 11 17:59:23 2009 +0100 ＠＠ -1,3 +1,11 ＠＠ +2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net> + + * cl-extra.el (ceiling*, floor*, round*, truncate*): + Implement these in terms of the C functions; mark them as + obsolete. + (mod*, rem*): Use #'nth-value with the C functions, not #'nth with + the CL emulation functions. + 2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net> * bytecomp.el : diff -r e9880ed9d812 -r c2270b7d8c9a lisp/cl-compat.el --- a/lisp/cl-compat.el Tue Aug 11 17:31:43 2009 +0100 +++ b/lisp/cl-compat.el Tue Aug 11 17:59:23 2009 +0100 ＠＠ -82,12 +82,11 ＠＠ (if test-not (not (funcall test-not item elt)) (funcall (or test 'eql) item elt)))) -;;; Rounding functions with old-style multiple value returns. - -(defun cl-floor (a &optional b) (values-list (floor* a b))) -(defun cl-ceiling (a &optional b) (values-list (ceiling* a b))) -(defun cl-round (a &optional b) (values-list (round* a b))) -(defun cl-truncate (a &optional b) (values-list (truncate* a b))) +;; The rounding functions in C now have all the functionality this package +;; used to: +(loop + for symbol in '(floor ceiling round truncate) + do (defalias (intern (format "cl-%s" symbol)) symbol)) (defun safe-idiv (a b) (let* ((q (/ (abs a) (abs b))) diff -r e9880ed9d812 -r c2270b7d8c9a lisp/cl-extra.el --- a/lisp/cl-extra.el Tue Aug 11 17:31:43 2009 +0100 +++ b/lisp/cl-extra.el Tue Aug 11 17:59:23 2009 +0100 ＠＠ -394,56 +394,41 ＠＠ (or (and (fboundp 'expt) (subrp (symbol-function 'expt))) (defalias 'expt 'cl-expt)) -(defun floor* (x &optional y) - "Return a list of the floor of X and the fractional part of X. -With two arguments, return floor and remainder of their quotient." - (let ((q (floor x y))) - (list q (- x (if y (* y q) q))))) +;; We can't use macrolet in this file; whence the literal macro +;; definition-and-call: +((macro . (lambda (&rest symbols) + "Make some old CL package truncate and round functions available. -(defun ceiling* (x &optional y) - "Return a list of the ceiling of X and the fractional part of X. -With two arguments, return ceiling and remainder of their quotient." - (let ((res (floor* x y))) - (if (= (car (cdr res)) 0) res - (list (1+ (car res)) (- (car (cdr res)) (or y 1)))))) - -(defun truncate* (x &optional y) - "Return a list of the integer part of X and the fractional part of X. -With two arguments, return truncation and remainder of their quotient." - (if (eq (>= x 0) (or (null y) (>= y 0))) - (floor* x y) (ceiling* x y))) - -(defun round* (x &optional y) - "Return a list of X rounded to the nearest integer and the remainder. -With two arguments, return rounding and remainder of their quotient." - (if y - (if (and (integerp x) (integerp y)) - (let* ((hy (/ y 2)) - (res (floor* (+ x hy) y))) - (if (and (= (car (cdr res)) 0) - (= (+ hy hy) y) - (/= (% (car res) 2) 0)) - (list (1- (car res)) hy) - (list (car res) (- (car (cdr res)) hy)))) - (let ((q (round (/ x y)))) - (list q (- x (* q y))))) - (if (integerp x) (list x 0) - (let ((q (round x))) - (list q (- x q)))))) +These functions are now implemented in C; their Lisp implementations in this +XEmacs are trivial, so we provide them and mark them obsolete." + (let (symbol result) + (while symbols + (setq symbol (car symbols) + symbols (cdr symbols)) + (push `(make-obsolete ',(intern (format "%s*" symbol)) + ',symbol "21.5.29") + result) + (push + `(defun ,(intern (format "%s*" symbol)) (number &optional divisor) + ,(format "See `%s'. This returns a list, not multiple values." + symbol) + (multiple-value-list (,symbol number divisor))) + result)) + (cons 'progn result)))) + ceiling floor round truncate) (defun mod* (x y) "The remainder of X divided by Y, with the same sign as Y." - (nth 1 (floor* x y))) + (nth-value 1 (floor x y))) (defun rem* (x y) "The remainder of X divided by Y, with the same sign as X." - (nth 1 (truncate* x y))) + (nth-value 1 (truncate x y))) (defun signum (a) "Return 1 if A is positive, -1 if negative, 0 if zero." (cond ((> a 0) 1) ((< a 0) -1) (t 0))) - ;; Random numbers. (defvar *random-state*) diff -r e9880ed9d812 -r c2270b7d8c9a man/ChangeLog --- a/man/ChangeLog Tue Aug 11 17:31:43 2009 +0100 +++ b/man/ChangeLog Tue Aug 11 17:59:23 2009 +0100 ＠＠ -1,3 +1,9 ＠＠ +2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net> + + * lispref/numbers.texi (Bigfloat Basics): + Correct this documentation (ignoring for the moment that it breaks + off in mid-sentence). + 2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net> * cl.texi (Organization): diff -r e9880ed9d812 -r c2270b7d8c9a man/lispref/numbers.texi --- a/man/lispref/numbers.texi Tue Aug 11 17:31:43 2009 +0100 +++ b/man/lispref/numbers.texi Tue Aug 11 17:59:23 2009 +0100 ＠＠ -410,7 +410,8 ＠＠ It is possible to make bigfloat the default floating point format by setting ＠code{default-float-precision} to a non-zero value. Precision -is given in bits, with a maximum precision of ＠code{bigfloat-max-prec}. +is given in bits, with a maximum precision of +＠code{bigfloat-maximum-precision}. ＠c #### is this true? Bigfloats are created automatically when a number with yes diff -r e9880ed9d812 -r c2270b7d8c9a src/ChangeLog --- a/src/ChangeLog Tue Aug 11 17:31:43 2009 +0100 +++ b/src/ChangeLog Tue Aug 11 17:59:23 2009 +0100 ＠＠ -1,3 +1,50 ＠＠ +2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net> + + * floatfns.c (ROUNDING_CONVERT, CONVERT_WITH_NUMBER_TYPES) + (CONVERT_WITHOUT_NUMBER_TYPES, MAYBE_TWO_ARGS_BIGNUM) + (MAYBE_ONE_ARG_BIGNUM, MAYBE_TWO_ARGS_RATIO) + (MAYBE_ONE_ARG_RATIO, MAYBE_TWO_ARGS_BIGFLOAT) + (MAYBE_ONE_ARG_BIGFLOAT, MAYBE_EFF, MAYBE_CHAR_OR_MARKER): + New macros, used in the implementation of the rounding functions. + (ceiling_two_fixnum, ceiling_two_bignum, ceiling_two_ratio) + (ceiling_two_bigfloat, ceiling_one_ratio, ceiling_one_bigfloat) + (ceiling_two_float, ceiling_one_float, ceiling_one_mundane_arg) + (floor_two_fixnum, floor_two_bignum, floor_two_ratio) + (floor_two_bigfloat, floor_one_ratio, floor_one_bigfloat) + (floor_two_float, floor_one_mundane_arg, round_two_fixnum) + (round_two_bignum_1, round_two_bignum, round_two_ratio) + (round_one_bigfloat_1, round_two_bigfloat, round_one_ratio) + (round_one_bigfloat, round_two_float, round_one_float) + (round_one_mundane_arg, truncate_two_fixnum) + (truncate_two_bignum, truncate_two_ratio, truncate_two_bigfloat) + (truncate_one_ratio, truncate_one_bigfloat, truncate_two_float) + (truncate_one_float, truncate_one_mundane_arg): + New functions, used in the implementation of the rounding + functions. + (Fceiling, Ffloor, Fround, Ftruncate, Ffceiling, Fffloor) + (Ffround, Fftruncate): + Revise to fully support Common Lisp conventions. This means: + -- All functions have optional DIVISOR arguments + -- All functions return multiple values; see #'values + -- All functions do their arithmetic with the correct number types + according to the contamination rules. + -- #'round and #'fround always round towards the even number + in ambiguous cases. + * doprnt.c (emacs_doprnt_1): + * number.c (internal_coerce_number): + Call Ftruncate with two arguments, not one. + * floatfns.c (Ffloat): + Correct this, if NUMBER is a bignum. + * lisp.h: + Declare Ftruncate as taking two arguments. + * number.c: + Provide scratch_ratio2, init it appropriately. + * number.h: + Make scratch_ratio2 available. + * number.h (BIGFLOAT_ARITH_RETURN): + * number.h (BIGFLOAT_ARITH_RETURN1): + Correct these functions. + 2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net> * bytecode.c (enum Opcode /* Byte codes */): diff -r e9880ed9d812 -r c2270b7d8c9a src/bytecode.c --- a/src/bytecode.c Tue Aug 11 17:31:43 2009 +0100 +++ b/src/bytecode.c Tue Aug 11 17:59:23 2009 +0100 ＠＠ -301,8 +301,8 ＠＠ #ifdef HAVE_RATIO if (RATIOP (obj)) RATIO_ARITH_RETURN (obj, neg); #endif -#ifdef HAVE_BIG_FLOAT - if (BIGFLOAT_P (obj)) BIGFLOAT_ARITH_RETURN (obj, neg); +#ifdef HAVE_BIGFLOAT + if (BIGFLOATP (obj)) BIGFLOAT_ARITH_RETURN (obj, neg); #endif obj = wrong_type_argument (Qnumber_char_or_marker_p, obj); diff -r e9880ed9d812 -r c2270b7d8c9a src/doprnt.c --- a/src/doprnt.c Tue Aug 11 17:31:43 2009 +0100 +++ b/src/doprnt.c Tue Aug 11 17:59:23 2009 +0100 ＠＠ -638,7 +638,7 ＠＠ else { if (FLOATP (obj)) - obj = Ftruncate (obj); + obj = Ftruncate (obj, Qnil); #ifdef HAVE_BIGFLOAT else if (BIGFLOATP (obj)) { diff -r e9880ed9d812 -r c2270b7d8c9a src/floatfns.c --- a/src/floatfns.c Tue Aug 11 17:31:43 2009 +0100 +++ b/src/floatfns.c Tue Aug 11 17:59:23 2009 +0100 ＠＠ -769,7 +769,7 ＠＠ return make_float ((double) XINT (number)); #ifdef HAVE_BIGNUM - if (BIGFLOATP (number)) + if (BIGNUMP (number)) { #ifdef HAVE_BIGFLOAT if (ZEROP (Vdefault_float_precision)) ＠＠ -848,347 +848,1602 ＠＠ #endif /* ! HAVE_LOGB */ } -DEFUN ("ceiling", Fceiling, 1, 1, 0, /* -Return the smallest integer no less than NUMBER. (Round toward +inf.) -*/ - (number)) +#ifdef WITH_NUMBER_TYPES +#define ROUNDING_CONVERT(conversion, return_float) \ + CONVERT_WITH_NUMBER_TYPES(conversion, return_float) +#else +#define ROUNDING_CONVERT(conversion, return_float) \ + CONVERT_WITHOUT_NUMBER_TYPES(conversion, return_float) +#endif + +#define CONVERT_WITH_NUMBER_TYPES(conversion, return_float) \ + if (!NILP (divisor)) \ + { \ + switch (promote_args (&number, &divisor)) \ + { \ + case FIXNUM_T: \ + return conversion##_two_fixnum (number, divisor, \ + return_float); \ + MAYBE_TWO_ARGS_WITH_NUMBER_TYPES (conversion, \ + BIGNUM, \ + return_float); \ + MAYBE_TWO_ARGS_WITH_NUMBER_TYPES (conversion, \ + RATIO, \ + return_float); \ + MAYBE_TWO_ARGS_WITH_NUMBER_TYPES (conversion, \ + BIGFLOAT, \ + return_float); \ + default: /* FLOAT_T */ \ + return conversion##_two_float (number,divisor, \ + return_float); \ + } \ + } \ + \ + /* Try this first, the arg is probably a float: */ \ + if (FLOATP (number)) \ + return conversion##_one_float (number, return_float); \ + \ + MAYBE_ONE_ARG_WITH_NUMBER_TYPES (conversion, \ + RATIO, return_float); \ + MAYBE_ONE_ARG_WITH_NUMBER_TYPES (conversion, \ + BIGFLOAT, return_float); \ + return conversion##_one_mundane_arg (number, divisor, \ + return_float) + + +#define CONVERT_WITHOUT_NUMBER_TYPES(conversion, return_float) \ + if (!NILP (divisor)) \ + { \ + /* The promote_args call if number types are available \ + does these conversions, we do them too for symmetry: */\ + if (CHARP (number)) \ + { \ + number = make_int (XCHAR (number)); \ + } \ + else if (MARKERP (number)) \ + { \ + number = make_int (marker_position (number)); \ + } \ + \ + if (CHARP (divisor)) \ + { \ + divisor = make_int (XCHAR (divisor)); \ + } \ + else if (MARKERP (divisor)) \ + { \ + divisor = make_int (marker_position (divisor)); \ + } \ + \ + CHECK_INT_OR_FLOAT (divisor); \ + if (INTP (number) && INTP (divisor)) \ + { \ + return conversion##_two_fixnum (number, divisor, \ + return_float); \ + } \ + else \ + { \ + return conversion##_two_float (number, divisor, \ + return_float); \ + } \ + } \ + \ + /* Try this first, the arg is probably a float: */ \ + if (FLOATP (number)) \ + return conversion##_one_float (number, return_float); \ + \ + return conversion##_one_mundane_arg (number, divisor, \ + return_float) \ + +#ifdef WITH_NUMBER_TYPES + +#ifdef HAVE_BIGNUM +#define MAYBE_TWO_ARGS_BIGNUM(conversion, return_float) \ + case BIGNUM_T: \ + return conversion##_two_bignum (number, divisor, return_float) + +#define MAYBE_ONE_ARG_BIGNUM(converse, return_float) \ + if (BIGNUM_P (number)) \ + return conversion##_one_bignum (number, divisor, return_float) +#else +#define MAYBE_TWO_ARGS_BIGNUM(conversion, return_float) +#define MAYBE_ONE_ARG_BIGNUM(converse, return_float) +#endif + +#ifdef HAVE_RATIO +#define MAYBE_TWO_ARGS_RATIO(conversion, return_float) \ + case RATIO_T: \ + return conversion##_two_ratio (number, divisor, return_float) + +#define MAYBE_ONE_ARG_RATIO(conversion, return_float) \ + if (RATIOP (number)) \ + return conversion##_one_ratio (number, divisor, return_float) +#else +#define MAYBE_TWO_ARGS_RATIO(conversion, return_float) +#define MAYBE_ONE_ARG_RATIO(converse, return_float) +#endif + +#ifdef HAVE_BIGFLOAT +#define MAYBE_TWO_ARGS_BIGFLOAT(conversion, return_float) \ + case BIGFLOAT_T: \ + return conversion##_two_bigfloat (number, divisor, return_float) + +#define MAYBE_ONE_ARG_BIGFLOAT(conversion, return_float) \ + if (BIGFLOATP (number)) \ + return conversion##_one_bigfloat (number, divisor, return_float) +#else +#define MAYBE_TWO_ARGS_BIGFLOAT(conversion, return_float) +#define MAYBE_ONE_ARG_BIGFLOAT(converse, return_float) +#endif + +#define MAYBE_TWO_ARGS_WITH_NUMBER_TYPES(convers, upcase, return_float) \ + MAYBE_TWO_ARGS_##upcase(convers, return_float) + +#define MAYBE_ONE_ARG_WITH_NUMBER_TYPES(convers, upcase, return_float) \ + MAYBE_ONE_ARG_##upcase(convers, return_float) + +#endif /* WITH_NUMBER_TYPES */ + +#define MAYBE_EFF(str) (return_float ? "f" str : str) + +/* The WITH_NUMBER_TYPES code calls promote_args, which accepts chars and + markers as equivalent to ints. This block does the same for + single-argument calls. */ +#define MAYBE_CHAR_OR_MARKER(conversion) do { \ + if (CHARP (number)) \ + { \ + return conversion##_one_mundane_arg (make_int (XCHAR (number)), \ + divisor, return_float); \ + } \ + \ + if (MARKERP (number)) \ + { \ + return conversion##_one_mundane_arg (make_int \ + (marker_position(number)), \ + divisor, return_float); \ + } \ + } while (0) + + +/* The guts of the implementations of the various rounding functions: */ + +static Lisp_Object +ceiling_two_fixnum (Lisp_Object number, Lisp_Object divisor, + int return_float) { - if (FLOATP (number)) + EMACS_INT i1 = XREALINT (number); + EMACS_INT i2 = XREALINT (divisor); + EMACS_INT i3 = 0, i4 = 0; + + if (i2 == 0) + Fsignal (Qarith_error, Qnil); + + /* With C89's integer /, the result is implementation-defined if either + operand is negative, so use only nonnegative operands. Here we do + basically the opposite of what floor_two_fixnum does, we add one in the + non-negative case: */ + + /* Make sure we use the same signs for the modulus calculation as for the + quotient calculation: */ + if (i2 < 0) { - double d; - IN_FLOAT ((d = ceil (XFLOAT_DATA (number))), "ceiling", number); - return (float_to_int (d, "ceiling", number, Qunbound)); + if (i1 <= 0) + { + i3 = -i1 / -i2; + /* Quotient is positive; add one to give the figure for + ceiling. */ + if (0 != (-i1 % -i2)) + { + ++i3; + } + } + else + { + /* Quotient is negative; no need to add one. */ + i3 = -(i1 / -i2); + } + } + else + { + if (i1 < 0) + { + /* Quotient is negative; no need to add one. */ + i3 = -(-i1 / i2); + } + else + { + i3 = i1 / i2; + /* Quotient is positive; add one to give the figure for + ceiling. */ + if (0 != (i1 % i2)) + { + ++i3; + } + } } + i4 = i1 - (i3 * i2); + + if (!return_float) + { + return values2 (make_int (i3), make_int (i4)); + } + + return values2 (make_float ((double)i3), + make_int (i4)); +} + +#ifdef HAVE_BIGNUM +static Lisp_Object +ceiling_two_bignum (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + Lisp_Object res0, res1; + + if (bignum_sign (XBIGNUM_DATA (divisor)) == 0) + { + Fsignal (Qarith_error, Qnil); + } + + bignum_ceil (scratch_bignum, XBIGNUM_DATA (number), XBIGNUM_DATA (divisor)); + + res0 = return_float ? make_float (bignum_to_double (scratch_bignum)) : + Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + + if (bignum_divisible_p (XBIGNUM_DATA (number), XBIGNUM_DATA (divisor))) + { + res1 = Qzero; + } + else + { + bignum_mul (scratch_bignum, scratch_bignum, XBIGNUM_DATA (divisor)); + bignum_sub (scratch_bignum, XBIGNUM_DATA (number), scratch_bignum); + res1 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + } + + return values2 (res0, res1); +} +#endif /* HAVE_BIGNUM */ + +#ifdef HAVE_RATIO +static Lisp_Object +ceiling_two_ratio (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + Lisp_Object res0, res1; + + if (ratio_sign (XRATIO_DATA (divisor)) == 0) + { + Fsignal (Qarith_error, Qnil); + } + + ratio_div (scratch_ratio, XRATIO_DATA (number), XRATIO_DATA (divisor)); + + bignum_ceil (scratch_bignum, ratio_numerator (scratch_ratio), + ratio_denominator (scratch_ratio)); + + res0 = return_float ? make_float (bignum_to_double (scratch_bignum)) : + Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + + if (bignum_divisible_p (ratio_numerator (scratch_ratio), + ratio_denominator (scratch_ratio))) + { + res1 = Qzero; + } + else + { + ratio_set_bignum (scratch_ratio, scratch_bignum); + ratio_mul (scratch_ratio2, scratch_ratio, XRATIO_DATA (divisor)); + ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio2); + res1 = Fcanonicalize_number (make_ratio_rt (scratch_ratio)); + } + + return values2 (res0, res1); +} +#endif /* HAVE_RATIO */ + +#ifdef HAVE_BIGFLOAT +static Lisp_Object +ceiling_two_bigfloat (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + Lisp_Object res0; + + if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0) + { + Fsignal (Qarith_error, Qnil); + } + + bigfloat_set_prec (scratch_bigfloat, max (XBIGFLOAT_GET_PREC (number), + XBIGFLOAT_GET_PREC (divisor))); + bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (number), + XBIGFLOAT_DATA (divisor)); + bigfloat_ceil (scratch_bigfloat, scratch_bigfloat); + + if (return_float) + { + res0 = make_bigfloat_bf (scratch_bigfloat); + } + else + { +#ifdef HAVE_BIGNUM + bignum_set_bigfloat (scratch_bignum, scratch_bigfloat); + res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#else + res0 = make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat)); +#endif /* HAVE_BIGNUM */ + } + + bigfloat_mul (scratch_bigfloat, scratch_bigfloat, XBIGFLOAT_DATA (divisor)); + bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (number), scratch_bigfloat); + return values2 (res0, + Fcanonicalize_number (make_bigfloat_bf (scratch_bigfloat))); +} +#endif /* HAVE_BIGFLOAT */ + +#ifdef HAVE_RATIO +static Lisp_Object +ceiling_one_ratio (Lisp_Object number, Lisp_Object UNUSED (divisor), + int return_float) +{ + Lisp_Object res0, res1; + + bignum_ceil (scratch_bignum, XRATIO_NUMERATOR (number), + XRATIO_DENOMINATOR (number)); + + res0 = return_float ? make_float (bignum_to_double (scratch_bignum)) : + Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + + if (bignum_divisible_p (XRATIO_NUMERATOR (number), + XRATIO_DENOMINATOR (number))) + { + res1 = Qzero; + } + else + { + ratio_set_bignum (scratch_ratio2, scratch_bignum); + ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio2); + res1 = Fcanonicalize_number (make_ratio_rt (scratch_ratio)); + } + + return values2 (res0, res1); +} +#endif /* HAVE_RATIO */ + +#ifdef HAVE_BIGFLOAT +static Lisp_Object +ceiling_one_bigfloat (Lisp_Object number, Lisp_Object UNUSED (divisor), + int return_float) +{ + Lisp_Object res0, res1; + + bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number)); + bigfloat_ceil (scratch_bigfloat, XBIGFLOAT_DATA (number)); + + if (return_float) + { + res0 = make_bigfloat_bf (scratch_bigfloat); + } + else + { +#ifdef HAVE_BIGNUM + bignum_set_bigfloat (scratch_bignum, scratch_bigfloat); + res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#else + res0 = make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat)); +#endif /* HAVE_BIGNUM */ + } + + bigfloat_sub (scratch_bigfloat2, XBIGFLOAT_DATA (number), scratch_bigfloat); + + res1 = make_bigfloat_bf (scratch_bigfloat2); + return values2 (res0, res1); +} +#endif /* HAVE_BIGFLOAT */ + +static Lisp_Object +ceiling_two_float (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + double f1 = extract_float (number); + double f2 = extract_float (divisor); + double f0, remain; + Lisp_Object res0; + + if (f2 == 0.0) + { + Fsignal (Qarith_error, Qnil); + } + + IN_FLOAT2 (f0 = ceil (f1 / f2), MAYBE_EFF("ceiling"), number, divisor); + IN_FLOAT2 (remain = f1 - (f0 * f2), MAYBE_EFF("ceiling"), number, divisor); + + if (return_float) + { + res0 = make_float(f0); + } + else + { + res0 = float_to_int (f0, MAYBE_EFF("ceiling"), number, divisor); + } + + return values2 (res0, make_float (remain)); +} + +static Lisp_Object +ceiling_one_float (Lisp_Object number, int return_float) +{ + double d, remain; + Lisp_Object res0; + + IN_FLOAT ((d = ceil (XFLOAT_DATA (number))), MAYBE_EFF("ceiling"), number); + IN_FLOAT ((remain = XFLOAT_DATA (number) - d), MAYBE_EFF("ceiling"), number); + + if (return_float) + { + res0 = make_float (d); + } + else + { + res0 = float_to_int (d, MAYBE_EFF("ceiling"), number, Qunbound); + } + return values2 (res0, make_float (remain)); +} + +EXFUN (Fceiling, 2); +EXFUN (Ffceiling, 2); + +static Lisp_Object +ceiling_one_mundane_arg (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + + if (return_float) + { + if (INTP (number)) + { + return values2 (make_float ((double) XINT (number)), Qzero); + } +#ifdef HAVE_BIGNUM + else if (BIGNUMP (number)) + { + return values2 (make_float + (bignum_to_double (XBIGNUM_DATA (number))), + Qzero); + } +#endif + } + else + { +#ifdef HAVE_BIGNUM + if (INTEGERP (number)) +#else + if (INTP (number)) +#endif + { + return values2 (number, Qzero); + } + } + + MAYBE_CHAR_OR_MARKER (ceiling); + + return Ffceiling (wrong_type_argument (Qnumberp, number), divisor); +} + +static Lisp_Object +floor_two_fixnum (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + EMACS_INT i1 = XREALINT (number); + EMACS_INT i2 = XREALINT (divisor); + EMACS_INT i3 = 0, i4 = 0; + Lisp_Object res0; + + if (i2 == 0) + { + Fsignal (Qarith_error, Qnil); + } + + /* With C89's integer /, the result is implementation-defined if either + operand is negative, so use only nonnegative operands. Notice also that + we're forcing the quotient of any negative numbers towards minus + infinity. */ + i3 = (i2 < 0 + ? (i1 <= 0 ? -i1 / -i2 : -1 - ((i1 - 1) / -i2)) + : (i1 < 0 ? -1 - ((-1 - i1) / i2) : i1 / i2)); + + i4 = i1 - (i3 * i2); + + if (return_float) + { + res0 = make_float ((double)i3); + } + else + { + res0 = make_int (i3); + } + + return values2 (res0, make_int (i4)); +} + +#ifdef HAVE_BIGNUM +static Lisp_Object +floor_two_bignum (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + Lisp_Object res0, res1; + + if (bignum_sign (XBIGNUM_DATA (divisor)) == 0) + { + Fsignal (Qarith_error, Qnil); + } + + bignum_floor (scratch_bignum, XBIGNUM_DATA (number), + XBIGNUM_DATA (divisor)); + + if (return_float) + { + res0 = make_float (bignum_to_double (scratch_bignum)); + } + else + { + res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + } + + if (bignum_divisible_p (XBIGNUM_DATA (number), XBIGNUM_DATA (divisor))) + { + res1 = Qzero; + } + else + { + bignum_mul (scratch_bignum, scratch_bignum, XBIGNUM_DATA (divisor)); + bignum_sub (scratch_bignum, XBIGNUM_DATA (number), scratch_bignum); + res1 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + } + + return values2 (res0, res1); +} +#endif /* HAVE_BIGNUM */ + +#ifdef HAVE_RATIO +static Lisp_Object +floor_two_ratio (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + Lisp_Object res0, res1; + + if (ratio_sign (XRATIO_DATA (divisor)) == 0) + { + Fsignal (Qarith_error, Qnil); + } + + ratio_div (scratch_ratio, XRATIO_DATA (number), XRATIO_DATA (divisor)); + + bignum_floor (scratch_bignum, ratio_numerator (scratch_ratio), + ratio_denominator (scratch_ratio)); + + res0 = return_float ? make_float (bignum_to_double (scratch_bignum)) : + Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + + if (bignum_divisible_p (ratio_numerator (scratch_ratio), + ratio_denominator (scratch_ratio))) + { + res1 = Qzero; + } + else + { + ratio_set_bignum (scratch_ratio, scratch_bignum); + ratio_mul (scratch_ratio, scratch_ratio, XRATIO_DATA (divisor)); + ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio); + res1 = Fcanonicalize_number (make_ratio_rt (scratch_ratio)); + } + + return values2 (res0, res1); +} +#endif /* HAVE_RATIO */ + +#ifdef HAVE_BIGFLOAT +static Lisp_Object +floor_two_bigfloat (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + Lisp_Object res0; + + if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0) + { + Fsignal (Qarith_error, Qnil); + } + + bigfloat_set_prec (scratch_bigfloat, max (XBIGFLOAT_GET_PREC (number), + XBIGFLOAT_GET_PREC (divisor))); + bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (number), + XBIGFLOAT_DATA (divisor)); + bigfloat_floor (scratch_bigfloat, scratch_bigfloat); + + if (return_float) + { + res0 = make_bigfloat_bf (scratch_bigfloat); + } + else + { +#ifdef HAVE_BIGNUM + bignum_set_bigfloat (scratch_bignum, scratch_bigfloat); + res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#else + res0 = make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat)); +#endif /* HAVE_BIGNUM */ + } + + bigfloat_mul (scratch_bigfloat2, scratch_bigfloat, + XBIGFLOAT_DATA (divisor)); + bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (number), scratch_bigfloat2); + + return values2 (res0, make_bigfloat_bf (scratch_bigfloat)); +} +#endif /* HAVE_BIGFLOAT */ + +#ifdef HAVE_RATIO +static Lisp_Object +floor_one_ratio (Lisp_Object number, Lisp_Object UNUSED (divisor), + int return_float) +{ + Lisp_Object res0, res1; + + bignum_floor (scratch_bignum, XRATIO_NUMERATOR (number), + XRATIO_DENOMINATOR (number)); + + res0 = return_float ? make_float (bignum_to_double (scratch_bignum)) : + Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + + if (bignum_divisible_p (XRATIO_NUMERATOR (number), + XRATIO_DENOMINATOR (number))) + { + res1 = Qzero; + } + else + { + ratio_set_bignum (scratch_ratio2, scratch_bignum); + ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio2); + res1 = Fcanonicalize_number (make_ratio_rt (scratch_ratio)); + } + + return values2 (res0, res1); +} +#endif /* HAVE_RATIO */ + +#ifdef HAVE_BIGFLOAT +static Lisp_Object +floor_one_bigfloat (Lisp_Object number, Lisp_Object UNUSED (divisor), + int return_float) +{ + Lisp_Object res0; + + bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number)); + bigfloat_floor (scratch_bigfloat, XBIGFLOAT_DATA (number)); + + if (return_float) + { + res0 = make_bigfloat_bf (scratch_bigfloat); + } + else + { +#ifdef HAVE_BIGNUM + bignum_set_bigfloat (scratch_bignum, scratch_bigfloat); + res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#else + res0 = make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat)); +#endif /* HAVE_BIGNUM */ + } + + bigfloat_sub (scratch_bigfloat2, XBIGFLOAT_DATA (number), scratch_bigfloat); + return values2 (res0, make_bigfloat_bf (scratch_bigfloat2)); +} +#endif /* HAVE_BIGFLOAT */ + +static Lisp_Object +floor_two_float (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + double f1 = extract_float (number); + double f2 = extract_float (divisor); + double f0, remain; + + if (f2 == 0.0) + { + Fsignal (Qarith_error, Qnil); + } + + IN_FLOAT2 (f0 = floor (f1 / f2), MAYBE_EFF ("floor"), number, divisor); + IN_FLOAT2 (remain = f1 - (f0 * f2), MAYBE_EFF ("floor"), number, divisor); + + if (return_float) + { + return values2 (make_float (f0), make_float (remain)); + } + + return values2 (float_to_int (f0, MAYBE_EFF ("floor"), number, divisor), + make_float (remain)); +} + +static Lisp_Object +floor_one_float (Lisp_Object number, int return_float) +{ + double d, d1; + + IN_FLOAT ((d = floor (XFLOAT_DATA (number))), MAYBE_EFF ("floor"), number); + IN_FLOAT ((d1 = XFLOAT_DATA (number) - d), MAYBE_EFF ("floor"), number); + + if (return_float) + { + return values2 (make_float (d), make_float (d1)); + } + else + { + return values2 (float_to_int (d, MAYBE_EFF ("floor"), number, Qunbound), + make_float (d1)); + } +} + +EXFUN (Ffloor, 2); +EXFUN (Fffloor, 2); + +static Lisp_Object +floor_one_mundane_arg (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ #ifdef HAVE_BIGNUM if (INTEGERP (number)) #else if (INTP (number)) #endif - return number; + { + if (return_float) + { + return values2 (make_float (extract_float (number)), Qzero); + } + else + { + return values2 (number, Qzero); + } + } -#ifdef HAVE_RATIO - if (RATIOP (number)) + MAYBE_CHAR_OR_MARKER (floor); + + if (return_float) { - bignum_ceil (scratch_bignum, XRATIO_NUMERATOR (number), - XRATIO_DENOMINATOR (number)); - return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); - } -#endif - -#ifdef HAVE_BIGFLOAT - if (BIGFLOATP (number)) - { - bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number)); - bigfloat_ceil (scratch_bigfloat, XBIGFLOAT_DATA (number)); -#ifdef HAVE_BIGNUM - bignum_set_bigfloat (scratch_bignum, scratch_bigfloat); - return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); -#else - return make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat)); -#endif /* HAVE_BIGNUM */ - } -#endif /* HAVE_BIGFLOAT */ - - return Fceiling (wrong_type_argument (Qnumberp, number)); -} - - -DEFUN ("floor", Ffloor, 1, 2, 0, /* -Return the largest integer no greater than NUMBER. (Round towards -inf.) -With optional second argument DIVISOR, return the largest integer no -greater than NUMBER/DIVISOR. -*/ - (number, divisor)) -{ -#ifdef WITH_NUMBER_TYPES - CHECK_REAL (number); - if (NILP (divisor)) - { - if (FLOATP (number)) - { - double d; - IN_FLOAT ((d = floor (XFLOAT_DATA (number))), "floor", number); - return (float_to_int (d, "floor", number, Qunbound)); - } -#ifdef HAVE_RATIO - else if (RATIOP (number)) - { - bignum_floor (scratch_bignum, XRATIO_NUMERATOR (number), - XRATIO_DENOMINATOR (number)); - return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); - } -#endif -#ifdef HAVE_BIGFLOAT - else if (BIGFLOATP (number)) - { - bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number)); - bigfloat_floor (scratch_bigfloat, XBIGFLOAT_DATA (number)); - return make_bigfloat_bf (scratch_bigfloat); - } -#endif - return number; + return Fffloor (wrong_type_argument (Qnumberp, number), divisor); } else { - CHECK_REAL (divisor); - switch (promote_args (&number, &divisor)) - { - case FIXNUM_T: - { - EMACS_INT i1 = XREALINT (number); - EMACS_INT i2 = XREALINT (divisor); + return Ffloor (wrong_type_argument (Qnumberp, number), divisor); + } +} - if (i2 == 0) - Fsignal (Qarith_error, Qnil); +/* Algorithm taken from cl-extra.el, now to be found as cl-round in + tests/automated/lisp-tests.el. */ +static Lisp_Object +round_two_fixnum (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + EMACS_INT i1 = XREALINT (number); + EMACS_INT i2 = XREALINT (divisor); + EMACS_INT i0, hi2, flooring, floored, flsecond; - /* With C's /, the result is implementation-defined if either - operand is negative, so use only nonnegative operands. */ - i1 = (i2 < 0 - ? (i1 <= 0 ? -i1 / -i2 : -1 - ((i1 - 1) / -i2)) - : (i1 < 0 ? -1 - ((-1 - i1) / i2) : i1 / i2)); - - return make_int (i1); - } -#ifdef HAVE_BIGNUM - case BIGNUM_T: - if (bignum_sign (XBIGNUM_DATA (divisor)) == 0) - Fsignal (Qarith_error, Qnil); - bignum_floor (scratch_bignum, XBIGNUM_DATA (number), - XBIGNUM_DATA (divisor)); - return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); -#endif -#ifdef HAVE_RATIO - case RATIO_T: - if (ratio_sign (XRATIO_DATA (divisor)) == 0) - Fsignal (Qarith_error, Qnil); - ratio_div (scratch_ratio, XRATIO_DATA (number), - XRATIO_DATA (divisor)); - bignum_floor (scratch_bignum, ratio_numerator (scratch_ratio), - ratio_denominator (scratch_ratio)); - return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); -#endif -#ifdef HAVE_BIGFLOAT - case BIGFLOAT_T: - if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0) - Fsignal (Qarith_error, Qnil); - bigfloat_set_prec (scratch_bigfloat, - max (XBIGFLOAT_GET_PREC (number), - XBIGFLOAT_GET_PREC (divisor))); - bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (number), - XBIGFLOAT_DATA (divisor)); - bigfloat_floor (scratch_bigfloat, scratch_bigfloat); - return make_bigfloat_bf (scratch_bigfloat); -#endif - default: /* FLOAT_T */ - { - double f1 = extract_float (number); - double f2 = extract_float (divisor); - - if (f2 == 0.0) - Fsignal (Qarith_error, Qnil); - - IN_FLOAT2 (f1 = floor (f1 / f2), "floor", number, divisor); - return float_to_int (f1, "floor", number, divisor); - } - } - } -#else /* !WITH_NUMBER_TYPES */ - CHECK_INT_OR_FLOAT (number); - - if (! NILP (divisor)) + if (i2 == 0) { - EMACS_INT i1, i2; - - CHECK_INT_OR_FLOAT (divisor); - - if (FLOATP (number) || FLOATP (divisor)) - { - double f1 = extract_float (number); - double f2 = extract_float (divisor); - - if (f2 == 0) - Fsignal (Qarith_error, Qnil); - - IN_FLOAT2 (f1 = floor (f1 / f2), "floor", number, divisor); - return float_to_int (f1, "floor", number, divisor); - } - - i1 = XINT (number); - i2 = XINT (divisor); - - if (i2 == 0) - Fsignal (Qarith_error, Qnil); - - /* With C's /, the result is implementation-defined if either operand - is negative, so use only nonnegative operands. */ - i1 = (i2 < 0 - ? (i1 <= 0 ? -i1 / -i2 : -1 - ((i1 - 1) / -i2)) - : (i1 < 0 ? -1 - ((-1 - i1) / i2) : i1 / i2)); - - return (make_int (i1)); + Fsignal (Qarith_error, Qnil); } - if (FLOATP (number)) + hi2 = i2 < 0 ? -( -i2 / 2) : i2 / 2; + + flooring = hi2 + i1; + + floored = (i2 < 0 + ? (flooring <= 0 ? -flooring / -i2 : -1 - ((flooring - 1) / -i2)) + : (flooring < 0 ? -1 - ((-1 - flooring) / i2) : flooring / i2)); + + flsecond = flooring - (floored * i2); + + if (0 == flsecond + && (i2 == (hi2 + hi2)) + && (0 != (floored % 2))) { - double d; - IN_FLOAT ((d = floor (XFLOAT_DATA (number))), "floor", number); - return (float_to_int (d, "floor", number, Qunbound)); + i0 = floored - 1; + return values2 (return_float ? make_float ((double)i0) : + make_int (i0), make_int (hi2)); + } + else + { + return values2 (return_float ? make_float ((double)floored) : + make_int (floored), + make_int (flsecond - hi2)); + } +} + +#ifdef HAVE_BIGNUM +static void +round_two_bignum_1 (bignum number, bignum divisor, + Lisp_Object *res, Lisp_Object *remain) +{ + bignum flooring, floored, hi2, flsecond; + + if (bignum_divisible_p (number, divisor)) + { + bignum_div (scratch_bignum, number, divisor); + *res = make_bignum_bg (scratch_bignum); + *remain = Qzero; + return; } - return number; -#endif /* WITH_NUMBER_TYPES */ + bignum_set_long (scratch_bignum, 2); + + bignum_div (scratch_bignum2, divisor, scratch_bignum); + + bignum_init (hi2); + bignum_set (hi2, scratch_bignum2); + + bignum_add (scratch_bignum, scratch_bignum2, number); + bignum_init (flooring); + bignum_set (flooring, scratch_bignum); + + bignum_floor (scratch_bignum, flooring, divisor); + bignum_init (floored); + bignum_set (floored, scratch_bignum); + + bignum_mul (scratch_bignum2, scratch_bignum, divisor); + bignum_sub (scratch_bignum, flooring, scratch_bignum2); + bignum_init (flsecond); + bignum_set (flsecond, scratch_bignum); + + bignum_set_long (scratch_bignum, 2); + bignum_mul (scratch_bignum2, scratch_bignum, hi2); + + if (bignum_sign (flsecond) == 0 + && bignum_eql (divisor, scratch_bignum2) + && (1 == bignum_testbit (floored, 0))) + { + bignum_set_long (scratch_bignum, 1); + bignum_sub (floored, floored, scratch_bignum); + *res = make_bignum_bg (floored); + *remain = make_bignum_bg (hi2); + } + else + { + bignum_sub (scratch_bignum, flsecond, + hi2); + *res = make_bignum_bg (floored); + *remain = make_bignum_bg (scratch_bignum); + } } -DEFUN ("round", Fround, 1, 1, 0, /* -Return the nearest integer to NUMBER. -*/ - (number)) +static Lisp_Object +round_two_bignum (Lisp_Object number, Lisp_Object divisor, + int return_float) { - if (FLOATP (number)) + Lisp_Object res0, res1; + + if (bignum_sign (XBIGNUM_DATA (divisor)) == 0) { - double d; - /* Screw the prevailing rounding mode. */ - IN_FLOAT ((d = emacs_rint (XFLOAT_DATA (number))), "round", number); - return (float_to_int (d, "round", number, Qunbound)); + Fsignal (Qarith_error, Qnil); } + round_two_bignum_1 (XBIGNUM_DATA (number), XBIGNUM_DATA (divisor), + &res0, &res1); + + if (return_float) + { + res0 = make_float (bignum_to_double (XBIGNUM_DATA (res0))); + } + else + { + res0 = Fcanonicalize_number (res0); + } + + return values2 (res0, Fcanonicalize_number (res1)); +} +#endif /* HAVE_BIGNUM */ + +#ifdef HAVE_RATIO +static Lisp_Object +round_two_ratio (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + Lisp_Object res0, res1; + + if (ratio_sign (XRATIO_DATA (divisor)) == 0) + { + Fsignal (Qarith_error, Qnil); + } + + ratio_div (scratch_ratio, XRATIO_DATA (number), XRATIO_DATA (divisor)); + + round_two_bignum_1 (ratio_numerator (scratch_ratio), + ratio_denominator (scratch_ratio), &res0, &res1); + + if (!ZEROP (res1)) + { + /* The numerator and denominator don't round exactly, calculate a + ratio remainder: */ + ratio_set_bignum (scratch_ratio2, XBIGNUM_DATA (res0)); + ratio_mul (scratch_ratio, scratch_ratio2, XRATIO_DATA (divisor)); + ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio); + + res1 = Fcanonicalize_number (make_ratio_rt (scratch_ratio)); + } + + res0 = return_float ? + make_float ((double)bignum_to_double(XBIGNUM_DATA (res0))) : + Fcanonicalize_number (res0); + + return values2 (res0, res1); +} +#endif /* HAVE_RATIO */ + +#ifdef HAVE_BIGFLOAT +/* This is the logic of emacs_rint above, no more and no less. */ +static Lisp_Object +round_one_bigfloat_1 (bigfloat number) +{ + Lisp_Object res0; + unsigned long prec = bigfloat_get_prec (number); + + assert ((bigfloat *)(&number) != (bigfloat *)&scratch_bigfloat + && (bigfloat *)(&number) != (bigfloat *)(&scratch_bigfloat2)); + + bigfloat_set_prec (scratch_bigfloat, prec); + bigfloat_set_prec (scratch_bigfloat2, prec); + + bigfloat_set_double (scratch_bigfloat, 0.5); + bigfloat_add (scratch_bigfloat2, scratch_bigfloat, number); + bigfloat_floor (scratch_bigfloat, scratch_bigfloat2); + res0 = make_bigfloat_bf (scratch_bigfloat); + + bigfloat_sub (scratch_bigfloat2, scratch_bigfloat, number); + bigfloat_abs (scratch_bigfloat, scratch_bigfloat2); + + bigfloat_set_double (scratch_bigfloat2, 0.5); + + do { + if (!bigfloat_ge (scratch_bigfloat, scratch_bigfloat2)) + { + break; + } + + if (!bigfloat_gt (scratch_bigfloat, scratch_bigfloat2)) + { + bigfloat_set_double (scratch_bigfloat2, 2.0); + bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (res0), + scratch_bigfloat2); + bigfloat_floor (scratch_bigfloat2, scratch_bigfloat); + bigfloat_set_double (scratch_bigfloat, 2.0); + bigfloat_mul (scratch_bigfloat2, scratch_bigfloat2, + scratch_bigfloat); + if (bigfloat_eql (scratch_bigfloat2, XBIGFLOAT_DATA (res0))) + { + break; + } + } + + if (bigfloat_lt (XBIGFLOAT_DATA (res0), number)) + { + bigfloat_set_double (scratch_bigfloat2, 1.0); + } + else + { + bigfloat_set_double (scratch_bigfloat2, -1.0); + } + + bigfloat_set (scratch_bigfloat, XBIGFLOAT_DATA (res0)); + + bigfloat_add (XBIGFLOAT_DATA (res0), scratch_bigfloat2, + scratch_bigfloat); + + } while (0); + + return res0; +} + +static Lisp_Object +round_two_bigfloat (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + Lisp_Object res0, res1; + bigfloat divided; + + unsigned long prec = max (XBIGFLOAT_GET_PREC (number), + XBIGFLOAT_GET_PREC (divisor)); + + if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0) + { + Fsignal (Qarith_error, Qnil); + } + + bigfloat_init (divided); + bigfloat_set_prec (divided, prec); + + bigfloat_div (divided, XBIGFLOAT_DATA (number), XBIGFLOAT_DATA (divisor)); + + res0 = round_one_bigfloat_1 (divided); + + bigfloat_set_prec (scratch_bigfloat, prec); + bigfloat_set_prec (scratch_bigfloat2, prec); + + bigfloat_mul (scratch_bigfloat, XBIGFLOAT_DATA (res0), + XBIGFLOAT_DATA (divisor)); + bigfloat_sub (scratch_bigfloat2, XBIGFLOAT_DATA (number), + scratch_bigfloat); + + res1 = make_bigfloat_bf (scratch_bigfloat2); + + if (!return_float) + { +#ifdef HAVE_BIGNUM + bignum_set_bigfloat (scratch_bignum, XBIGFLOAT_DATA (res0)); + res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#else + res0 = make_int ((EMACS_INT) bigfloat_to_long (XBIGFLOAT_DATA (res0))); +#endif /* HAVE_BIGNUM */ + } + + return values2 (res0, res1); +} +#endif /* HAVE_BIGFLOAT */ + +#ifdef HAVE_RATIO +static Lisp_Object +round_one_ratio (Lisp_Object number, Lisp_Object UNUSED (divisor), + int return_float) +{ + Lisp_Object res0, res1; + + round_two_bignum_1 (XRATIO_NUMERATOR (number), XRATIO_DENOMINATOR (number), + &res0, &res1); + + if (!ZEROP (res1)) + { + ratio_set_bignum (scratch_ratio2, XBIGNUM_DATA (res0)); + ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio2); + res1 = Fcanonicalize_number (make_ratio_rt (scratch_ratio)); + } + + res0 = return_float ? + make_float ((double)bignum_to_double(XBIGNUM_DATA (res0))) : + Fcanonicalize_number (res0); + + return values2 (res0, res1); +} +#endif /* HAVE_RATIO */ + +#ifdef HAVE_BIGFLOAT +static Lisp_Object +round_one_bigfloat (Lisp_Object number, Lisp_Object UNUSED (divisor), + int return_float) +{ + Lisp_Object res0 = round_one_bigfloat_1 (XBIGFLOAT_DATA (number)); + Lisp_Object res1; + + bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (number), + XBIGFLOAT_DATA (res0)); + + res1 = make_bigfloat_bf (scratch_bigfloat); + + if (!return_float) + { +#ifdef HAVE_BIGNUM + bignum_set_bigfloat (scratch_bignum, XBIGFLOAT_DATA (res0)); + res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#else + res0 = make_int ((EMACS_INT) bigfloat_to_long + (XBIGFLOAT_DATA (res0))); +#endif /* HAVE_BIGNUM */ + } + + return values2 (res0, res1); +} +#endif /* HAVE_BIGFLOAT */ + +static Lisp_Object +round_two_float (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + double f1 = extract_float (number); + double f2 = extract_float (divisor); + double f0, remain; + + if (f2 == 0.0) + Fsignal (Qarith_error, Qnil); + + IN_FLOAT2 ((f0 = emacs_rint (f1 / f2)), MAYBE_EFF ("round"), number, + divisor); + IN_FLOAT2 (remain = f1 - (f0 * f2), MAYBE_EFF ("round"), number, divisor); + + if (return_float) + { + return values2 (make_float (f0), make_float (remain)); + } + else + { + return values2 (float_to_int (f0, MAYBE_EFF("round"), number, divisor), + make_float (remain)); + } +} + +static Lisp_Object +round_one_float (Lisp_Object number, int return_float) +{ + double d; + /* Screw the prevailing rounding mode. */ + IN_FLOAT ((d = emacs_rint (XFLOAT_DATA (number))), MAYBE_EFF ("round"), + number); + + if (return_float) + { + return values2 (make_float (d), make_float (XFLOAT_DATA (number) - d)); + } + else + { + return values2 ((float_to_int (d, MAYBE_EFF ("round"), number, + Qunbound)), + make_float (XFLOAT_DATA (number) - d)); + } +} + +EXFUN (Fround, 2); +EXFUN (Ffround, 2); + +static Lisp_Object +round_one_mundane_arg (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ #ifdef HAVE_BIGNUM if (INTEGERP (number)) #else if (INTP (number)) #endif - return number; - -#ifdef HAVE_RATIO - if (RATIOP (number)) { - if (bignum_divisible_p (XRATIO_NUMERATOR (number), - XRATIO_DENOMINATOR (number))) + if (return_float) { - bignum_div (scratch_bignum, XRATIO_NUMERATOR (number), - XRATIO_DENOMINATOR (number)); + return values2 (make_float (extract_float (number)), Qzero); } else { - bignum_add (scratch_bignum2, XRATIO_NUMERATOR (number), - XRATIO_DENOMINATOR (number)); - bignum_div (scratch_bignum, scratch_bignum2, - XRATIO_DENOMINATOR (number)); + return values2 (number, Qzero); } - return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); } + + MAYBE_CHAR_OR_MARKER (round); + + if (return_float) + { + return Ffround (wrong_type_argument (Qnumberp, number), divisor); + } + else + { + return Fround (wrong_type_argument (Qnumberp, number), divisor); + } +} + +static Lisp_Object +truncate_two_fixnum (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + EMACS_INT i1 = XREALINT (number); + EMACS_INT i2 = XREALINT (divisor); + EMACS_INT i0; + + if (i2 == 0) + Fsignal (Qarith_error, Qnil); + + /* We're truncating towards zero, so apart from avoiding the C89 + implementation-defined behaviour with truncation and negative numbers, + we don't need to do anything further: */ + i0 = (i2 < 0 + ? (i1 <= 0 ? -i1 / -i2 : -(i1 / -i2)) + : (i1 < 0 ? -(-i1 / i2) : i1 / i2)); + + if (return_float) + { + return values2 (make_float ((double)i0), make_int (i1 - (i0 * i2))); + } + else + { + return values2 (make_int (i0), make_int (i1 - (i0 * i2))); + } +} + +#ifdef HAVE_BIGNUM +static Lisp_Object +truncate_two_bignum (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + Lisp_Object res0; + + if (bignum_sign (XBIGNUM_DATA (divisor)) == 0) + { + Fsignal (Qarith_error, Qnil); + } + + bignum_div (scratch_bignum, XBIGNUM_DATA (number), + XBIGNUM_DATA (divisor)); + + if (return_float) + { + res0 = make_float (bignum_to_double (scratch_bignum)); + } + else + { + res0 = make_bignum_bg (scratch_bignum); + } + + if (bignum_divisible_p (XBIGNUM_DATA (number), + XBIGNUM_DATA (divisor))) + { + return values2 (Fcanonicalize_number (res0), Qzero); + } + + bignum_mul (scratch_bignum2, scratch_bignum, XBIGNUM_DATA (divisor)); + bignum_sub (scratch_bignum, XBIGNUM_DATA (number), scratch_bignum2); + + return values2 (Fcanonicalize_number (res0), + Fcanonicalize_number (make_bignum_bg (scratch_bignum))); +} +#endif /* HAVE_BIGNUM */ + +#ifdef HAVE_RATIO +static Lisp_Object +truncate_two_ratio (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + Lisp_Object res0; + + if (ratio_sign (XRATIO_DATA (divisor)) == 0) + { + Fsignal (Qarith_error, Qnil); + } + + ratio_div (scratch_ratio, XRATIO_DATA (number), XRATIO_DATA (divisor)); + + bignum_div (scratch_bignum, ratio_numerator (scratch_ratio), + ratio_denominator (scratch_ratio)); + + if (return_float) + { + res0 = make_float (bignum_to_double (scratch_bignum)); + } + else + { + res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + } + + if (bignum_divisible_p (ratio_numerator (scratch_ratio), + ratio_denominator (scratch_ratio))) + { + return values2 (res0, Qzero); + } + + ratio_set_bignum (scratch_ratio2, scratch_bignum); + ratio_mul (scratch_ratio, scratch_ratio2, XRATIO_DATA (divisor)); + ratio_sub (scratch_ratio2, XRATIO_DATA (number), scratch_ratio); + + return values2 (res0, Fcanonicalize_number (make_ratio_rt(scratch_ratio2))); +} #endif #ifdef HAVE_BIGFLOAT - if (BIGFLOATP (number)) +static Lisp_Object +truncate_two_bigfloat (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + Lisp_Object res0; + unsigned long prec = max (XBIGFLOAT_GET_PREC (number), + XBIGFLOAT_GET_PREC (divisor)); + + if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0) { - unsigned long prec = XBIGFLOAT_GET_PREC (number); - bigfloat_set_prec (scratch_bigfloat, prec); - bigfloat_set_prec (scratch_bigfloat2, prec); - bigfloat_set_double (scratch_bigfloat2, - bigfloat_sign (XBIGFLOAT_DATA (number)) * 0.5); - bigfloat_floor (scratch_bigfloat, scratch_bigfloat2); + Fsignal (Qarith_error, Qnil); + } + + bigfloat_set_prec (scratch_bigfloat, prec); + bigfloat_set_prec (scratch_bigfloat2, prec); + + bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (number), + XBIGFLOAT_DATA (divisor)); + bigfloat_trunc (scratch_bigfloat, scratch_bigfloat); + + if (return_float) + { + res0 = make_bigfloat_bf (scratch_bigfloat); + } + else + { #ifdef HAVE_BIGNUM bignum_set_bigfloat (scratch_bignum, scratch_bigfloat); - return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); #else - return make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat)); + res0 = make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat)); #endif /* HAVE_BIGNUM */ } + + bigfloat_mul (scratch_bigfloat2, scratch_bigfloat, XBIGFLOAT_DATA (divisor)); + bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (number), scratch_bigfloat2); + + return values2 (res0, make_bigfloat_bf (scratch_bigfloat)); +} #endif /* HAVE_BIGFLOAT */ - return Fround (wrong_type_argument (Qnumberp, number)); +#ifdef HAVE_RATIO +static Lisp_Object +truncate_one_ratio (Lisp_Object number, Lisp_Object UNUSED (divisor), + int return_float) +{ + Lisp_Object res0; + + if (ratio_sign (XRATIO_DATA (number)) == 0) + { + Fsignal (Qarith_error, Qnil); + } + + bignum_div (scratch_bignum, XRATIO_NUMERATOR (number), + XRATIO_DENOMINATOR (number)); + if (return_float) + { + res0 = make_float (bignum_to_double (scratch_bignum)); + } + else + { + res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + } + + if (bignum_divisible_p (XRATIO_NUMERATOR (number), + XRATIO_DENOMINATOR (number))) + { + return values2 (res0, Qzero); + } + + ratio_set_bignum (scratch_ratio2, scratch_bignum); + ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio2); + + return values2 (res0, Fcanonicalize_number (make_ratio_rt (scratch_ratio))); +} +#endif /* HAVE_RATIO */ + +#ifdef HAVE_BIGFLOAT +static Lisp_Object +truncate_one_bigfloat (Lisp_Object number, Lisp_Object UNUSED (divisor), + int return_float) +{ + Lisp_Object res0; + + bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number)); + bigfloat_set_prec (scratch_bigfloat2, XBIGFLOAT_GET_PREC (number)); + bigfloat_trunc (scratch_bigfloat, XBIGFLOAT_DATA (number)); + + if (return_float) + { + res0 = make_bigfloat_bf (scratch_bigfloat); + } + else + { +#ifdef HAVE_BIGNUM + bignum_set_bigfloat (scratch_bignum, scratch_bigfloat); + res0 = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); +#else + res0 = make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat)); +#endif /* HAVE_BIGNUM */ + } + + bigfloat_sub (scratch_bigfloat2, XBIGFLOAT_DATA (number), scratch_bigfloat); + + return + values2 (res0, + Fcanonicalize_number (make_bigfloat_bf (scratch_bigfloat2))); +} +#endif /* HAVE_BIGFLOAT */ + +static Lisp_Object +truncate_two_float (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ + double f1 = extract_float (number); + double f2 = extract_float (divisor); + double f0, remain; + Lisp_Object res0; + + if (f2 == 0.0) + { + Fsignal (Qarith_error, Qnil); + } + + res0 = float_to_int (f1 / f2, MAYBE_EFF ("truncate"), number, Qunbound); + f0 = extract_float (res0); + + IN_FLOAT2 (remain = f1 - (f0 * f2), MAYBE_EFF ("truncate"), number, divisor); + + if (return_float) + { + res0 = make_float (f0); + } + + return values2 (res0, make_float (remain)); } -DEFUN ("truncate", Ftruncate, 1, 1, 0, /* -Truncate a floating point number to an integer. -Rounds the value toward zero. -*/ - (number)) +static Lisp_Object +truncate_one_float (Lisp_Object number, int return_float) { - if (FLOATP (number)) - return float_to_int (XFLOAT_DATA (number), "truncate", number, Qunbound); + Lisp_Object res0 + = float_to_int (XFLOAT_DATA (number), MAYBE_EFF ("truncate"), + number, Qunbound); + if (return_float) + { + res0 = make_float ((double)XINT(res0)); + return values2 (res0, make_float ((XFLOAT_DATA (number) + - XFLOAT_DATA (res0)))); + } + else + { + return values2 (res0, make_float (XFLOAT_DATA (number) + - XREALINT (res0))); + } +} +EXFUN (Fftruncate, 2); + +static Lisp_Object +truncate_one_mundane_arg (Lisp_Object number, Lisp_Object divisor, + int return_float) +{ #ifdef HAVE_BIGNUM if (INTEGERP (number)) #else if (INTP (number)) #endif - return number; + { + if (return_float) + { + return values2 (make_float (extract_float (number)), Qzero); + } + else + { + return values2 (number, Qzero); + } + } -#ifdef HAVE_RATIO - if (RATIOP (number)) + MAYBE_CHAR_OR_MARKER (truncate); + + if (return_float) { - bignum_div (scratch_bignum, XRATIO_NUMERATOR (number), - XRATIO_DENOMINATOR (number)); - return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + return Fftruncate (wrong_type_argument (Qnumberp, number), divisor); } -#endif + else + { + return Ftruncate (wrong_type_argument (Qnumberp, number), divisor); + } +} + +/* Rounding functions that will not necessarily return floats: */ -#ifdef HAVE_BIGFLOAT - if (BIGFLOATP (number)) - { - bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number)); - bigfloat_trunc (scratch_bigfloat, XBIGFLOAT_DATA (number)); -#ifdef HAVE_BIGNUM - bignum_set_bigfloat (scratch_bignum, scratch_bigfloat); - return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); -#else - return make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat)); -#endif /* HAVE_BIGNUM */ - } -#endif /* HAVE_BIGFLOAT */ +DEFUN ("ceiling", Fceiling, 1, 2, 0, /* +Return the smallest integer no less than NUMBER. (Round toward +inf.) - return Ftruncate (wrong_type_argument (Qnumberp, number)); +With optional argument DIVISOR, return the smallest integer no less than +the quotient of NUMBER and DIVISOR. + +This function returns multiple values; see `multiple-value-bind' and +`multiple-value-call'. The second returned value is the remainder in the +calculation, which will be one minus the fractional part of NUMBER if DIVISOR +is omitted or one. +*/ + (number, divisor)) +{ + ROUNDING_CONVERT(ceiling, 0); +} + +DEFUN ("floor", Ffloor, 1, 2, 0, /* +Return the largest integer no greater than NUMBER. (Round towards -inf.) +With optional second argument DIVISOR, return the largest integer no +greater than the quotient of NUMBER and DIVISOR. + +This function returns multiple values; see `multiple-value-call' and +`multiple-value-bind'. The second returned value is the remainder in the +calculation, which will just be the fractional part if DIVISOR is omitted or +one. +*/ + (number, divisor)) +{ + ROUNDING_CONVERT(floor, 0); +} + +DEFUN ("round", Fround, 1, 2, 0, /* +Return the nearest integer to NUMBER. +If NUMBER is exactly halfway between two integers, return the one that +is even. + +Optional argument DIVISOR means return the nearest integer to NUMBER +divided by DIVISOR. + +This function returns multiple values; see `multiple-value-call' and +`multiple-value-bind'. The second returned value is the remainder +in the calculation. +*/ + (number, divisor)) +{ + ROUNDING_CONVERT(round, 0); +} + +DEFUN ("truncate", Ftruncate, 1, 2, 0, /* +Truncate a floating point number to an integer. +Rounds the value toward zero. + +Optional argument DIVISOR means truncate NUMBER divided by DIVISOR. + +This function returns multiple values; see `multiple-value-call' and +`multiple-value-bind'. The second returned value is the remainder. +*/ + (number, divisor)) +{ + ROUNDING_CONVERT(truncate, 0); } /* Float-rounding functions. */ -DEFUN ("fceiling", Ffceiling, 1, 1, 0, /* +DEFUN ("fceiling", Ffceiling, 1, 2, 0, /* Return the smallest integer no less than NUMBER, as a float. $Round toward +inf.$ + +With optional argument DIVISOR, return the smallest integer no less than the +quotient of NUMBER and DIVISOR, as a float. + +This function returns multiple values; the second value is the remainder in +the calculation. */ - (number)) + (number, divisor)) { - double d = extract_float (number); - IN_FLOAT (d = ceil (d), "fceiling", number); - return make_float (d); + ROUNDING_CONVERT(ceiling, 1); } -DEFUN ("ffloor", Fffloor, 1, 1, 0, /* +DEFUN ("ffloor", Fffloor, 1, 2, 0, /* Return the largest integer no greater than NUMBER, as a float. $Round towards -inf.$ + +With optional argument DIVISOR, return the largest integer no greater than +the quotient of NUMBER and DIVISOR, as a float. + +This function returns multiple values; the second value is the remainder in +the calculation. */ - (number)) + (number, divisor)) { - double d = extract_float (number); - IN_FLOAT (d = floor (d), "ffloor", number); - return make_float (d); + ROUNDING_CONVERT(floor, 1); } -DEFUN ("fround", Ffround, 1, 1, 0, /* +DEFUN ("fround", Ffround, 1, 2, 0, /* Return the nearest integer to NUMBER, as a float. +If NUMBER is exactly halfway between two integers, return the one that is +even. + +With optional argument DIVISOR, return the nearest integer to the quotient +of NUMBER and DIVISOR, as a float. + +This function returns multiple values; the second value is the remainder in +the calculation. */ - (number)) + (number, divisor)) { - double d = extract_float (number); - IN_FLOAT (d = emacs_rint (d), "fround", number); - return make_float (d); + ROUNDING_CONVERT(round, 1); } -DEFUN ("ftruncate", Fftruncate, 1, 1, 0, /* +DEFUN ("ftruncate", Fftruncate, 1, 2, 0, /* Truncate a floating point number to an integral float value. Rounds the value toward zero. + +With optional argument DIVISOR, truncate the quotient of NUMBER and DIVISOR, +to an integral float value. + +This function returns multiple values; the second value is the remainder in +the calculation. */ - (number)) + (number, divisor)) { - double d = extract_float (number); - if (d >= 0.0) - IN_FLOAT (d = floor (d), "ftruncate", number); - else - IN_FLOAT (d = ceil (d), "ftruncate", number); - return make_float (d); + ROUNDING_CONVERT(truncate, 1); } #ifdef FLOAT_CATCH_SIGILL diff -r e9880ed9d812 -r c2270b7d8c9a src/lisp.h --- a/src/lisp.h Tue Aug 11 17:31:43 2009 +0100 +++ b/src/lisp.h Tue Aug 11 17:59:23 2009 +0100 ＠＠ -4705,7 +4705,7 ＠＠ void unlock_buffer (struct buffer *); /* Defined in floatfns.c */ -EXFUN (Ftruncate, 1); +EXFUN (Ftruncate, 2); double extract_float (Lisp_Object); diff -r e9880ed9d812 -r c2270b7d8c9a src/number.c --- a/src/number.c Tue Aug 11 17:31:43 2009 +0100 +++ b/src/number.c Tue Aug 11 17:59:23 2009 +0100 ＠＠ -41,7 +41,7 ＠＠ bignum scratch_bignum, scratch_bignum2; #endif #ifdef HAVE_RATIO -ratio scratch_ratio; +ratio scratch_ratio, scratch_ratio2; #endif #ifdef HAVE_BIGFLOAT bigfloat scratch_bigfloat, scratch_bigfloat2; ＠＠ -561,7 +561,7 ＠＠ switch (type) { case FIXNUM_T: - return Ftruncate (number); + return Ftruncate (number, Qnil); case BIGNUM_T: #ifdef HAVE_BIGNUM bignum_set_double (scratch_bignum, XFLOAT_DATA (number)); ＠＠ -853,6 +853,7 ＠＠ #ifdef HAVE_RATIO ratio_init (scratch_ratio); + ratio_init (scratch_ratio2); #endif #ifdef HAVE_BIGFLOAT diff -r e9880ed9d812 -r c2270b7d8c9a src/number.h --- a/src/number.h Tue Aug 11 17:31:43 2009 +0100 +++ b/src/number.h Tue Aug 11 17:59:23 2009 +0100 ＠＠ -195,7 +195,7 ＠＠ extern Lisp_Object make_ratio (long, unsigned long); extern Lisp_Object make_ratio_bg (bignum, bignum); extern Lisp_Object make_ratio_rt (ratio); -extern ratio scratch_ratio; +extern ratio scratch_ratio, scratch_ratio2; #else /* !HAVE_RATIO */ ＠＠ -251,16 +251,16 ＠＠ #define XBIGFLOAT_GET_PREC(x) bigfloat_get_prec (XBIGFLOAT_DATA (x)) #define XBIGFLOAT_SET_PREC(x,p) bigfloat_set_prec (XBIGFLOAT_DATA (x), p) -#define BIGFLOAT_ARITH_RETURN(f,op) do \ -{ \ - Lisp_Object retval = make_bigfloat_bf (f); \ +#define BIGFLOAT_ARITH_RETURN(f,op) do \ +{ \ + Lisp_Object retval = make_bigfloat (0.0, bigfloat_get_default_prec()); \ bigfloat_##op (XBIGFLOAT_DATA (retval), XBIGFLOAT_DATA (f)); \ return retval; \ } while (0) #define BIGFLOAT_ARITH_RETURN1(f,op,arg) do \ { \ - Lisp_Object retval = make_bigfloat_bf (f); \ + Lisp_Object retval = make_bigfloat (0.0, bigfloat_get_default_prec()); \ bigfloat_##op (XBIGFLOAT_DATA (retval), XBIGFLOAT_DATA (f), arg); \ return retval; \ } while (0) diff -r e9880ed9d812 -r c2270b7d8c9a tests/ChangeLog --- a/tests/ChangeLog Tue Aug 11 17:31:43 2009 +0100 +++ b/tests/ChangeLog Tue Aug 11 17:59:23 2009 +0100 ＠＠ -1,3 +1,11 ＠＠ +2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net> + + * automated/lisp-tests.el: + Test the new Common Lisp-compatible rounding functions available in + C. + (generate-rounding-output): Provide a function useful for + generating the data for the rounding functions tests. + 2009-08-10 Aidan Kehoe <kehoea(a)parhasard.net> * automated/mule-tests.el: diff -r e9880ed9d812 -r c2270b7d8c9a tests/automated/lisp-tests.el --- a/tests/automated/lisp-tests.el Tue Aug 11 17:31:43 2009 +0100 +++ b/tests/automated/lisp-tests.el Tue Aug 11 17:59:23 2009 +0100 ＠＠ -1368,5 +1368,574 ＠＠ (load test-file-name nil t nil) (delete-file test-file-name)) +(flet ((cl-floor (x &optional y) + (let ((q (floor x y))) + (list q (- x (if y (* y q) q))))) + (cl-ceiling (x &optional y) + (let ((res (cl-floor x y))) + (if (= (car (cdr res)) 0) res + (list (1+ (car res)) (- (car (cdr res)) (or y 1)))))) + (cl-truncate (x &optional y) + (if (eq (>= x 0) (or (null y) (>= y 0))) + (cl-floor x y) (cl-ceiling x y))) + (cl-round (x &optional y) + (if y + (if (and (integerp x) (integerp y)) + (let* ((hy (/ y 2)) + (res (cl-floor (+ x hy) y))) + (if (and (= (car (cdr res)) 0) + (= (+ hy hy) y) + (/= (% (car res) 2) 0)) + (list (1- (car res)) hy) + (list (car res) (- (car (cdr res)) hy)))) + (let ((q (round (/ x y)))) + (list q (- x (* q y))))) + (if (integerp x) (list x 0) + (let ((q (round x))) + (list q (- x q)))))) + (Assert-rounding (first second &key + one-floor-result two-floor-result + one-ffloor-result two-ffloor-result + one-ceiling-result two-ceiling-result + one-fceiling-result two-fceiling-result + one-round-result two-round-result + one-fround-result two-fround-result + one-truncate-result two-truncate-result + one-ftruncate-result two-ftruncate-result) + (Assert (equal one-floor-result (multiple-value-list + (floor first))) + (format "checking (floor %S) gives %S" + first one-floor-result)) + (Assert (equal one-floor-result (multiple-value-list + (floor first 1))) + (format "checking (floor %S 1) gives %S" + first one-floor-result)) + (Check-Error arith-error (floor first 0)) + (Check-Error arith-error (floor first 0.0)) + (Assert (equal two-floor-result (multiple-value-list + (floor first second))) + (format + "checking (floor %S %S) gives %S" + first second two-floor-result)) + (Assert (equal (cl-floor first second) + (multiple-value-list (floor first second))) + (format + "checking (floor %S %S) gives the same as the old code" + first second)) + (Assert (equal one-ffloor-result (multiple-value-list + (ffloor first))) + (format "checking (ffloor %S) gives %S" + first one-ffloor-result)) + (Assert (equal one-ffloor-result (multiple-value-list + (ffloor first 1))) + (format "checking (ffloor %S 1) gives %S" + first one-ffloor-result)) + (Check-Error arith-error (ffloor first 0)) + (Check-Error arith-error (ffloor first 0.0)) + (Assert (equal two-ffloor-result (multiple-value-list + (ffloor first second))) + (format "checking (ffloor %S %S) gives %S" + first second two-ffloor-result)) + (Assert (equal one-ceiling-result (multiple-value-list + (ceiling first))) + (format "checking (ceiling %S) gives %S" + first one-ceiling-result)) + (Assert (equal one-ceiling-result (multiple-value-list + (ceiling first 1))) + (format "checking (ceiling %S 1) gives %S" + first one-ceiling-result)) + (Check-Error arith-error (ceiling first 0)) + (Check-Error arith-error (ceiling first 0.0)) + (Assert (equal two-ceiling-result (multiple-value-list + (ceiling first second))) + (format "checking (ceiling %S %S) gives %S" + first second two-ceiling-result)) + (Assert (equal (cl-ceiling first second) + (multiple-value-list (ceiling first second))) + (format + "checking (ceiling %S %S) gives the same as the old code" + first second)) + (Assert (equal one-fceiling-result (multiple-value-list + (fceiling first))) + (format "checking (fceiling %S) gives %S" + first one-fceiling-result)) + (Assert (equal one-fceiling-result (multiple-value-list + (fceiling first 1))) + (format "checking (fceiling %S 1) gives %S" + first one-fceiling-result)) + (Check-Error arith-error (fceiling first 0)) + (Check-Error arith-error (fceiling first 0.0)) + (Assert (equal two-fceiling-result (multiple-value-list + (fceiling first second))) + (format "checking (fceiling %S %S) gives %S" + first second two-fceiling-result)) + (Assert (equal one-round-result (multiple-value-list + (round first))) + (format "checking (round %S) gives %S" + first one-round-result)) + (Assert (equal one-round-result (multiple-value-list + (round first 1))) + (format "checking (round %S 1) gives %S, types %S, actual %S, types %S" + first one-round-result (mapcar #'type-of one-round-result) + (multiple-value-list (round first 1)) + (mapcar #'type-of (multiple-value-list (round first 1))))) + (Check-Error arith-error (round first 0)) + (Check-Error arith-error (round first 0.0)) + (Assert (equal two-round-result (multiple-value-list + (round first second))) + (format "checking (round %S %S) gives %S" + first second two-round-result)) + (Assert (equal one-fround-result (multiple-value-list + (fround first))) + (format "checking (fround %S) gives %S" + first one-fround-result)) + (Assert (equal one-fround-result (multiple-value-list + (fround first 1))) + (format "checking (fround %S 1) gives %S" + first one-fround-result)) + (Check-Error arith-error (fround first 0)) + (Check-Error arith-error (fround first 0.0)) + (Assert (equal two-fround-result (multiple-value-list + (fround first second))) + (format "checking (fround %S %S) gives %S" + first second two-fround-result)) + (Assert (equal (cl-round first second) + (multiple-value-list (round first second))) + (format + "checking (round %S %S) gives the same as the old code" + first second)) + (Assert (equal one-truncate-result (multiple-value-list + (truncate first))) + (format "checking (truncate %S) gives %S" + first one-truncate-result)) + (Assert (equal one-truncate-result (multiple-value-list + (truncate first 1))) + (format "checking (truncate %S 1) gives %S" + first one-truncate-result)) + (Check-Error arith-error (truncate first 0)) + (Check-Error arith-error (truncate first 0.0)) + (Assert (equal two-truncate-result (multiple-value-list + (truncate first second))) + (format "checking (truncate %S %S) gives %S" + first second two-truncate-result)) + (Assert (equal (cl-truncate first second) + (multiple-value-list (truncate first second))) + (format + "checking (truncate %S %S) gives the same as the old code" + first second)) + (Assert (equal one-ftruncate-result (multiple-value-list + (ftruncate first))) + (format "checking (ftruncate %S) gives %S" + first one-ftruncate-result)) + (Assert (equal one-ftruncate-result (multiple-value-list + (ftruncate first 1))) + (format "checking (ftruncate %S 1) gives %S" + first one-ftruncate-result)) + (Check-Error arith-error (ftruncate first 0)) + (Check-Error arith-error (ftruncate first 0.0)) + (Assert (equal two-ftruncate-result (multiple-value-list + (ftruncate first second))) + (format "checking (ftruncate %S %S) gives %S" + first second two-ftruncate-result))) + (Assert-rounding-floating (pie ee) + (let ((pie-type (type-of pie))) + (assert (eq pie-type (type-of ee)) t + "This code assumes the two arguments have the same type.") + (Assert-rounding pie ee +:one-floor-result (list 3 (- pie 3)) +:two-floor-result (list 1 (- pie (* 1 ee))) +:one-ffloor-result (list (coerce 3 pie-type) (- pie 3.0)) +:two-ffloor-result (list (coerce 1 pie-type) (- pie (* 1.0 ee))) +:one-ceiling-result (list 4 (- pie 4)) +:two-ceiling-result (list 2 (- pie (* 2 ee))) +:one-fceiling-result (list (coerce 4 pie-type) (- pie 4.0)) +:two-fceiling-result (list (coerce 2 pie-type) (- pie (* 2.0 ee))) +:one-round-result (list 3 (- pie 3)) +:two-round-result (list 1 (- pie (* 1 ee))) +:one-fround-result (list (coerce 3 pie-type) (- pie 3.0)) +:two-fround-result (list (coerce 1 pie-type) (- pie (* 1.0 ee))) +:one-truncate-result (list 3 (- pie 3)) +:two-truncate-result (list 1 (- pie (* 1 ee))) +:one-ftruncate-result (list (coerce 3 pie-type) (- pie 3.0)) +:two-ftruncate-result (list (coerce 1 pie-type) + (- pie (* 1.0 ee)))) + (Assert-rounding pie (- ee) +:one-floor-result (list 3 (- pie 3)) +:two-floor-result (list -2 (- pie (* -2 (- ee)))) +:one-ffloor-result (list (coerce 3 pie-type) (- pie 3.0)) +:two-ffloor-result (list (coerce -2 pie-type) + (- pie (* -2.0 (- ee)))) +:one-ceiling-result (list 4 (- pie 4)) +:two-ceiling-result (list -1 (- pie (* -1 (- ee)))) +:one-fceiling-result (list (coerce 4 pie-type) (- pie 4.0)) +:two-fceiling-result (list (coerce -1 pie-type) + (- pie (* -1.0 (- ee)))) +:one-round-result (list 3 (- pie 3)) +:two-round-result (list -1 (- pie (* -1 (- ee)))) +:one-fround-result (list (coerce 3 pie-type) (- pie 3.0)) +:two-fround-result (list (coerce -1 pie-type) + (- pie (* -1.0 (- ee)))) +:one-truncate-result (list 3 (- pie 3)) +:two-truncate-result (list -1 (- pie (* -1 (- ee)))) +:one-ftruncate-result (list (coerce 3 pie-type) (- pie 3.0)) +:two-ftruncate-result (list (coerce -1 pie-type) + (- pie (* -1.0 (- ee))))) + (Assert-rounding (- pie) ee +:one-floor-result (list -4 (- (- pie) -4)) +:two-floor-result (list -2 (- (- pie) (* -2 ee))) +:one-ffloor-result (list (coerce -4 pie-type) (- (- pie) -4.0)) +:two-ffloor-result (list (coerce -2 pie-type) + (- (- pie) (* -2.0 ee))) +:one-ceiling-result (list -3 (- (- pie) -3)) +:two-ceiling-result (list -1 (- (- pie) (* -1 ee))) +:one-fceiling-result (list (coerce -3 pie-type) (- (- pie) -3.0)) +:two-fceiling-result (list (coerce -1 pie-type) + (- (- pie) (* -1.0 ee))) +:one-round-result (list -3 (- (- pie) -3)) +:two-round-result (list -1 (- (- pie) (* -1 ee))) +:one-fround-result (list (coerce -3 pie-type) (- (- pie) -3.0)) +:two-fround-result (list (coerce -1 pie-type) + (- (- pie) (* -1.0 ee))) +:one-truncate-result (list -3 (- (- pie) -3)) +:two-truncate-result (list -1 (- (- pie) (* -1 ee))) +:one-ftruncate-result (list (coerce -3 pie-type) (- (- pie) -3.0)) +:two-ftruncate-result (list (coerce -1 pie-type) + (- (- pie) (* -1.0 ee)))) + (Assert-rounding (- pie) (- ee) +:one-floor-result (list -4 (- (- pie) -4)) +:two-floor-result (list 1 (- (- pie) (* 1 (- ee)))) +:one-ffloor-result (list (coerce -4 pie-type) (- (- pie) -4.0)) +:two-ffloor-result (list (coerce 1 pie-type) + (- (- pie) (* 1.0 (- ee)))) +:one-ceiling-result (list -3 (- (- pie) -3)) +:two-ceiling-result (list 2 (- (- pie) (* 2 (- ee)))) +:one-fceiling-result (list (coerce -3 pie-type) (- (- pie) -3.0)) +:two-fceiling-result (list (coerce 2 pie-type) + (- (- pie) (* 2.0 (- ee)))) +:one-round-result (list -3 (- (- pie) -3)) +:two-round-result (list 1 (- (- pie) (* 1 (- ee)))) +:one-fround-result (list (coerce -3 pie-type) (- (- pie) -3.0)) +:two-fround-result (list (coerce 1 pie-type) + (- (- pie) (* 1.0 (- ee)))) +:one-truncate-result (list -3 (- (- pie) -3)) +:two-truncate-result (list 1 (- (- pie) (* 1 (- ee)))) +:one-ftruncate-result (list (coerce -3 pie-type) (- (- pie) -3.0)) +:two-ftruncate-result (list (coerce 1 pie-type) + (- (- pie) (* 1.0 (- ee))))) + (Assert-rounding ee pie +:one-floor-result (list 2 (- ee 2)) +:two-floor-result (list 0 ee) +:one-ffloor-result (list (coerce 2 pie-type) (- ee 2.0)) +:two-ffloor-result (list (coerce 0 pie-type) ee) +:one-ceiling-result (list 3 (- ee 3)) +:two-ceiling-result (list 1 (- ee pie)) +:one-fceiling-result (list (coerce 3 pie-type) (- ee 3.0)) +:two-fceiling-result (list (coerce 1 pie-type) (- ee pie)) +:one-round-result (list 3 (- ee 3)) +:two-round-result (list 1 (- ee (* 1 pie))) +:one-fround-result (list (coerce 3 pie-type) (- ee 3.0)) +:two-fround-result (list (coerce 1 pie-type) (- ee (* 1.0 pie))) +:one-truncate-result (list 2 (- ee 2)) +:two-truncate-result (list 0 ee) +:one-ftruncate-result (list (coerce 2 pie-type) (- ee 2.0)) +:two-ftruncate-result (list (coerce 0 pie-type) ee)) + (Assert-rounding ee (- pie) +:one-floor-result (list 2 (- ee 2)) +:two-floor-result (list -1 (- ee (* -1 (- pie)))) +:one-ffloor-result (list (coerce 2 pie-type) (- ee 2.0)) +:two-ffloor-result (list (coerce -1 pie-type) + (- ee (* -1.0 (- pie)))) +:one-ceiling-result (list 3 (- ee 3)) +:two-ceiling-result (list 0 ee) +:one-fceiling-result (list (coerce 3 pie-type) (- ee 3.0)) +:two-fceiling-result (list (coerce 0 pie-type) ee) +:one-round-result (list 3 (- ee 3)) +:two-round-result (list -1 (- ee (* -1 (- pie)))) +:one-fround-result (list (coerce 3 pie-type) (- ee 3.0)) +:two-fround-result (list (coerce -1 pie-type) + (- ee (* -1.0 (- pie)))) +:one-truncate-result (list 2 (- ee 2)) +:two-truncate-result (list 0 ee) +:one-ftruncate-result (list (coerce 2 pie-type) (- ee 2.0)) +:two-ftruncate-result (list (coerce 0 pie-type) ee))))) + ;; First, two integers: + (Assert-rounding 27 8 :one-floor-result '(27 0) :two-floor-result '(3 3) +:one-ffloor-result '(27.0 0) :two-ffloor-result '(3.0 3) +:one-ceiling-result '(27 0) :two-ceiling-result '(4 -5) +:one-fceiling-result '(27.0 0) :two-fceiling-result '(4.0 -5) +:one-round-result '(27 0) :two-round-result '(3 3) +:one-fround-result '(27.0 0) :two-fround-result '(3.0 3) +:one-truncate-result '(27 0) :two-truncate-result '(3 3) +:one-ftruncate-result '(27.0 0) :two-ftruncate-result '(3.0 3)) + (Assert-rounding 27 -8 :one-floor-result '(27 0) :two-floor-result '(-4 -5) +:one-ffloor-result '(27.0 0) :two-ffloor-result '(-4.0 -5) +:one-ceiling-result '(27 0) :two-ceiling-result '(-3 3) +:one-fceiling-result '(27.0 0) :two-fceiling-result '(-3.0 3) +:one-round-result '(27 0) :two-round-result '(-3 3) +:one-fround-result '(27.0 0) :two-fround-result '(-3.0 3) +:one-truncate-result '(27 0) :two-truncate-result '(-3 3) +:one-ftruncate-result '(27.0 0) :two-ftruncate-result '(-3.0 3)) + (Assert-rounding -27 8 +:one-floor-result '(-27 0) :two-floor-result '(-4 5) +:one-ffloor-result '(-27.0 0) :two-ffloor-result '(-4.0 5) +:one-ceiling-result '(-27 0) :two-ceiling-result '(-3 -3) +:one-fceiling-result '(-27.0 0) :two-fceiling-result '(-3.0 -3) +:one-round-result '(-27 0) :two-round-result '(-3 -3) +:one-fround-result '(-27.0 0) :two-fround-result '(-3.0 -3) +:one-truncate-result '(-27 0) :two-truncate-result '(-3 -3) +:one-ftruncate-result '(-27.0 0) :two-ftruncate-result '(-3.0 -3)) + (Assert-rounding -27 -8 +:one-floor-result '(-27 0) :two-floor-result '(3 -3) +:one-ffloor-result '(-27.0 0) :two-ffloor-result '(3.0 -3) +:one-ceiling-result '(-27 0) :two-ceiling-result '(4 5) +:one-fceiling-result '(-27.0 0) :two-fceiling-result '(4.0 5) +:one-round-result '(-27 0) :two-round-result '(3 -3) +:one-fround-result '(-27.0 0) :two-fround-result '(3.0 -3) +:one-truncate-result '(-27 0) :two-truncate-result '(3 -3) +:one-ftruncate-result '(-27.0 0) :two-ftruncate-result '(3.0 -3)) + (Assert-rounding 8 27 +:one-floor-result '(8 0) :two-floor-result '(0 8) +:one-ffloor-result '(8.0 0) :two-ffloor-result '(0.0 8) +:one-ceiling-result '(8 0) :two-ceiling-result '(1 -19) +:one-fceiling-result '(8.0 0) :two-fceiling-result '(1.0 -19) +:one-round-result '(8 0) :two-round-result '(0 8) +:one-fround-result '(8.0 0) :two-fround-result '(0.0 8) +:one-truncate-result '(8 0) :two-truncate-result '(0 8) +:one-ftruncate-result '(8.0 0) :two-ftruncate-result '(0.0 8)) + (Assert-rounding 8 -27 +:one-floor-result '(8 0) :two-floor-result '(-1 -19) +:one-ffloor-result '(8.0 0) :two-ffloor-result '(-1.0 -19) +:one-ceiling-result '(8 0) :two-ceiling-result '(0 8) +:one-fceiling-result '(8.0 0) :two-fceiling-result '(0.0 8) +:one-round-result '(8 0) :two-round-result '(0 8) +:one-fround-result '(8.0 0) :two-fround-result '(0.0 8) +:one-truncate-result '(8 0) :two-truncate-result '(0 8) +:one-ftruncate-result '(8.0 0) :two-ftruncate-result '(0.0 8)) + (Assert-rounding -8 27 +:one-floor-result '(-8 0) :two-floor-result '(-1 19) +:one-ffloor-result '(-8.0 0) :two-ffloor-result '(-1.0 19) +:one-ceiling-result '(-8 0) :two-ceiling-result '(0 -8) +:one-fceiling-result '(-8.0 0) :two-fceiling-result '(0.0 -8) +:one-round-result '(-8 0) :two-round-result '(0 -8) +:one-fround-result '(-8.0 0) :two-fround-result '(0.0 -8) +:one-truncate-result '(-8 0) :two-truncate-result '(0 -8) +:one-ftruncate-result '(-8.0 0) :two-ftruncate-result '(0.0 -8)) + (Assert-rounding -8 -27 +:one-floor-result '(-8 0) :two-floor-result '(0 -8) +:one-ffloor-result '(-8.0 0) :two-ffloor-result '(0.0 -8) +:one-ceiling-result '(-8 0) :two-ceiling-result '(1 19) +:one-fceiling-result '(-8.0 0) :two-fceiling-result '(1.0 19) +:one-round-result '(-8 0) :two-round-result '(0 -8) +:one-fround-result '(-8.0 0) :two-fround-result '(0.0 -8) +:one-truncate-result '(-8 0) :two-truncate-result '(0 -8) +:one-ftruncate-result '(-8.0 0) :two-ftruncate-result '(0.0 -8)) + (Assert-rounding 32 4 +:one-floor-result '(32 0) :two-floor-result '(8 0) +:one-ffloor-result '(32.0 0) :two-ffloor-result '(8.0 0) +:one-ceiling-result '(32 0) :two-ceiling-result '(8 0) +:one-fceiling-result '(32.0 0) :two-fceiling-result '(8.0 0) +:one-round-result '(32 0) :two-round-result '(8 0) +:one-fround-result '(32.0 0) :two-fround-result '(8.0 0) +:one-truncate-result '(32 0) :two-truncate-result '(8 0) +:one-ftruncate-result '(32.0 0) :two-ftruncate-result '(8.0 0)) + (Assert-rounding 32 -4 +:one-floor-result '(32 0) :two-floor-result '(-8 0) +:one-ffloor-result '(32.0 0) :two-ffloor-result '(-8.0 0) +:one-ceiling-result '(32 0) :two-ceiling-result '(-8 0) +:one-fceiling-result '(32.0 0) :two-fceiling-result '(-8.0 0) +:one-round-result '(32 0) :two-round-result '(-8 0) +:one-fround-result '(32.0 0) :two-fround-result '(-8.0 0) +:one-truncate-result '(32 0) :two-truncate-result '(-8 0) +:one-ftruncate-result '(32.0 0) :two-ftruncate-result '(-8.0 0)) + (Assert-rounding 12 9 +:one-floor-result '(12 0) :two-floor-result '(1 3) +:one-ffloor-result '(12.0 0) :two-ffloor-result '(1.0 3) +:one-ceiling-result '(12 0) :two-ceiling-result '(2 -6) +:one-fceiling-result '(12.0 0) :two-fceiling-result '(2.0 -6) +:one-round-result '(12 0) :two-round-result '(1 3) +:one-fround-result '(12.0 0) :two-fround-result '(1.0 3) +:one-truncate-result '(12 0) :two-truncate-result '(1 3) +:one-ftruncate-result '(12.0 0) :two-ftruncate-result '(1.0 3)) + (Assert-rounding 10 4 +:one-floor-result '(10 0) :two-floor-result '(2 2) +:one-ffloor-result '(10.0 0) :two-ffloor-result '(2.0 2) +:one-ceiling-result '(10 0) :two-ceiling-result '(3 -2) +:one-fceiling-result '(10.0 0) :two-fceiling-result '(3.0 -2) +:one-round-result '(10 0) :two-round-result '(2 2) +:one-fround-result '(10.0 0) :two-fround-result '(2.0 2) +:one-truncate-result '(10 0) :two-truncate-result '(2 2) +:one-ftruncate-result '(10.0 0) :two-ftruncate-result '(2.0 2)) + (Assert-rounding 14 4 +:one-floor-result '(14 0) :two-floor-result '(3 2) +:one-ffloor-result '(14.0 0) :two-ffloor-result '(3.0 2) +:one-ceiling-result '(14 0) :two-ceiling-result '(4 -2) +:one-fceiling-result '(14.0 0) :two-fceiling-result '(4.0 -2) +:one-round-result '(14 0) :two-round-result '(4 -2) +:one-fround-result '(14.0 0) :two-fround-result '(4.0 -2) +:one-truncate-result '(14 0) :two-truncate-result '(3 2) +:one-ftruncate-result '(14.0 0) :two-ftruncate-result '(3.0 2)) + ;; Now, two floats: + (Assert-rounding-floating pi e) + (when (featurep 'bigfloat) + (Assert-rounding-floating (coerce pi 'bigfloat) (coerce e 'bigfloat))) + (when (featurep 'bignum) + (assert (not (evenp most-positive-fixnum)) t + "In the unlikely event that most-positive-fixnum is even, rewrite this.") + (Assert-rounding (1+ most-positive-fixnum) (* 2 most-positive-fixnum) +:one-floor-result `(,(1+ most-positive-fixnum) 0) +:two-floor-result `(0 ,(1+ most-positive-fixnum)) +:one-ffloor-result `(,(float (1+ most-positive-fixnum)) 0) +:two-ffloor-result `(0.0 ,(1+ most-positive-fixnum)) +:one-ceiling-result `(,(1+ most-positive-fixnum) 0) +:two-ceiling-result `(1 ,(1+ (- most-positive-fixnum))) +:one-fceiling-result `(,(float (1+ most-positive-fixnum)) 0) +:two-fceiling-result `(1.0 ,(1+ (- most-positive-fixnum))) +:one-round-result `(,(1+ most-positive-fixnum) 0) +:two-round-result `(1 ,(1+ (- most-positive-fixnum))) +:one-fround-result `(,(float (1+ most-positive-fixnum)) 0) +:two-fround-result `(1.0 ,(1+ (- most-positive-fixnum))) +:one-truncate-result `(,(1+ most-positive-fixnum) 0) +:two-truncate-result `(0 ,(1+ most-positive-fixnum)) +:one-ftruncate-result `(,(float (1+ most-positive-fixnum)) 0) +:two-ftruncate-result `(0.0 ,(1+ most-positive-fixnum))) + (Assert-rounding (1+ most-positive-fixnum) (- (* 2 most-positive-fixnum)) +:one-floor-result `(,(1+ most-positive-fixnum) 0) +:two-floor-result `(-1 ,(1+ (- most-positive-fixnum))) +:one-ffloor-result `(,(float (1+ most-positive-fixnum)) 0) +:two-ffloor-result `(-1.0 ,(1+ (- most-positive-fixnum))) +:one-ceiling-result `(,(1+ most-positive-fixnum) 0) +:two-ceiling-result `(0 ,(1+ most-positive-fixnum)) +:one-fceiling-result `(,(float (1+ most-positive-fixnum)) 0) +:two-fceiling-result `(0.0 ,(1+ most-positive-fixnum)) +:one-round-result `(,(1+ most-positive-fixnum) 0) +:two-round-result `(-1 ,(1+ (- most-positive-fixnum))) +:one-fround-result `(,(float (1+ most-positive-fixnum)) 0) +:two-fround-result `(-1.0 ,(1+ (- most-positive-fixnum))) +:one-truncate-result `(,(1+ most-positive-fixnum) 0) +:two-truncate-result `(0 ,(1+ most-positive-fixnum)) +:one-ftruncate-result `(,(float (1+ most-positive-fixnum)) 0) +:two-ftruncate-result `(0.0 ,(1+ most-positive-fixnum))) + (Assert-rounding (- (1+ most-positive-fixnum)) (* 2 most-positive-fixnum) +:one-floor-result `(,(- (1+ most-positive-fixnum)) 0) +:two-floor-result `(-1 ,(1- most-positive-fixnum)) +:one-ffloor-result `(,(float (- (1+ most-positive-fixnum))) 0) +:two-ffloor-result `(-1.0 ,(1- most-positive-fixnum)) +:one-ceiling-result `(,(- (1+ most-positive-fixnum)) 0) +:two-ceiling-result `(0 ,(- (1+ most-positive-fixnum))) +:one-fceiling-result `(,(float (- (1+ most-positive-fixnum))) 0) +:two-fceiling-result `(0.0 ,(- (1+ most-positive-fixnum))) +:one-round-result `(,(- (1+ most-positive-fixnum)) 0) +:two-round-result `(-1 ,(1- most-positive-fixnum)) +:one-fround-result `(,(float (- (1+ most-positive-fixnum))) 0) +:two-fround-result `(-1.0 ,(1- most-positive-fixnum)) +:one-truncate-result `(,(- (1+ most-positive-fixnum)) 0) +:two-truncate-result `(0 ,(- (1+ most-positive-fixnum))) +:one-ftruncate-result `(,(float (- (1+ most-positive-fixnum))) 0) +:two-ftruncate-result `(0.0 ,(- (1+ most-positive-fixnum)))) + ;; Test the handling of values with .5: + (Assert-rounding (1+ (* 2 most-positive-fixnum)) 2 +:one-floor-result `(,(1+ (* 2 most-positive-fixnum)) 0) +:two-floor-result `(,most-positive-fixnum 1) +:one-ffloor-result `(,(float (1+ (* 2 most-positive-fixnum))) 0) + ;; We can't just call #'float here; we must use code that converts a + ;; bignum with value most-positive-fixnum (the creation of which is + ;; not directly possible in Lisp) to a float, not code that converts + ;; the fixnum with value most-positive-fixnum to a float. The eval is + ;; to avoid compile-time optimisation that can break this. +:two-ffloor-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) 1) +:one-ceiling-result `(,(1+ (* 2 most-positive-fixnum)) 0) +:two-ceiling-result `(,(1+ most-positive-fixnum) -1) +:one-fceiling-result `(,(float (1+ (* 2 most-positive-fixnum))) 0) +:two-fceiling-result `(,(float (1+ most-positive-fixnum)) -1) +:one-round-result `(,(1+ (* 2 most-positive-fixnum)) 0) +:two-round-result `(,(1+ most-positive-fixnum) -1) +:one-fround-result `(,(float (1+ (* 2 most-positive-fixnum))) 0) +:two-fround-result `(,(float (1+ most-positive-fixnum)) -1) +:one-truncate-result `(,(1+ (* 2 most-positive-fixnum)) 0) +:two-truncate-result `(,most-positive-fixnum 1) +:one-ftruncate-result `(,(float (1+ (* 2 most-positive-fixnum))) 0) + ;; See the comment above on :two-ffloor-result: +:two-ftruncate-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) 1)) + (Assert-rounding (1+ (* 2 (1- most-positive-fixnum))) 2 +:one-floor-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0) +:two-floor-result `(,(1- most-positive-fixnum) 1) +:one-ffloor-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0) + ;; See commentary above on float conversions. +:two-ffloor-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0)) 1) +:one-ceiling-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0) +:two-ceiling-result `(,most-positive-fixnum -1) +:one-fceiling-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0) +:two-fceiling-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) -1) +:one-round-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0) +:two-round-result `(,(1- most-positive-fixnum) 1) +:one-fround-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0) +:two-fround-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0)) 1) +:one-truncate-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0) +:two-truncate-result `(,(1- most-positive-fixnum) 1) +:one-ftruncate-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0) + ;; See commentary above +:two-ftruncate-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0)) + 1))) + (when (featurep 'ratio) + (Assert-rounding (read "4/3") (read "8/7") +:one-floor-result '(1 1/3) :two-floor-result '(1 4/21) +:one-ffloor-result '(1.0 1/3) :two-ffloor-result '(1.0 4/21) +:one-ceiling-result '(2 -2/3) :two-ceiling-result '(2 -20/21) +:one-fceiling-result '(2.0 -2/3) :two-fceiling-result '(2.0 -20/21) +:one-round-result '(1 1/3) :two-round-result '(1 4/21) +:one-fround-result '(1.0 1/3) :two-fround-result '(1.0 4/21) +:one-truncate-result '(1 1/3) :two-truncate-result '(1 4/21) +:one-ftruncate-result '(1.0 1/3) :two-ftruncate-result '(1.0 4/21)) + (Assert-rounding (read "-4/3") (read "8/7") +:one-floor-result '(-2 2/3) :two-floor-result '(-2 20/21) +:one-ffloor-result '(-2.0 2/3) :two-ffloor-result '(-2.0 20/21) +:one-ceiling-result '(-1 -1/3) :two-ceiling-result '(-1 -4/21) +:one-fceiling-result '(-1.0 -1/3) :two-fceiling-result '(-1.0 -4/21) +:one-round-result '(-1 -1/3) :two-round-result '(-1 -4/21) +:one-fround-result '(-1.0 -1/3) :two-fround-result '(-1.0 -4/21) +:one-truncate-result '(-1 -1/3) :two-truncate-result '(-1 -4/21) +:one-ftruncate-result '(-1.0 -1/3) :two-ftruncate-result '(-1.0 -4/21)))) +;; Run this function in a Common Lisp with two arguments to get results that +;; we should compare against, above. Though note the dancing-around with the +;; bigfloats and bignums above, too; you can't necessarily just use the +;; output here. + +(defun generate-rounding-output (first second) + (let ((print-readably t)) + (princ first) + (princ " ") + (princ second) + (princ " :one-floor-result ") + (princ (list 'quote (multiple-value-list (floor first)))) + (princ " :two-floor-result ") + (princ (list 'quote (multiple-value-list (floor first second)))) + (princ " :one-ffloor-result ") + (princ (list 'quote (multiple-value-list (ffloor first)))) + (princ " :two-ffloor-result ") + (princ (list 'quote (multiple-value-list (ffloor first second)))) + (princ " :one-ceiling-result ") + (princ (list 'quote (multiple-value-list (ceiling first)))) + (princ " :two-ceiling-result ") + (princ (list 'quote (multiple-value-list (ceiling first second)))) + (princ " :one-fceiling-result ") + (princ (list 'quote (multiple-value-list (fceiling first)))) + (princ " :two-fceiling-result ") + (princ (list 'quote (multiple-value-list (fceiling first second)))) + (princ " :one-round-result ") + (princ (list 'quote (multiple-value-list (round first)))) + (princ " :two-round-result ") + (princ (list 'quote (multiple-value-list (round first second)))) + (princ " :one-fround-result ") + (princ (list 'quote (multiple-value-list (fround first)))) + (princ " :two-fround-result ") + (princ (list 'quote (multiple-value-list (fround first second)))) + (princ " :one-truncate-result ") + (princ (list 'quote (multiple-value-list (truncate first)))) + (princ " :two-truncate-result ") + (princ (list 'quote (multiple-value-list (truncate first second)))) + (princ " :one-ftruncate-result ") + (princ (list 'quote (multiple-value-list (ftruncate first)))) + (princ " :two-ftruncate-result ") + (princ (list 'quote (multiple-value-list (ftruncate first second)))))) -- ¿Dónde estará ahora mi sobrino Yoghurtu Nghe, que tuvo que huir precipitadamente de la aldea por culpa de la escasez de rinocerontes? _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches

1 participants
1 comments

[COMMIT] Support full Common Lisp multiple values in C. 15 years, 4 months

Aidan Kehoe

APPROVE COMMIT NOTE: This patch has been committed. SXEmacs, this doesn’t quite fit with your C indentation. The rest of it should work, though; do I need to fight with tla to get it in? Problem; while setf with (values ...) works, letf with same doesn’t. # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net> # Date 1250452549 -3600 # Node ID 8f1ee2d15784f584fc6518ec64f3cdef27f73dae # Parent e3feb329bda9831e5b3d4ca8e2dacc643cb15e28 Support full Common Lisp multiple values in C. lisp/ChangeLog 2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net> * bytecomp.el : Update this file to support full C-level multiple values. This involves: -- Four new bytecodes, and special compiler functions to compile multiple-value-call, multiple-value-list-internal, values, values-list, and, since it now needs to pass back multiple values and is a special form, throw. -- There's a new compiler variable, byte-compile-checks-on-load, which is a list of forms that are evaluated at the very start of a file, with an error thrown if any of them give nil. -- The header is now inserted *after* compilation, giving a chance for the compilation process to influence what those checks are. There is still a check done before compilation for non-ASCII characters, to try to turn off dynamic docstrings if appopriate, in `byte-compile-maybe-reset-coding'. Space is reserved for checks; comments describing the version of the byte compiler generating the file are inserted if space remains for them. * bytecomp.el (byte-compile-version): Update this, we're a newer version of the byte compiler. * byte-optimize.el (byte-optimize-funcall): Correct a comment. * bytecomp.el (byte-compile-lapcode): Discard the arg with byte-multiple-value-call. * bytecomp.el (byte-compile-checks-and-comments-space): New variable, describe how many octets to reserve for checks at the start of byte-compiled files. * cl-compat.el: Remove the fake multiple-value implementation. Have the functions that use it use the real multiple-value implementation instead. * cl-macs.el (cl-block-wrapper, cl-block-throw): Revise the byte-compile properties of these symbols to work now we've made throw into a special form; keep the byte-compile properties as anonymous lambdas, since we don't have docstrings for them. * cl-macs.el (multiple-value-bind, multiple-value-setq) (multiple-value-list, nth-value): Update these functions to work with the C support for multiple values. * cl-macs.el (values): Modify the setf handler for this to call #'multiple-value-list-internal appropriately. * cl-macs.el (cl-setf-do-store): If the store form is a cons, treat it specially as wrapping the store value. * cl.el (cl-block-wrapper): Make this an alias of #'and, not #'identity, since it needs to pass back multiple values. * cl.el (multiple-value-apply): We no longer support this, mark it obsolete. * lisp-mode.el (eval-interactive-verbose): Remove a useless space in the docstring. * lisp-mode.el (eval-interactive): Update this function and its docstring. It now passes back a list, basically wrapping any eval calls with multiple-value-list. This allows multiple values to be printed by default in *scratch*. * lisp-mode.el (prin1-list-as-multiple-values): New function, printing a list as multiple values in the manner of Bruno Haible's clisp, separating each entry with " ;\n". * lisp-mode.el (eval-last-sexp): Call #'prin1-list-as-multiple-values on the return value of #'eval-interactive. * lisp-mode.el (eval-defun): Call #'prin1-list-as-multiple-values on the return value of #'eval-interactive. * mouse.el (mouse-eval-sexp): Deal with lists corresponding to multiple values from #'eval-interactive. Call #'cl-prettyprint, which is always available, instead of sometimes calling #'pprint and sometimes falling back to prin1. * obsolete.el (obsolete-throw): New function, called from eval.c when #'funcall encounters an attempt to call #'throw (now a special form) as a function. Only needed for compatibility with 21.4 byte-code. man/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net> * cl.texi (Organization): Remove references to the obsolete multiple-value emulating code. src/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net> * bytecode.c (enum Opcode /* Byte codes */): Add four new bytecodes, to deal with multiple values. (POP_WITH_MULTIPLE_VALUES): New macro. (POP): Modify this macro to ignore multiple values. (DISCARD_PRESERVING_MULTIPLE_VALUES): New macro. (DISCARD): Modify this macro to ignore multiple values. (TOP_WITH_MULTIPLE_VALUES): New macro. (TOP_ADDRESS): New macro. (TOP): Modify this macro to ignore multiple values. (TOP_LVALUE): New macro. (Bcall): Ignore multiple values where appropriate. (Breturn): Pass back multiple values. (Bdup): Preserve multiple values. Use TOP_LVALUE with most bytecodes that assign anything to anything. (Bbind_multiple_value_limits, Bmultiple_value_call, Bmultiple_value_list_internal, Bthrow): Implement the new bytecodes. (Bgotoifnilelsepop, Bgotoifnonnilelsepop, BRgotoifnilelsepop, BRgotoifnonnilelsepop): Discard any multiple values. * callint.c (Fcall_interactively): Ignore multiple values when calling #'eval, in two places. * device-x.c (x_IO_error_handler): * macros.c (pop_kbd_macro_event): * eval.c (Fsignal): * eval.c (flagged_a_squirmer): Call throw_or_bomb_out, not Fthrow, now that the latter is a special form. * eval.c: Make Qthrow, Qobsolete_throw available as symbols. Provide multiple_value_current_limit, multiple-values-limit (the latter as specified by Common Lisp. * eval.c (For): Ignore multiple values when comparing with Qnil, but pass any multiple values back for the last arg. * eval.c (Fand): Ditto. * eval.c (Fif): Ignore multiple values when examining the result of the condition. * eval.c (Fcond): Ignore multiple values when comparing what the clauses give, but pass them back if a clause gave non-nil. * eval.c (Fprog2): Never pass back multiple values. * eval.c (FletX, Flet): Ignore multiple when evaluating what exactly symbols should be bound to. * eval.c (Fwhile): Ignore multiple values when evaluating the test. * eval.c (Fsetq, Fdefvar, Fdefconst): Ignore multiple values. * eval.c (Fthrow): Declare this as a special form; ignore multiple values for TAG, preserve them for VALUE. * eval.c (throw_or_bomb_out): Make this available to other files, now Fthrow is a special form. * eval.c (Feval): Ignore multiple values when calling a compiled function, a non-special-form subr, or a lambda expression. * eval.c (Ffuncall): If we attempt to call #'throw (now a special form) as a function, don't error, call #'obsolete-throw instead. * eval.c (make_multiple_value, multiple_value_aset) (multiple_value_aref, print_multiple_value, mark_multiple_value) (size_multiple_value): Implement the multiple_value type. Add a long comment describing our implementation. * eval.c (bind_multiple_value_limits): New function, used by the bytecode and by #'multiple-value-call, #'multiple-value-list-internal. * eval.c (multiple_value_call): New function, used by the bytecode and #'multiple-value-call. * eval.c (Fmultiple_value_call): New special form. * eval.c (multiple_value_list_internal): New function, used by the byte code and #'multiple-value-list-internal. * eval.c (Fmultiple_value_list_internal, Fmultiple_value_prog1): New special forms. * eval.c (Fvalues, Fvalues_list): New Lisp functions. * eval.c (values2): New function, for C code returning multiple values. * eval.c (syms_of_eval): Make our new Lisp functions and symbols available. * eval.c (multiple-values-limit): Make this available to Lisp. * event-msw.c (dde_eval_string): * event-stream.c (execute_help_form): * glade.c (connector): * glyphs-widget.c (glyph_instantiator_to_glyph): * glyphs.c (evaluate_xpm_color_symbols): * gui-x.c (wv_set_evalable_slot, button_item_to_widget_value): * gui.c (gui_item_value, gui_item_display_flush_left): * lread.c (check_if_suppressed): * menubar-gtk.c (menu_convert, menu_descriptor_to_widget_1): * menubar-msw.c (populate_menu_add_item): * print.c (Fwith_output_to_temp_buffer): * symbols.c (Fsetq_default): Ignore multiple values when calling Feval. * symeval.h: Add the header declarations necessary for the multiple-values implementation. * inline.c: #include symeval.h, now that it has some inline functions. * lisp.h: Update Fthrow's declaration. Make throw_or_bomb_out available to all files. * lrecord.h (enum lrecord_type): Add the multiple_value type here. diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/ChangeLog --- a/lisp/ChangeLog Sun Aug 16 14:58:57 2009 +0100 +++ b/lisp/ChangeLog Sun Aug 16 20:55:49 2009 +0100 ＠＠ -10,6 +10,83 ＠＠ Use buffer (format " *Minibuf-%d*" (minibuffer-depth)), regardless of depth. +2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net> + + * bytecomp.el : + Update this file to support full C-level multiple values. This + involves: + -- Four new bytecodes, and special compiler functions to compile + multiple-value-call, multiple-value-list-internal, values, + values-list, and, since it now needs to pass back multiple values + and is a special form, throw. + -- There's a new compiler variable, byte-compile-checks-on-load, + which is a list of forms that are evaluated at the very start of a + file, with an error thrown if any of them give nil. + -- The header is now inserted *after* compilation, giving a chance + for the compilation process to influence what those checks + are. There is still a check done before compilation for non-ASCII + characters, to try to turn off dynamic docstrings if appopriate, + in `byte-compile-maybe-reset-coding'. + Space is reserved for checks; comments describing the version of + the byte compiler generating the file are inserted if space + remains for them. + * bytecomp.el (byte-compile-version): + Update this, we're a newer version of the byte compiler. + * byte-optimize.el (byte-optimize-funcall): + Correct a comment. + * bytecomp.el (byte-compile-lapcode): + Discard the arg with byte-multiple-value-call. + * bytecomp.el (byte-compile-checks-and-comments-space): + New variable, describe how many octets to reserve for checks at + the start of byte-compiled files. + * cl-compat.el: + Remove the fake multiple-value implementation. Have the functions + that use it use the real multiple-value implementation instead. + * cl-macs.el (cl-block-wrapper, cl-block-throw): + Revise the byte-compile properties of these symbols to work now + we've made throw into a special form; keep the byte-compile + properties as anonymous lambdas, since we don't have docstrings + for them. + * cl-macs.el (multiple-value-bind, multiple-value-setq) + (multiple-value-list, nth-value): + Update these functions to work with the C support for multiple + values. + * cl-macs.el (values): + Modify the setf handler for this to call + #'multiple-value-list-internal appropriately. + * cl-macs.el (cl-setf-do-store): + If the store form is a cons, treat it specially as wrapping the + store value. + * cl.el (cl-block-wrapper): + Make this an alias of #'and, not #'identity, since it needs to + pass back multiple values. + * cl.el (multiple-value-apply): + We no longer support this, mark it obsolete. + * lisp-mode.el (eval-interactive-verbose): + Remove a useless space in the docstring. + * lisp-mode.el (eval-interactive): + Update this function and its docstring. It now passes back a list, + basically wrapping any eval calls with multiple-value-list. This + allows multiple values to be printed by default in *scratch*. + * lisp-mode.el (prin1-list-as-multiple-values): + New function, printing a list as multiple values in the manner of + Bruno Haible's clisp, separating each entry with " ;\n". + * lisp-mode.el (eval-last-sexp): + Call #'prin1-list-as-multiple-values on the return value of + #'eval-interactive. + * lisp-mode.el (eval-defun): + Call #'prin1-list-as-multiple-values on the return value of + #'eval-interactive. + * mouse.el (mouse-eval-sexp): + Deal with lists corresponding to multiple values from + #'eval-interactive. Call #'cl-prettyprint, which is always + available, instead of sometimes calling #'pprint and sometimes + falling back to prin1. + * obsolete.el (obsolete-throw): + New function, called from eval.c when #'funcall encounters an + attempt to call #'throw (now a special form) as a function. Only + needed for compatibility with 21.4 byte-code. + 2009-08-10 Aidan Kehoe <kehoea(a)parhasard.net> * help.el (function-arglist, function-documentation): diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/byte-optimize.el --- a/lisp/byte-optimize.el Sun Aug 16 14:58:57 2009 +0100 +++ b/lisp/byte-optimize.el Sun Aug 16 20:55:49 2009 +0100 ＠＠ -1093,7 +1093,7 ＠＠ (put 'nlistp 'byte-optimizer 'byte-compile-negation-optimizer) (defun byte-optimize-funcall (form) - ;; (funcall '(lambda ...) ...) ==> ((lambda ...) ...) + ;; (funcall #'(lambda ...) ...) ==> ((lambda ...) ...) ;; (funcall 'foo ...) ==> (foo ...) (let ((fn (nth 1 form))) (if (memq (car-safe fn) '(quote function)) diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/bytecomp.el --- a/lisp/bytecomp.el Sun Aug 16 14:58:57 2009 +0100 +++ b/lisp/bytecomp.el Sun Aug 16 20:55:49 2009 +0100 ＠＠ -10,7 +10,7 ＠＠ ;; Richard Stallman <rms(a)gnu.org> ;; Keywords: internal lisp -(defconst byte-compile-version "2.27 XEmacs; 2000-09-12.") +(defconst byte-compile-version "2.28 XEmacs; 2009-08-09.") ;; This file is part of XEmacs. ＠＠ -215,7 +215,7 ＠＠ (load-library "bytecomp-runtime")) (eval-when-compile - (defvar byte-compile-single-version nil + (defvar byte-compile-single-version t "If this is true, the choice of emacs version (v19 or v20) byte-codes will be hard-coded into bytecomp when it compiles itself. If the compiler itself is compiled with optimization, this causes a speedup.") ＠＠ -304,6 +304,10 ＠＠ "This is completely ignored. It is only around for backwards compatibility.") +(defvar byte-compile-checks-on-load '((featurep 'xemacs)) + "A list of expressions to check when first loading a file. +Emacs will throw an error if any of them fail; checks will be made in +reverse order.") ;; FSF enables byte-compile-dynamic-docstrings but not byte-compile-dynamic ;; by default. This would be a reasonable conservative approach except ＠＠ -440,7 +444,7 ＠＠ on the specbind stack. The cdr of each cell is an integer bitmask.") (defvar byte-compile-force-escape-quoted nil - "If non-nil, `byte-compile-insert-header' always adds a coding cookie. + "If t, `byte-compile-maybe-reset-coding' always chooses `escape-quoted' This is for situations where the byte compiler output file needs to be able to encode character values above ?\\xFF, but this cannot be ＠＠ -733,7 +737,10 ＠＠ (byte-defop 176 nil byte-concatN) (byte-defop 177 nil byte-insertN) -;; unused: 178-181 +(byte-defop 178 1 byte-bind-multiple-value-limits) +(byte-defop 179 -3 byte-multiple-value-list-internal) +(byte-defop 180 0 byte-multiple-value-call) +(byte-defop 181 -1 byte-throw) ;; these ops are new to v20 (byte-defop 182 -1 byte-member) ＠＠ -833,6 +840,10 ＠＠ (<= (symbol-value op) byte-insertN)) (setq pc (+ 2 pc)) (cons off (cons (symbol-value op) bytes))) + ((= byte-multiple-value-call (symbol-value op)) + (setq pc (1+ pc)) + ;; Ignore off. + (cons (symbol-value op) bytes)) ((< off 6) (setq pc (1+ pc)) (cons (+ (symbol-value op) off) bytes)) ＠＠ -1386,6 +1397,8 ＠＠ (byte-optimize byte-optimize) (byte-compile-emacs19-compatibility byte-compile-emacs19-compatibility) + (byte-compile-checks-on-load + byte-compile-checks-on-load) (byte-compile-dynamic byte-compile-dynamic) (byte-compile-dynamic-docstrings byte-compile-dynamic-docstrings) ＠＠ -1718,9 +1731,7 ＠＠ ;; byte-compile-warning-types ;; byte-compile-warnings)) (byte-compile-force-escape-quoted byte-compile-force-escape-quoted) - (byte-compile-using-dynamic nil) - (byte-compile-using-escape-quoted nil) - ) + (byte-compile-using-dynamic nil)) (byte-compile-close-variables (save-excursion (setq byte-compile-outbuffer ＠＠ -1730,9 +1741,8 ＠＠ (setq case-fold-search nil) (and filename (not eval) - (byte-compile-insert-header filename - byte-compile-inbuffer - byte-compile-outbuffer)) + (byte-compile-maybe-reset-coding byte-compile-inbuffer + byte-compile-outbuffer)) (setq byte-compile-using-dynamic (or (symbol-value-in-buffer 'byte-compile-dynamic byte-compile-inbuffer) ＠＠ -1763,6 +1773,8 ＠＠ ;; Compile pending forms at end of file. (byte-compile-flush-pending) + (byte-compile-insert-header filename byte-compile-inbuffer + byte-compile-outbuffer) (byte-compile-warn-about-unresolved-functions) ;; Should we always do this? When calling multiple files, it ;; would be useful to delay this warning until all have ＠＠ -1797,11 +1809,16 ＠＠ (kill-buffer byte-compile-outbuffer) nil))) +(defvar byte-compile-checks-and-comments-space 475 + "Number of octets of space for checks and comments; used by the dynamic +docstrings code.") + (defun byte-compile-insert-header (filename byte-compile-inbuffer - byte-compile-outbuffer) + byte-compile-outbuffer) (set-buffer byte-compile-inbuffer) - (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) + (let (checks-string comments) (set-buffer byte-compile-outbuffer) + (delete-region 1 (1+ byte-compile-checks-and-comments-space)) (goto-char 1) ;; ;; The magic number of .elc files is ";ELC", or 0x3B454C43. After that is ＠＠ -1817,62 +1834,56 ＠＠ (insert ";ELC" (if (byte-compile-version-cond byte-compile-emacs19-compatibility) 19 20) - "\000\000\000\n" - ) - (insert ";;; compiled by " - (or (and (boundp 'user-mail-address) user-mail-address) - (concat (user-login-name) "＠" (system-name))) - " on " - (current-time-string) "\n;;; from file " filename "\n") - (insert ";;; emacs version " emacs-version ".\n") - (insert ";;; bytecomp version " byte-compile-version "\n;;; " - (cond - ((eq byte-optimize 'source) "source-level optimization only") - ((eq byte-optimize 'byte) "byte-level optimization only") - (byte-optimize "optimization is on") - (t "optimization is off")) - (if (byte-compile-version-cond byte-compile-emacs19-compatibility) - "; compiled with Emacs 19 compatibility.\n" - ".\n")) - (if (not (byte-compile-version-cond byte-compile-emacs19-compatibility)) - (insert ";;; this file uses opcodes which do not exist in Emacs 19.\n" - ;; Have to check if emacs-version is bound so that this works - ;; in files loaded early in loadup.el. - "\n(if (and (boundp 'emacs-version)\n" - "\t (or (and (boundp 'epoch::version) epoch::version)\n" - "\t (string-lessp emacs-version \"20\")))\n" - " (error \"`" - ;; prin1-to-string is used to quote backslashes. - (substring (prin1-to-string (file-name-nondirectory filename)) - 1 -1) - "' was compiled for Emacs 20\"))\n\n")) - (insert "(or (boundp 'current-load-list) (setq current-load-list nil))\n" - "\n") - (if (and (byte-compile-version-cond byte-compile-emacs19-compatibility) - dynamic-docstrings) - (insert ";;; this file uses opcodes which do not exist prior to\n" - ";;; XEmacs 19.14/GNU Emacs 19.29 or later." - ;; Have to check if emacs-version is bound so that this works - ;; in files loaded early in loadup.el. - "\n(if (and (boundp 'emacs-version)\n" - "\t (or (and (boundp 'epoch::version) epoch::version)\n" - "\t (and (not (string-match \"XEmacs\" emacs-version))\n" - "\t (string-lessp emacs-version \"19.29\"))\n" - "\t (string-lessp emacs-version \"19.14\")))\n" - " (error \"`" - ;; prin1-to-string is used to quote backslashes. - (substring (prin1-to-string (file-name-nondirectory filename)) - 1 -1) - "' was compiled for XEmacs 19.14/Emacs 19.29 or later\"))\n\n" - ) - )) - - ;; back in the inbuffer; determine and set the coding system for the .elc - ;; file if under Mule. If there are any extended characters in the - ;; input file, use `escape-quoted' to make sure that both binary and - ;; extended characters are output properly and distinguished properly. - ;; Otherwise, use `raw-text' for maximum portability with non-Mule - ;; Emacsen. + "\000\000\000\n") + (when (not (eq (find-coding-system 'raw-text-unix) + (find-coding-system buffer-file-coding-system))) + (insert (format ";;;###coding system: %s\n" + (coding-system-name buffer-file-coding-system)))) + (insert (format + "\n(or %s\n (error \"Loading this file requires: %s\"))\n" + (setq checks-string + (let ((print-readably t)) + (prin1-to-string (if (> (length + byte-compile-checks-on-load) + 1) + (cons 'and + (reverse + byte-compile-checks-on-load)) + (car byte-compile-checks-on-load))))) + checks-string)) + (setq comments + (with-string-as-buffer-contents "" + (insert "\n;;; compiled by " + (or (and (boundp 'user-mail-address) user-mail-address) + (concat (user-login-name) "＠" (system-name))) + " on " + (current-time-string) "\n;;; from file " filename "\n") + (insert ";;; emacs version " emacs-version ".\n") + (insert ";;; bytecomp version " byte-compile-version "\n;;; " + (cond + ((eq byte-optimize 'source) + "source-level optimization only") + ((eq byte-optimize 'byte) "byte-level optimization only") + (byte-optimize "optimization is on") + (t "optimization is off")) + "\n"))) + + ;; We won't trip this unless the byte-compiler changes, in which case + ;; it's just a matter of upping the space. + (assert (natnump (- (1+ byte-compile-checks-and-comments-space) (point))) + t "Not enough space for the feature checks!") + + (if (natnump (- (1+ byte-compile-checks-and-comments-space) + (+ (point) (length comments)))) + (insert comments)) + (insert-char ?\ (- (1+ byte-compile-checks-and-comments-space) + (point))))) + +(defun byte-compile-maybe-reset-coding (byte-compile-inbuffer + byte-compile-outbuffer) + ;; We also reserve some space for the feature checks: + (goto-char 1) + (insert-char ?\ byte-compile-checks-and-comments-space) (if (or (featurep '(not mule)) ;; Don't scan buffer if we are not muleized (and (not byte-compile-force-escape-quoted) ＠＠ -1885,7 +1896,8 ＠＠ ;; not true of ordinary comments. (let ((non-latin-1-re (concat "[^\000-\377]" - #r"\|\\u[0-9a-fA-F]\{4,4\}\|\\U[0-9a-fA-F]\{8,8\}")) + #r"\|\\u[0-9a-fA-F]\{4,4\}\|\\U[0-9a-fA-F]" + "\\{8,8\\}")) (case-fold-search nil)) (catch 'need-to-escape-quote (while (re-search-forward non-latin-1-re nil t) ＠＠ -1894,19 +1906,12 ＠＠ (forward-line 1)) t))))) (setq buffer-file-coding-system 'raw-text-unix) - (insert "(or (featurep 'mule) (error \"Loading this file requires Mule support\")) -;;;###coding system: escape-quoted\n") (setq buffer-file-coding-system 'escape-quoted) - ;; #### Lazy loading not yet implemented for MULE files - ;; mrb - Fix this someday. + (pushnew '(featurep 'mule) byte-compile-checks-on-load) (save-excursion (set-buffer byte-compile-inbuffer) (setq byte-compile-dynamic nil - byte-compile-dynamic-docstrings nil)) - ;;(external-debugging-output (prin1-to-string (buffer-local-variables)))) - ) - ) - + byte-compile-dynamic-docstrings nil)))) (defun byte-compile-output-file-form (form) ;; writes the given form to the output buffer, being careful of docstrings ＠＠ -3084,6 +3089,11 ＠＠ (byte-defop-compiler (% byte-rem) 2) (byte-defop-compiler aset 3) +(byte-defop-compiler-1 bind-multiple-value-limits) +(byte-defop-compiler multiple-value-list-internal) +(byte-defop-compiler-1 multiple-value-call) +(byte-defop-compiler throw) + (byte-defop-compiler-rmsfun member 2) (byte-defop-compiler-rmsfun assq 2) ＠＠ -3102,11 +3112,14 ＠＠ ;;(byte-defop-compiler (mod byte-rem) 2) -(defun byte-compile-subr-wrong-args (form n) +(defun byte-compile-warn-wrong-args (form n) (when (memq 'subr-callargs byte-compile-warnings) (byte-compile-warn "%s called with %d arg%s, but requires %s" (car form) (length (cdr form)) - (if (= 1 (length (cdr form))) "" "s") n)) + (if (= 1 (length (cdr form))) "" "s") n))) + +(defun byte-compile-subr-wrong-args (form n) + (byte-compile-warn-wrong-args form n) ;; get run-time wrong-number-of-args error. (byte-compile-normal-call form)) ＠＠ -3641,6 +3654,9 ＠＠ (byte-defop-compiler-1 inline byte-compile-progn) (byte-defop-compiler-1 progn) (byte-defop-compiler-1 prog1) +(byte-defop-compiler-1 multiple-value-prog1) +(byte-defop-compiler-1 values) +(byte-defop-compiler-1 values-list) (byte-defop-compiler-1 prog2) (byte-defop-compiler-1 if) (byte-defop-compiler-1 cond) ＠＠ -3660,13 +3676,36 ＠＠ (defun byte-compile-prog1 (form) (setq form (cdr form)) + ;; #'prog1 never returns multiple values: + (byte-compile-form-do-effect (list 'values (pop form))) + (byte-compile-body form t)) + +(defun byte-compile-multiple-value-prog1 (form) + (setq form (cdr form)) (byte-compile-form-do-effect (pop form)) (byte-compile-body form t)) +(defun byte-compile-values (form) + (if (and (= 2 (length form)) + (byte-compile-constp (second form))) + (byte-compile-form-do-effect (second form)) + (byte-compile-normal-call form))) + +(defun byte-compile-values-list (form) + (if (and (= 2 (length form)) + (or (null (second form)) + (and (consp (second form)) + (eq (car (second form)) + 'quote) + (not (symbolp (car-safe (cdr (second form)))))))) + (byte-compile-form-do-effect (car-safe (cdr (second form)))) + (byte-compile-normal-call form))) + (defun byte-compile-prog2 (form) (setq form (cdr form)) (byte-compile-form (pop form) t) - (byte-compile-form-do-effect (pop form)) + ;; #'prog2 never returns multiple values: + (byte-compile-form-do-effect (list 'values (pop form))) (byte-compile-body form t)) (defmacro byte-compile-goto-if (cond discard tag) ＠＠ -3952,6 +3991,65 ＠＠ (byte-compile-body (cdr (cdr form))) (byte-compile-out 'byte-temp-output-buffer-show 0)) +(defun byte-compile-multiple-value-call (form) + (if (< (length form) 2) + (progn + (byte-compile-warn-wrong-args form 1) + (byte-compile-normal-call + `(signal 'wrong-number-of-arguments '(,(car form) + ,(length (cdr form)))))) + (setq form (cdr form)) + (byte-compile-form (car form)) + (byte-compile-push-constant 0) + (byte-compile-variable-ref 'byte-varref 'multiple-values-limit) + ;; bind-multiple-value-limits leaves two existing values on the stack, + ;; and pushes a new value, the specpdl_depth() at the time it was + ;; called. + (byte-compile-out 'byte-bind-multiple-value-limits 0) + (mapcar 'byte-compile-form (cdr form)) + ;; Most of the other code puts this sort of value in the program stream, + ;; not pushing it on the stack. + (byte-compile-push-constant (+ 3 (length form))) + (byte-compile-out 'byte-multiple-value-call (+ 3 (length form))) + (pushnew '(subrp (symbol-function 'multiple-value-call)) + byte-compile-checks-on-load +:test #'equal))) + +(defun byte-compile-multiple-value-list-internal (form) + (if (/= 4 (length form)) + (progn + (byte-compile-warn-wrong-args form 3) + (byte-compile-normal-call + `(signal 'wrong-number-of-arguments '(,(car form) + ,(length (cdr form)))))) + (byte-compile-form (nth 1 form)) + (byte-compile-form (nth 2 form)) + (byte-compile-out 'byte-bind-multiple-value-limits 0) + (byte-compile-form (nth 3 form)) + (byte-compile-out (get (car form) 'byte-opcode) 0) + (pushnew '(subrp (symbol-function 'multiple-value-call)) + byte-compile-checks-on-load +:test #'equal))) + +(defun byte-compile-throw (form) + ;; We can't use byte-compile-two-args for throw because in the event that + ;; the form does not have two args, it tries to #'funcall it expecting a + ;; runtime wrong-number-of-arguments error. Now that #'throw is a special + ;; form, it provokes an invalid-function error instead (or at least it + ;; should; there's a kludge around for the moment in eval.c that avoids + ;; that, but this file should not assume that that will always be there). + (if (/= 2 (length (cdr form))) + (progn + (byte-compile-warn-wrong-args form 2) + (byte-compile-normal-call + `(signal 'wrong-number-of-arguments '(,(car form) + ,(length (cdr form)))))) + (byte-compile-form (nth 1 form)) ;; Push the arguments + (byte-compile-form (nth 2 form)) + (byte-compile-out (get (car form) 'byte-opcode) 0) + (pushnew '(null (function-max-args 'throw)) + byte-compile-checks-on-load +:test #'equal))) ;;; top-level forms elsewhere ＠＠ -4115,6 +4213,8 ＠＠ ;; This is actually an unnecessary case, because there should be ;; no more opcodes behind byte-return. (setq byte-compile-depth nil)) + (byte-multiple-value-call + (setq byte-compile-depth (- byte-compile-depth offset))) (t (setq byte-compile-depth (+ byte-compile-depth (or (aref byte-stack+-info diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/cl-compat.el --- a/lisp/cl-compat.el Sun Aug 16 14:58:57 2009 +0100 +++ b/lisp/cl-compat.el Sun Aug 16 20:55:49 2009 +0100 ＠＠ -59,52 +59,10 ＠＠ (defun keyword-of (sym) (or (keywordp sym) (keywordp (intern (format ":%s" sym))))) - -;;; Multiple values. Note that the new package uses a different -;;; convention for multiple values. The following definitions -;;; emulate the old convention; all function names have been changed -;;; by capitalizing the first letter: Values, Multiple-value-*, -;;; to avoid conflict with the new-style definitions in cl-macs. - -(put 'Multiple-value-bind 'lisp-indent-function 2) -(put 'Multiple-value-setq 'lisp-indent-function 2) -(put 'Multiple-value-call 'lisp-indent-function 1) -(put 'Multiple-value-prog1 'lisp-indent-function 1) - -(defvar *mvalues-values* nil) - -(defun Values (&rest val-forms) - (setq *mvalues-values* val-forms) - (car val-forms)) - -(defun Values-list (val-forms) - (apply 'values val-forms)) - -(defmacro Multiple-value-list (form) - (list 'let* (list '(*mvalues-values* nil) (list '*mvalues-temp* form)) - '(or (and (eq *mvalues-temp* (car *mvalues-values*)) *mvalues-values*) - (list *mvalues-temp*)))) - -(defmacro Multiple-value-call (function &rest args) - (list 'apply function - (cons 'append - (mapcar (function (lambda (x) (list 'Multiple-value-list x))) - args)))) - -(defmacro Multiple-value-bind (vars form &rest body) - (list* 'multiple-value-bind vars (list 'Multiple-value-list form) body)) - -(defmacro Multiple-value-setq (vars form) - (list 'multiple-value-setq vars (list 'Multiple-value-list form))) - -(defmacro Multiple-value-prog1 (form &rest body) - (list 'prog1 form (list* 'let '((*mvalues-values* nil)) body))) - - ;;; Routines for parsing keyword arguments. (defun build-klist (arglist keys &optional allow-others) - (let ((res (Multiple-value-call 'mapcar* 'cons (unzip-lists arglist)))) + (let ((res (multiple-value-call 'mapcar* 'cons (unzip-lists arglist)))) (or allow-others (let ((bad (set-difference (mapcar 'car res) keys))) (if bad (error "Bad keywords: %s not in %s" bad keys)))) ＠＠ -124,25 +82,23 ＠＠ (if test-not (not (funcall test-not item elt)) (funcall (or test 'eql) item elt)))) - ;;; Rounding functions with old-style multiple value returns. -(defun cl-floor (a &optional b) (Values-list (floor* a b))) -(defun cl-ceiling (a &optional b) (Values-list (ceiling* a b))) -(defun cl-round (a &optional b) (Values-list (round* a b))) -(defun cl-truncate (a &optional b) (Values-list (truncate* a b))) +(defun cl-floor (a &optional b) (values-list (floor* a b))) +(defun cl-ceiling (a &optional b) (values-list (ceiling* a b))) +(defun cl-round (a &optional b) (values-list (round* a b))) +(defun cl-truncate (a &optional b) (values-list (truncate* a b))) (defun safe-idiv (a b) (let* ((q (/ (abs a) (abs b))) (s (* (signum a) (signum b)))) - (Values q (- a (* s q b)) s))) - + (values q (- a (* s q b)) s))) ;; Internal routines. (defun pair-with-newsyms (oldforms) (let ((newsyms (mapcar (function (lambda (x) (gensym))) oldforms))) - (Values (mapcar* 'list newsyms oldforms) newsyms))) + (values (mapcar* 'list newsyms oldforms) newsyms))) (defun zip-lists (evens odds) (mapcan 'list evens odds)) ＠＠ -151,7 +107,7 ＠＠ (let ((e nil) (o nil)) (while list (setq e (cons (car list) e) o (cons (cadr list) o) list (cddr list))) - (Values (nreverse e) (nreverse o)))) + (values (nreverse e) (nreverse o)))) (defun reassemble-argslists (list) (let ((n (apply 'min (mapcar 'length list))) (res nil)) diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/cl-macs.el --- a/lisp/cl-macs.el Sun Aug 16 14:58:57 2009 +0100 +++ b/lisp/cl-macs.el Sun Aug 16 20:55:49 2009 +0100 ＠＠ -715,24 +715,30 ＠＠ (defvar cl-active-block-names nil) -(put 'cl-block-wrapper 'byte-compile 'cl-byte-compile-block) -(defun cl-byte-compile-block (cl-form) - (if (fboundp 'byte-compile-form-do-effect) ; Check for optimizing compiler - (progn - (let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil)) - (cl-active-block-names (cons cl-entry cl-active-block-names)) - (cl-body (byte-compile-top-level - (cons 'progn (cddr (nth 1 cl-form)))))) - (if (cdr cl-entry) - (byte-compile-form (list 'catch (nth 1 (nth 1 cl-form)) cl-body)) - (byte-compile-form cl-body)))) - (byte-compile-form (nth 1 cl-form)))) +(put 'cl-block-wrapper 'byte-compile + #'(lambda (cl-form) + (if (/= (length cl-form) 2) + (byte-compile-warn-wrong-args cl-form 1)) -(put 'cl-block-throw 'byte-compile 'cl-byte-compile-throw) -(defun cl-byte-compile-throw (cl-form) - (let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names))) - (if cl-found (setcdr cl-found t))) - (byte-compile-normal-call (cons 'throw (cdr cl-form)))) + (if (fboundp 'byte-compile-form-do-effect) ; Check for optimizing + ; compiler + (progn + (let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil)) + (cl-active-block-names (cons cl-entry + cl-active-block-names)) + (cl-body (byte-compile-top-level + (cons 'progn (cddr (nth 1 cl-form)))))) + (if (cdr cl-entry) + (byte-compile-form (list 'catch (nth 1 (nth 1 cl-form)) + cl-body)) + (byte-compile-form cl-body)))) + (byte-compile-form (nth 1 cl-form))))) + +(put 'cl-block-throw 'byte-compile + #'(lambda (cl-form) + (let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names))) + (if cl-found (setcdr cl-found t))) + (byte-compile-throw (cons 'throw (cdr cl-form))))) ;;;###autoload (defmacro return (&optional result) ＠＠ -1841,47 +1847,70 ＠＠ (list 'function (cons 'lambda rest))) (list 'quote func))) - -;;; Multiple values. +;;; Multiple values. We support full Common Lisp conventions here. ;;;###autoload -(defmacro multiple-value-bind (vars form &rest body) - "(multiple-value-bind (SYM SYM...) FORM BODY): collect multiple return values. -FORM must return a list; the BODY is then executed with the first N elements -of this list bound (`let'-style) to each of the symbols SYM in turn. This -is analogous to the Common Lisp `multiple-value-bind' macro, using lists to -simulate true multiple return values. For compatibility, (values A B C) is -a synonym for (list A B C)." - (let ((temp (gensym)) (n -1)) - (list* 'let* (cons (list temp form) - (mapcar #'(lambda (v) - (list v (list 'nth (setq n (1+ n)) temp))) - vars)) - body))) +(defmacro multiple-value-bind (syms form &rest body) + "Collect and bind multiple return values. + +If FORM returns multiple values, each symbol in SYMS is bound to one of +them, in order, and BODY is executed. If FORM returns fewer multiple values +than there are SYMS, remaining SYMS are bound to nil. If FORM does +not return multiple values, it is treated as returning one multiple value. + +Returns the value given by the last element of BODY." + (if (null syms) + `(progn ,form ,＠body) + (if (= 1 (length syms)) + ;; Code written to deal with other "implementations" of multiple + ;; values may have a one-element SYMS. + `(let ((,(car syms) ,form)) + ,＠body) + (let ((temp (gensym))) + `(let* ((,temp (multiple-value-list-internal 0 ,(length syms) ,form)) + ,＠(loop + for var in syms + collect `(,var (prog1 (car ,temp) + (setq ,temp (cdr ,temp)))))) + ,＠body))))) ;;;###autoload -(defmacro multiple-value-setq (vars form) - "(multiple-value-setq (SYM SYM...) FORM): collect multiple return values. -FORM must return a list; the first N elements of this list are stored in -each of the symbols SYM in turn. This is analogous to the Common Lisp -`multiple-value-setq' macro, using lists to simulate true multiple return -values. For compatibility, (values A B C) is a synonym for (list A B C)." - (cond ((null vars) (list 'progn form nil)) - ((null (cdr vars)) (list 'setq (car vars) (list 'car form))) - (t - (let* ((temp (gensym)) (n 0)) - (list 'let (list (list temp form)) - (list 'prog1 (list 'setq (pop vars) (list 'car temp)) - (cons 'setq - (apply 'nconc - (mapcar - #'(lambda (v) - (list v (list - 'nth - (setq n (1+ n)) - temp))) - vars))))))))) +(defmacro multiple-value-setq (syms form) + "Collect and set multiple values. +FORM should normally return multiple values; the first N values are stored +in the symbols in SYMS in turn. If FORM returns fewer than N values, the +remaining symbols have their values set to nil. FORM not returning multiple +values is treated as FORM returning one multiple value, with other elements +of SYMS initialized to nil. + +Returns the first of the multiple values given by FORM." + (if (null syms) + ;; Never return multiple values from multiple-value-setq: + (and form `(values ,form)) + (if (= 1 (length syms)) + `(setq ,(car syms) ,form) + (let ((temp (gensym))) + `(let* ((,temp (multiple-value-list-internal 0 ,(length syms) ,form))) + (setq ,＠(loop + for sym in syms + nconc `(,sym (car-safe ,temp) + ,temp (cdr-safe ,temp)))) + ,(car syms)))))) + +;;;###autoload +(defmacro multiple-value-list (form) + "Evaluate FORM and return a list of the multiple values it returned." + `(multiple-value-list-internal 0 multiple-values-limit ,form)) + +;;;###autoload +(defmacro nth-value (n form) + "Evaluate FORM and return the Nth multiple value it returned." + (if (integerp n) + `(car (multiple-value-list-internal ,n ,(1+ n) ,form)) + (let ((temp (gensym))) + `(let ((,temp ,n)) + (car (multiple-value-list-internal ,temp (1+ ,temp) ,form)))))) ;;; Declarations. ＠＠ -2346,8 +2375,9 ＠＠ (store-temp (gensym "--values-store--"))) (list (apply 'append (mapcar 'first methods)) (apply 'append (mapcar 'second methods)) - (list store-temp) - (cons 'list + `((,store-temp + (multiple-value-list-internal 0 ,(if args (length args) 1)))) + (cons 'values (mapcar #'(lambda (m) (cl-setf-do-store (cons (car (third m)) (fourth m)) (list 'pop store-temp))) ＠＠ -2410,11 +2440,25 ＠＠ (defun cl-setf-do-store (spec val) (let ((sym (car spec)) (form (cdr spec))) - (if (or (cl-const-expr-p val) - (and (cl-simple-expr-p val) (eq (cl-expr-contains form sym) 1)) - (cl-setf-simple-store-p sym form)) - (subst val sym form) - (list 'let (list (list sym val)) form)))) + (if (consp sym) + ;; XEmacs change, only used for implementing #'values at the moment. + (let* ((orig (copy-list sym)) + (intermediate (last orig)) + (circular-limit 32)) + (while (consp (car intermediate)) + (when (zerop circular-limit) + (error 'circular-list "Form seems to contain loops")) + (setq intermediate (last (car intermediate)) + circular-limit (1- circular-limit))) + (setcdr intermediate (list val)) + `(let (,orig) + ,form)) + (if (or (cl-const-expr-p val) + (and (cl-simple-expr-p val) + (eq (cl-expr-contains form sym) 1)) + (cl-setf-simple-store-p sym form)) + (subst val sym form) + (list 'let (list (list sym val)) form))))) (defun cl-setf-simple-store-p (sym form) (and (consp form) (eq (cl-expr-contains form sym) 1) diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/cl.el --- a/lisp/cl.el Sun Aug 16 14:58:57 2009 +0100 +++ b/lisp/cl.el Sun Aug 16 20:55:49 2009 +0100 ＠＠ -209,48 +209,24 ＠＠ ;;; Blocks and exits. -(defalias 'cl-block-wrapper 'identity) +;; This used to be #'identity, but that didn't preserve multiple values in +;; interpreted code. #'and isn't great either, there's no error on too many +;; arguments passed to it when interpreted. Fortunately most of the places +;; where cl-block-wrapper is called are generated from old, established +;; macros, so too many arguments resulting from human error is unlikely; and +;; the byte compile handler in cl-macs.el warns if more than one arg is +;; passed to it. +(defalias 'cl-block-wrapper 'and) + (defalias 'cl-block-throw 'throw) +;;; XEmacs; multiple values are in eval.c and cl-macs.el. -;;; Multiple values. True multiple values are not supported, or even -;;; simulated. Instead, multiple-value-bind and friends simply expect -;;; the target form to return the values as a list. +;;; We no longer support `multiple-value-apply', which was ill-conceived to +;;; start with, is not specified by Common Lisp, and which nothing uses, +;;; according to Google Code Search, as of Sat Mar 14 23:31:35 GMT 2009. -(defsubst values (&rest values) - "Return multiple values, Common Lisp style. -The arguments of `values' are the values -that the containing function should return." - values) - -(defsubst values-list (list) - "Return multiple values, Common Lisp style, taken from a list. -LIST specifies the list of values -that the containing function should return." - list) - -(defsubst multiple-value-list (expression) - "Return a list of the multiple values produced by EXPRESSION. -This handles multiple values in Common Lisp style, but it does not -work right when EXPRESSION calls an ordinary Emacs Lisp function -that returns just one value." - expression) - -(defsubst multiple-value-apply (function expression) - "Evaluate EXPRESSION to get multiple values and apply FUNCTION to them. -This handles multiple values in Common Lisp style, but it does not work -right when EXPRESSION calls an ordinary Emacs Lisp function that returns just -one value." - (apply function expression)) - -(defalias 'multiple-value-call 'apply) ; only works for one arg - -(defsubst nth-value (n expression) - "Evaluate EXPRESSION to get multiple values and return the Nth one. -This handles multiple values in Common Lisp style, but it does not work -right when EXPRESSION calls an ordinary Emacs Lisp function that returns just -one value." - (nth n expression)) +(make-obsolete 'multiple-value-apply 'multiple-value-call) ;;; Macros. diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/lisp-mode.el --- a/lisp/lisp-mode.el Sun Aug 16 14:58:57 2009 +0100 +++ b/lisp/lisp-mode.el Sun Aug 16 20:55:49 2009 +0100 ＠＠ -424,36 +424,55 ＠＠ been treated noninteractively. The printed messages are \"defvar treated as defconst\" and \"defcustom - evaluation forced\". See `eval-interactive' for more details." +evaluation forced\". See `eval-interactive' for more details." :type 'boolean :group 'lisp) (defun eval-interactive (expr) - "Like `eval' except that it transforms defvars to defconsts. -The evaluation of defcustom forms is forced." + "Evaluate EXPR; pass back multiple values, transform defvars to defconsts. + +Always returns a list. The length of this list will be something other than +one if the form returned multiple values. It will be zero if the form +returned a single zero-length multiple value." (cond ((and (eq (car-safe expr) 'defvar) (> (length expr) 2)) - (eval (cons 'defconst (cdr expr))) + (setq expr (multiple-value-list (eval (cons 'defconst (cdr expr))))) (when eval-interactive-verbose (message "defvar treated as defconst") (sit-for 1) (message "")) - (nth 1 expr)) + expr) ((and (eq (car-safe expr) 'defcustom) (> (length expr) 2) (default-boundp (nth 1 expr))) ;; Force variable to be bound - ;; #### defcustom might specify a different :set method. - (set-default (nth 1 expr) (eval (nth 2 expr))) + (funcall + (or (plist-get expr :set) #'custom-set-default) + (nth 1 expr) (eval (nth 2 expr))) ;; And evaluate the defcustom - (eval expr) + (setq expr (multiple-value-list (eval expr))) (when eval-interactive-verbose (message "defcustom evaluation forced") (sit-for 1) (message "")) - (nth 1 expr)) + expr) (t - (eval expr)))) + (multiple-value-list (eval expr))))) + +(defun prin1-list-as-multiple-values (multiple-value-list &optional stream) + "Call `prin1' on each element of MULTIPLE-VALUE-LIST, separated by \" ;\\n\" + +If MULTIPLE-VALUE-LIST is zero-length, print the text +\"#<zero length multiple value> ;\\n\". Always returns nil." + (loop for value in multiple-value-list + with seen-first = nil + do + (if seen-first + (princ " ;\n" stream) + (setq seen-first t)) + (prin1 value stream) + finally (unless seen-first + (princ "#<zero length multiple value> ;" stream)))) ;; XEmacs change, based on Bob Weiner suggestion (defun eval-last-sexp (eval-last-sexp-arg-internal) ;dynamic scoping wonderment ＠＠ -463,31 +482,32 ＠＠ (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t)) (opoint (point)) ignore-quotes) - (prin1 (eval-interactive - (letf (((syntax-table) emacs-lisp-mode-syntax-table)) - (save-excursion - ;; If this sexp appears to be enclosed in `...' then - ;; ignore the surrounding quotes. - (setq ignore-quotes (or (eq (char-after) ?\') - (eq (char-before) ?\'))) - (forward-sexp -1) - ;; vladimir(a)cs.ualberta.ca 30-Jul-1997: skip ` in - ;; `variable' so that the value is returned, not the - ;; name. - (if (and ignore-quotes - (eq (char-after) ?\`)) - (forward-char)) - (save-restriction - (narrow-to-region (point-min) opoint) - (let ((expr (read (current-buffer)))) - (if (eq (car-safe expr) 'interactive) - ;; If it's an (interactive ...) form, it's - ;; more useful to show how an interactive call - ;; would use it. - `(call-interactively - (lambda (&rest args) - ,expr args)) - expr))))))))) + (prin1-list-as-multiple-values + (eval-interactive + (letf (((syntax-table) emacs-lisp-mode-syntax-table)) + (save-excursion + ;; If this sexp appears to be enclosed in `...' then + ;; ignore the surrounding quotes. + (setq ignore-quotes (or (eq (char-after) ?\') + (eq (char-before) ?\'))) + (forward-sexp -1) + ;; vladimir(a)cs.ualberta.ca 30-Jul-1997: skip ` in + ;; `variable' so that the value is returned, not the + ;; name. + (if (and ignore-quotes + (eq (char-after) ?\`)) + (forward-char)) + (save-restriction + (narrow-to-region (point-min) opoint) + (let ((expr (read (current-buffer)))) + (if (eq (car-safe expr) 'interactive) + ;; If it's an (interactive ...) form, it's + ;; more useful to show how an interactive call + ;; would use it. + `(call-interactively + (lambda (&rest args) + ,expr args)) + expr))))))))) (defun eval-defun (eval-defun-arg-internal) "Evaluate defun that point is in or before. ＠＠ -495,11 +515,12 ＠＠ With argument, insert value in current buffer after the defun." (interactive "P") (let ((standard-output (if eval-defun-arg-internal (current-buffer) t))) - (prin1 (eval-interactive (save-excursion - (end-of-defun) - (beginning-of-defun) - (read (current-buffer))))))) - + (prin1-list-as-multiple-values + (eval-interactive + (save-excursion + (end-of-defun) + (beginning-of-defun) + (read (current-buffer))))))) (defun lisp-comment-indent () (if (looking-at "\\s<\\s<\\s<") diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/mouse.el --- a/lisp/mouse.el Sun Aug 16 14:58:57 2009 +0100 +++ b/lisp/mouse.el Sun Aug 16 20:55:49 2009 +0100 ＠＠ -278,18 +278,23 ＠＠ (message "Regex \"%s\" not found" exp) (ding nil 'quiet))) (t (setq val (if (fboundp 'eval-interactive) - (eval-interactive exp) - (eval exp))))) - (setq result-str (prin1-to-string val)) + (eval-interactive exp) + (list (eval exp)))))) + (setq result-str (mapconcat #'prin1-to-string val " ;\n")) ;; #### -- need better test (if (and (not force-window) - (<= (length result-str) (window-width (selected-window)))) + (<= (length result-str) (window-width (selected-window))) + (not (string-match "\n" result-str))) (message "%s" result-str) (with-output-to-temp-buffer "*Mouse-Eval*" - (if-fboundp 'pprint - (pprint val) - (prin1 val))) - ))) + (loop + for value in val + with seen-first = nil + do + (if seen-first + (princ " ;\n") + (setq seen-first t)) + (cl-prettyprint value)))))) (defun mouse-line-length (event) "Print the length of the line indicated by the pointer." diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/obsolete.el --- a/lisp/obsolete.el Sun Aug 16 14:58:57 2009 +0100 +++ b/lisp/obsolete.el Sun Aug 16 20:55:49 2009 +0100 ＠＠ -395,5 +395,18 ＠＠ (make-obsolete 'function-called-at-point 'function-at-point) +;; As of 21.5, #'throw is a special form. This makes bytecode using it +;; compiled for 21.4 fail; making this function available works around that. +(defun obsolete-throw (tag value) + "Ugly compatibility hack. + +See the implementation of #'funcall in eval.c. This should be removed once +we no longer encounter bytecode from 21.4." + (throw tag value)) + +(make-obsolete + 'obsolete-throw + "it says `obsolete' in the name, you know you shouldn't be using this.") + (provide 'obsolete) ;;; obsolete.el ends here diff -r e3feb329bda9 -r 8f1ee2d15784 man/ChangeLog --- a/man/ChangeLog Sun Aug 16 14:58:57 2009 +0100 +++ b/man/ChangeLog Sun Aug 16 20:55:49 2009 +0100 ＠＠ -1,3 +1,8 ＠＠ +2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net> + + * cl.texi (Organization): + Remove references to the obsolete multiple-value emulating code. + 2009-07-28 Stephen Turnbull <stephen(a)xemacs.org> * internals/internals.texi (Redisplay Piece by Piece): diff -r e3feb329bda9 -r 8f1ee2d15784 man/cl.texi --- a/man/cl.texi Sun Aug 16 14:58:57 2009 +0100 +++ b/man/cl.texi Sun Aug 16 20:55:49 2009 +0100 ＠＠ -249,9 +249,8 ＠＠ There is another file, ＠file{cl-compat.el}, which defines some routines from the older ＠file{cl.el} package that are no longer present in the new package. This includes internal routines -like ＠code{setelt} and ＠code{zip-lists}, deprecated features -like ＠code{defkeyword}, and an emulation of the old-style -multiple-values feature. ＠xref{Old CL Compatibility}. +like ＠code{setelt} and ＠code{zip-lists}, and deprecated features +like ＠code{defkeyword}. ＠xref{Old CL Compatibility}. ＠node Installation, Naming Conventions, Organization, Overview ＠section Installation ＠＠ -5345,14 +5344,6 ＠＠ The ＠code{loop} macro is complete except that ＠code{loop-finish} and type specifiers are unimplemented. -The multiple-value return facility treats lists as multiple -values, since Emacs Lisp cannot support multiple return values -directly. The macros will be compatible with Common Lisp if -＠code{values} or ＠code{values-list} is always used to return to -a ＠code{multiple-value-bind} or other multiple-value receiver; -if ＠code{values} is used without ＠code{multiple-value-＠dots{}} -or vice-versa the effect will be different from Common Lisp. - Many Common Lisp declarations are ignored, and others match the Common Lisp standard in concept but not in detail. For example, local ＠code{special} declarations, which are purely ＠＠ -5377,14 +5368,6 ＠＠ Following is a list of all known incompatibilities between this package and the older Quiroz ＠file{cl.el} package. -This package's emulation of multiple return values in functions is -incompatible with that of the older package. That package attempted -to come as close as possible to true Common Lisp multiple return -values; unfortunately, it could not be 100% reliable and so was prone -to occasional surprises if used freely. This package uses a simpler -method, namely replacing multiple values with lists of values, which -is more predictable though more noticeably different from Common Lisp. - The ＠code{defkeyword} form and ＠code{keywordp} function are not implemented in this package. ＠＠ -5449,19 +5432,6 ＠＠ use the more natural keyword argument processing offered by ＠code{defun*}. -Multiple return values are treated differently by the two -Common Lisp packages. The old package's method was more -compatible with true Common Lisp, though it used heuristics -that caused it to report spurious multiple return values in -certain cases. The ＠code{cl-compat} package defines a set -of multiple-value macros that are compatible with the old -CL package; again, they are heuristic in nature, but they -are guaranteed to work in any case where the old package's -macros worked. To avoid name collision with the ``official'' -multiple-value facilities, the ones in ＠code{cl-compat} have -capitalized names: ＠code{Values}, ＠code{Values-list}, -＠code{Multiple-value-bind}, etc. - The functions ＠code{cl-floor}, ＠code{cl-ceiling}, ＠code{cl-truncate}, and ＠code{cl-round} are defined by ＠code{cl-compat} to use the old-style multiple-value mechanism, just as they did in the old diff -r e3feb329bda9 -r 8f1ee2d15784 src/ChangeLog --- a/src/ChangeLog Sun Aug 16 14:58:57 2009 +0100 +++ b/src/ChangeLog Sun Aug 16 20:55:49 2009 +0100 ＠＠ -1,3 +1,118 ＠＠ +2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net> + + * bytecode.c (enum Opcode /* Byte codes */): + Add four new bytecodes, to deal with multiple values. + (POP_WITH_MULTIPLE_VALUES): New macro. + (POP): Modify this macro to ignore multiple values. + (DISCARD_PRESERVING_MULTIPLE_VALUES): New macro. + (DISCARD): Modify this macro to ignore multiple values. + (TOP_WITH_MULTIPLE_VALUES): New macro. + (TOP_ADDRESS): New macro. + (TOP): Modify this macro to ignore multiple values. + (TOP_LVALUE): New macro. + (Bcall): Ignore multiple values where appropriate. + (Breturn): Pass back multiple values. + (Bdup): Preserve multiple values. + Use TOP_LVALUE with most bytecodes that assign anything to + anything. + (Bbind_multiple_value_limits, Bmultiple_value_call, + Bmultiple_value_list_internal, Bthrow): Implement the new + bytecodes. + (Bgotoifnilelsepop, Bgotoifnonnilelsepop, BRgotoifnilelsepop, + BRgotoifnonnilelsepop): + Discard any multiple values. + * callint.c (Fcall_interactively): + Ignore multiple values when calling #'eval, in two places. + * device-x.c (x_IO_error_handler): + * macros.c (pop_kbd_macro_event): + * eval.c (Fsignal): + * eval.c (flagged_a_squirmer): + Call throw_or_bomb_out, not Fthrow, now that the latter is a + special form. + * eval.c: + Make Qthrow, Qobsolete_throw available as symbols. + Provide multiple_value_current_limit, multiple-values-limit (the + latter as specified by Common Lisp. + * eval.c (For): + Ignore multiple values when comparing with Qnil, but pass any + multiple values back for the last arg. + * eval.c (Fand): + Ditto. + * eval.c (Fif): + Ignore multiple values when examining the result of the + condition. + * eval.c (Fcond): + Ignore multiple values when comparing what the clauses give, but + pass them back if a clause gave non-nil. + * eval.c (Fprog2): + Never pass back multiple values. + * eval.c (FletX, Flet): + Ignore multiple when evaluating what exactly symbols should be + bound to. + * eval.c (Fwhile): + Ignore multiple values when evaluating the test. + * eval.c (Fsetq, Fdefvar, Fdefconst): + Ignore multiple values. + * eval.c (Fthrow): + Declare this as a special form; ignore multiple values for TAG, + preserve them for VALUE. + * eval.c (throw_or_bomb_out): + Make this available to other files, now Fthrow is a special form. + * eval.c (Feval): + Ignore multiple values when calling a compiled function, a + non-special-form subr, or a lambda expression. + * eval.c (Ffuncall): + If we attempt to call #'throw (now a special form) as a function, + don't error, call #'obsolete-throw instead. + * eval.c (make_multiple_value, multiple_value_aset) + (multiple_value_aref, print_multiple_value, mark_multiple_value) + (size_multiple_value): + Implement the multiple_value type. Add a long comment describing + our implementation. + * eval.c (bind_multiple_value_limits): + New function, used by the bytecode and by #'multiple-value-call, + #'multiple-value-list-internal. + * eval.c (multiple_value_call): + New function, used by the bytecode and #'multiple-value-call. + * eval.c (Fmultiple_value_call): + New special form. + * eval.c (multiple_value_list_internal): + New function, used by the byte code and + #'multiple-value-list-internal. + * eval.c (Fmultiple_value_list_internal, Fmultiple_value_prog1): + New special forms. + * eval.c (Fvalues, Fvalues_list): + New Lisp functions. + * eval.c (values2): + New function, for C code returning multiple values. + * eval.c (syms_of_eval): + Make our new Lisp functions and symbols available. + * eval.c (multiple-values-limit): + Make this available to Lisp. + * event-msw.c (dde_eval_string): + * event-stream.c (execute_help_form): + * glade.c (connector): + * glyphs-widget.c (glyph_instantiator_to_glyph): + * glyphs.c (evaluate_xpm_color_symbols): + * gui-x.c (wv_set_evalable_slot, button_item_to_widget_value): + * gui.c (gui_item_value, gui_item_display_flush_left): + * lread.c (check_if_suppressed): + * menubar-gtk.c (menu_convert, menu_descriptor_to_widget_1): + * menubar-msw.c (populate_menu_add_item): + * print.c (Fwith_output_to_temp_buffer): + * symbols.c (Fsetq_default): + Ignore multiple values when calling Feval. + * symeval.h: + Add the header declarations necessary for the multiple-values + implementation. + * inline.c: + #include symeval.h, now that it has some inline functions. + * lisp.h: + Update Fthrow's declaration. Make throw_or_bomb_out available to + all files. + * lrecord.h (enum lrecord_type): + Add the multiple_value type here. + 2009-07-28 Stephen Turnbull <stephen(a)xemacs.org> * faces.c (ensure_face_cachel_contains_charset): diff -r e3feb329bda9 -r 8f1ee2d15784 src/bytecode.c --- a/src/bytecode.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/bytecode.c Sun Aug 16 20:55:49 2009 +0100 ＠＠ -243,6 +243,12 ＠＠ BlistN = 0257, BconcatN = 0260, BinsertN = 0261, + + Bbind_multiple_value_limits = 0262, /* New in 21.5. */ + Bmultiple_value_list_internal = 0263, /* New in 21.5. */ + Bmultiple_value_call = 0264, /* New in 21.5. */ + Bthrow = 0265, /* New in 21.5. */ + Bmember = 0266, /* new in v20 */ Bassq = 0267, /* new in v20 */ ＠＠ -653,15 +659,44 ＠＠ /* Push x onto the execution stack. */ #define PUSH(x) (*++stack_ptr = (x)) -/* Pop a value off the execution stack. */ -#define POP (*stack_ptr--) +/* Pop a value, which may be multiple, off the execution stack. */ +#define POP_WITH_MULTIPLE_VALUES (*stack_ptr--) + +/* Pop a value off the execution stack, treating multiple values as single. */ +#define POP (IGNORE_MULTIPLE_VALUES (POP_WITH_MULTIPLE_VALUES)) + +#define DISCARD_PRESERVING_MULTIPLE_VALUES(n) (stack_ptr -= (n)) /* Discard n values from the execution stack. */ -#define DISCARD(n) (stack_ptr -= (n)) +#define DISCARD(n) do { \ + if (1 != multiple_value_current_limit) \ + { \ + int i, en = n; \ + for (i = 0; i < en; i++) \ + { \ + *stack_ptr = ignore_multiple_values (*stack_ptr); \ + stack_ptr--; \ + } \ + } \ + else \ + { \ + stack_ptr -= (n); \ + } \ + } while (0) + +/* Get the value, which may be multiple, at the top of the execution stack; + and leave it there. */ +#define TOP_WITH_MULTIPLE_VALUES (*stack_ptr) + +#define TOP_ADDRESS (stack_ptr) /* Get the value which is at the top of the execution stack, but don't pop it. */ -#define TOP (*stack_ptr) +#define TOP (IGNORE_MULTIPLE_VALUES (TOP_WITH_MULTIPLE_VALUES)) + +#define TOP_LVALUE (*stack_ptr) + + /* See comment before the big switch in execute_optimized_program(). */ #define GCPRO_STACK (gcpro1.nvars = stack_ptr - stack_beg) ＠＠ -859,7 +894,8 ＠＠ Fput (TOP, Qbyte_code_meter, make_int (XINT (val) + 1)); } #endif - TOP = Ffuncall (n + 1, &TOP); + TOP_LVALUE = TOP; /* Ignore multiple values. */ + TOP_LVALUE = Ffuncall (n + 1, TOP_ADDRESS); break; case Bunbind: ＠＠ -895,7 +931,8 ＠＠ break; case Bgotoifnilelsepop: - if (NILP (TOP)) + /* Discard any multiple value: */ + if (NILP (TOP_LVALUE = TOP)) JUMP; else { ＠＠ -905,7 +942,8 ＠＠ break; case Bgotoifnonnilelsepop: - if (!NILP (TOP)) + /* Discard any multiple value: */ + if (!NILP (TOP_LVALUE = TOP)) JUMP; else { ＠＠ -934,7 +972,7 ＠＠ break; case BRgotoifnilelsepop: - if (NILP (TOP)) + if (NILP (TOP_LVALUE = TOP)) JUMPR; else { ＠＠ -944,7 +982,7 ＠＠ break; case BRgotoifnonnilelsepop: - if (!NILP (TOP)) + if (!NILP (TOP_LVALUE = TOP)) JUMPR; else { ＠＠ -960,7 +998,7 ＠＠ if (specpdl_depth() != speccount) invalid_byte_code ("unbalanced specbinding stack", Qunbound); #endif - return TOP; + return TOP_WITH_MULTIPLE_VALUES; case Bdiscard: DISCARD (1); ＠＠ -968,7 +1006,7 ＠＠ case Bdup: { - Lisp_Object arg = TOP; + Lisp_Object arg = TOP_WITH_MULTIPLE_VALUES; PUSH (arg); break; } ＠＠ -978,17 +1016,22 ＠＠ break; case Bcar: - /* Fcar can GC via wrong_type_argument. */ - /* GCPRO_STACK; */ - TOP = CONSP (TOP) ? XCAR (TOP) : Fcar (TOP); - break; + { + /* Fcar can GC via wrong_type_argument. */ + /* GCPRO_STACK; */ + Lisp_Object arg = TOP; + TOP_LVALUE = CONSP (arg) ? XCAR (arg) : Fcar (arg); + break; + } case Bcdr: - /* Fcdr can GC via wrong_type_argument. */ - /* GCPRO_STACK; */ - TOP = CONSP (TOP) ? XCDR (TOP) : Fcdr (TOP); - break; - + { + /* Fcdr can GC via wrong_type_argument. */ + /* GCPRO_STACK; */ + Lisp_Object arg = TOP; + TOP_LVALUE = CONSP (arg) ? XCDR (arg) : Fcdr (arg); + break; + } case Bunbind_all: /* To unbind back to the beginning of this frame. Not used yet, ＠＠ -1001,62 +1044,62 ＠＠ Lisp_Object arg = POP; /* Fcar and Fnthcdr can GC via wrong_type_argument. */ /* GCPRO_STACK; */ - TOP = Fcar (Fnthcdr (TOP, arg)); + TOP_LVALUE = Fcar (Fnthcdr (TOP, arg)); break; } case Bsymbolp: - TOP = SYMBOLP (TOP) ? Qt : Qnil; + TOP_LVALUE = SYMBOLP (TOP) ? Qt : Qnil; break; case Bconsp: - TOP = CONSP (TOP) ? Qt : Qnil; + TOP_LVALUE = CONSP (TOP) ? Qt : Qnil; break; case Bstringp: - TOP = STRINGP (TOP) ? Qt : Qnil; + TOP_LVALUE = STRINGP (TOP) ? Qt : Qnil; break; case Blistp: - TOP = LISTP (TOP) ? Qt : Qnil; + TOP_LVALUE = LISTP (TOP) ? Qt : Qnil; break; case Bnumberp: #ifdef WITH_NUMBER_TYPES - TOP = NUMBERP (TOP) ? Qt : Qnil; + TOP_LVALUE = NUMBERP (TOP) ? Qt : Qnil; #else - TOP = INT_OR_FLOATP (TOP) ? Qt : Qnil; + TOP_LVALUE = INT_OR_FLOATP (TOP) ? Qt : Qnil; #endif break; case Bintegerp: #ifdef HAVE_BIGNUM - TOP = INTEGERP (TOP) ? Qt : Qnil; + TOP_LVALUE = INTEGERP (TOP) ? Qt : Qnil; #else - TOP = INTP (TOP) ? Qt : Qnil; + TOP_LVALUE = INTP (TOP) ? Qt : Qnil; #endif break; case Beq: { Lisp_Object arg = POP; - TOP = EQ_WITH_EBOLA_NOTICE (TOP, arg) ? Qt : Qnil; + TOP_LVALUE = EQ_WITH_EBOLA_NOTICE (TOP, arg) ? Qt : Qnil; break; } case Bnot: - TOP = NILP (TOP) ? Qt : Qnil; + TOP_LVALUE = NILP (TOP) ? Qt : Qnil; break; case Bcons: { Lisp_Object arg = POP; - TOP = Fcons (TOP, arg); + TOP_LVALUE = Fcons (TOP, arg); break; } case Blist1: - TOP = Fcons (TOP, Qnil); + TOP_LVALUE = Fcons (TOP, Qnil); break; ＠＠ -1079,7 +1122,7 ＠＠ DISCARD (1); goto list_loop; } - TOP = list; + TOP_LVALUE = list; break; } ＠＠ -1097,101 +1140,107 ＠＠ DISCARD (n - 1); /* Apparently `concat' can GC; Fconcat GCPROs its arguments. */ /* GCPRO_STACK; */ - TOP = Fconcat (n, &TOP); + TOP_LVALUE = TOP; /* Ignore multiple values. */ + TOP_LVALUE = Fconcat (n, TOP_ADDRESS); break; case Blength: - TOP = Flength (TOP); + TOP_LVALUE = Flength (TOP); break; case Baset: { Lisp_Object arg2 = POP; Lisp_Object arg1 = POP; - TOP = Faset (TOP, arg1, arg2); + TOP_LVALUE = Faset (TOP, arg1, arg2); break; } case Bsymbol_value: /* Why does this need GCPRO_STACK? If not, remove others, too. */ /* GCPRO_STACK; */ - TOP = Fsymbol_value (TOP); + TOP_LVALUE = Fsymbol_value (TOP); break; case Bsymbol_function: - TOP = Fsymbol_function (TOP); + TOP_LVALUE = Fsymbol_function (TOP); break; case Bget: { Lisp_Object arg = POP; - TOP = Fget (TOP, arg, Qnil); + TOP_LVALUE = Fget (TOP, arg, Qnil); break; } case Bsub1: + { #ifdef HAVE_BIGNUM - TOP = Fsub1 (TOP); + TOP_LVALUE = Fsub1 (TOP); #else - TOP = INTP (TOP) ? INT_MINUS1 (TOP) : Fsub1 (TOP); + Lisp_Object arg = TOP; + TOP_LVALUE = INTP (arg) ? INT_MINUS1 (arg) : Fsub1 (arg); #endif break; - + } case Badd1: + { #ifdef HAVE_BIGNUM - TOP = Fadd1 (TOP); + TOP_LVALUE = Fadd1 (TOP); #else - TOP = INTP (TOP) ? INT_PLUS1 (TOP) : Fadd1 (TOP); + Lisp_Object arg = TOP; + TOP_LVALUE = INTP (arg) ? INT_PLUS1 (arg) : Fadd1 (arg); #endif break; - + } case Beqlsign: { Lisp_Object arg = POP; - TOP = bytecode_arithcompare (TOP, arg) == 0 ? Qt : Qnil; + TOP_LVALUE = bytecode_arithcompare (TOP, arg) == 0 ? Qt : Qnil; break; } case Bgtr: { Lisp_Object arg = POP; - TOP = bytecode_arithcompare (TOP, arg) > 0 ? Qt : Qnil; + TOP_LVALUE = bytecode_arithcompare (TOP, arg) > 0 ? Qt : Qnil; break; } case Blss: { Lisp_Object arg = POP; - TOP = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil; + TOP_LVALUE = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil; break; } case Bleq: { Lisp_Object arg = POP; - TOP = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil; + TOP_LVALUE = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil; break; } case Bgeq: { Lisp_Object arg = POP; - TOP = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil; + TOP_LVALUE = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil; break; } case Bnegate: - TOP = bytecode_negate (TOP); + TOP_LVALUE = bytecode_negate (TOP); break; case Bnconc: DISCARD (1); /* nconc2 GCPROs before calling this. */ /* GCPRO_STACK; */ - TOP = bytecode_nconc2 (&TOP); + TOP_LVALUE = TOP; /* Ignore multiple values. */ + TOP_LVALUE = bytecode_nconc2 (TOP_ADDRESS); break; case Bplus: ＠＠ -1199,9 +1248,9 ＠＠ Lisp_Object arg2 = POP; Lisp_Object arg1 = TOP; #ifdef HAVE_BIGNUM - TOP = bytecode_arithop (arg1, arg2, opcode); + TOP_LVALUE = bytecode_arithop (arg1, arg2, opcode); #else - TOP = INTP (arg1) && INTP (arg2) ? + TOP_LVALUE = INTP (arg1) && INTP (arg2) ? INT_PLUS (arg1, arg2) : bytecode_arithop (arg1, arg2, opcode); #endif ＠＠ -1213,9 +1262,9 ＠＠ Lisp_Object arg2 = POP; Lisp_Object arg1 = TOP; #ifdef HAVE_BIGNUM - TOP = bytecode_arithop (arg1, arg2, opcode); + TOP_LVALUE = bytecode_arithop (arg1, arg2, opcode); #else - TOP = INTP (arg1) && INTP (arg2) ? + TOP_LVALUE = INTP (arg1) && INTP (arg2) ? INT_MINUS (arg1, arg2) : bytecode_arithop (arg1, arg2, opcode); #endif ＠＠ -1228,7 +1277,7 ＠＠ case Bmin: { Lisp_Object arg = POP; - TOP = bytecode_arithop (TOP, arg, opcode); + TOP_LVALUE = bytecode_arithop (TOP, arg, opcode); break; } ＠＠ -1239,7 +1288,8 ＠＠ case Binsert: /* Says it can GC. */ /* GCPRO_STACK; */ - TOP = Finsert (1, &TOP); + TOP_LVALUE = TOP; /* Ignore multiple values. */ + TOP_LVALUE = Finsert (1, TOP_ADDRESS); break; case BinsertN: ＠＠ -1247,20 +1297,21 ＠＠ DISCARD (n - 1); /* See Binsert. */ /* GCPRO_STACK; */ - TOP = Finsert (n, &TOP); + TOP_LVALUE = TOP; /* Ignore multiple values. */ + TOP_LVALUE = Finsert (n, TOP_ADDRESS); break; case Baref: { Lisp_Object arg = POP; - TOP = Faref (TOP, arg); + TOP_LVALUE = Faref (TOP, arg); break; } case Bmemq: { Lisp_Object arg = POP; - TOP = Fmemq (TOP, arg); + TOP_LVALUE = Fmemq (TOP, arg); break; } ＠＠ -1269,7 +1320,7 ＠＠ Lisp_Object arg = POP; /* Fset may call magic handlers */ /* GCPRO_STACK; */ - TOP = Fset (TOP, arg); + TOP_LVALUE = Fset (TOP, arg); break; } ＠＠ -1278,21 +1329,21 ＠＠ Lisp_Object arg = POP; /* Can QUIT, so can GC, right? */ /* GCPRO_STACK; */ - TOP = Fequal (TOP, arg); + TOP_LVALUE = Fequal (TOP, arg); break; } case Bnthcdr: { Lisp_Object arg = POP; - TOP = Fnthcdr (TOP, arg); + TOP_LVALUE = Fnthcdr (TOP, arg); break; } case Belt: { Lisp_Object arg = POP; - TOP = Felt (TOP, arg); + TOP_LVALUE = Felt (TOP, arg); break; } ＠＠ -1301,12 +1352,12 ＠＠ Lisp_Object arg = POP; /* Can QUIT, so can GC, right? */ /* GCPRO_STACK; */ - TOP = Fmember (TOP, arg); + TOP_LVALUE = Fmember (TOP, arg); break; } case Bgoto_char: - TOP = Fgoto_char (TOP, Qnil); + TOP_LVALUE = Fgoto_char (TOP, Qnil); break; case Bcurrent_buffer: ＠＠ -1321,7 +1372,7 ＠＠ /* #### WAG: set-buffer may cause Fset's of buffer locals Didn't prevent crash. :-( */ /* GCPRO_STACK; */ - TOP = Fset_buffer (TOP); + TOP_LVALUE = Fset_buffer (TOP); break; case Bpoint_max: ＠＠ -1337,41 +1388,41 ＠＠ Lisp_Object arg = POP; /* Can QUIT, so can GC, right? */ /* GCPRO_STACK; */ - TOP = Fskip_chars_forward (TOP, arg, Qnil); + TOP_LVALUE = Fskip_chars_forward (TOP, arg, Qnil); break; } case Bassq: { Lisp_Object arg = POP; - TOP = Fassq (TOP, arg); + TOP_LVALUE = Fassq (TOP, arg); break; } case Bsetcar: { Lisp_Object arg = POP; - TOP = Fsetcar (TOP, arg); + TOP_LVALUE = Fsetcar (TOP, arg); break; } case Bsetcdr: { Lisp_Object arg = POP; - TOP = Fsetcdr (TOP, arg); + TOP_LVALUE = Fsetcdr (TOP, arg); break; } case Bnreverse: - TOP = bytecode_nreverse (TOP); + TOP_LVALUE = bytecode_nreverse (TOP); break; case Bcar_safe: - TOP = CONSP (TOP) ? XCAR (TOP) : Qnil; + TOP_LVALUE = CONSP (TOP) ? XCAR (TOP) : Qnil; break; case Bcdr_safe: - TOP = CONSP (TOP) ? XCDR (TOP) : Qnil; + TOP_LVALUE = CONSP (TOP) ? XCDR (TOP) : Qnil; break; } ＠＠ -1390,6 +1441,8 ＠＠ const Opbyte *UNUSED (program_ptr), Opcode opcode) { + REGISTER int n; + switch (opcode) { ＠＠ -1403,7 +1456,7 ＠＠ int count = specpdl_depth (); record_unwind_protect (save_window_excursion_unwind, call1 (Qcurrent_window_configuration, Qnil)); - TOP = Fprogn (TOP); + TOP_LVALUE = Fprogn (TOP); unbind_to (count); break; } ＠＠ -1416,14 +1469,14 ＠＠ case Bcatch: { Lisp_Object arg = POP; - TOP = internal_catch (TOP, Feval, arg, 0, 0, 0); + TOP_LVALUE = internal_catch (TOP, Feval, arg, 0, 0, 0); break; } case Bskip_chars_backward: { Lisp_Object arg = POP; - TOP = Fskip_chars_backward (TOP, arg, Qnil); + TOP_LVALUE = Fskip_chars_backward (TOP, arg, Qnil); break; } ＠＠ -1435,7 +1488,7 ＠＠ { Lisp_Object arg2 = POP; /* handlers */ Lisp_Object arg1 = POP; /* bodyform */ - TOP = condition_case_3 (arg1, TOP, arg2); + TOP_LVALUE = condition_case_3 (arg1, TOP, arg2); break; } ＠＠ -1443,51 +1496,51 ＠＠ { Lisp_Object arg2 = POP; Lisp_Object arg1 = POP; - TOP = Fset_marker (TOP, arg1, arg2); + TOP_LVALUE = Fset_marker (TOP, arg1, arg2); break; } case Brem: { Lisp_Object arg = POP; - TOP = Frem (TOP, arg); + TOP_LVALUE = Frem (TOP, arg); break; } case Bmatch_beginning: - TOP = Fmatch_beginning (TOP); + TOP_LVALUE = Fmatch_beginning (TOP); break; case Bmatch_end: - TOP = Fmatch_end (TOP); + TOP_LVALUE = Fmatch_end (TOP); break; case Bupcase: - TOP = Fupcase (TOP, Qnil); + TOP_LVALUE = Fupcase (TOP, Qnil); break; case Bdowncase: - TOP = Fdowncase (TOP, Qnil); + TOP_LVALUE = Fdowncase (TOP, Qnil); break; case Bfset: { Lisp_Object arg = POP; - TOP = Ffset (TOP, arg); + TOP_LVALUE = Ffset (TOP, arg); break; } case Bstring_equal: { Lisp_Object arg = POP; - TOP = Fstring_equal (TOP, arg); + TOP_LVALUE = Fstring_equal (TOP, arg); break; } case Bstring_lessp: { Lisp_Object arg = POP; - TOP = Fstring_lessp (TOP, arg); + TOP_LVALUE = Fstring_lessp (TOP, arg); break; } ＠＠ -1495,7 +1548,7 ＠＠ { Lisp_Object arg2 = POP; Lisp_Object arg1 = POP; - TOP = Fsubstring (TOP, arg1, arg2); + TOP_LVALUE = Fsubstring (TOP, arg1, arg2); break; } ＠＠ -1504,11 +1557,11 ＠＠ break; case Bchar_after: - TOP = Fchar_after (TOP, Qnil); + TOP_LVALUE = Fchar_after (TOP, Qnil); break; case Bindent_to: - TOP = Findent_to (TOP, Qnil, Qnil); + TOP_LVALUE = Findent_to (TOP, Qnil, Qnil); break; case Bwiden: ＠＠ -1549,56 +1602,56 ＠＠ break; case Bforward_char: - TOP = Fforward_char (TOP, Qnil); + TOP_LVALUE = Fforward_char (TOP, Qnil); break; case Bforward_word: - TOP = Fforward_word (TOP, Qnil); + TOP_LVALUE = Fforward_word (TOP, Qnil); break; case Bforward_line: - TOP = Fforward_line (TOP, Qnil); + TOP_LVALUE = Fforward_line (TOP, Qnil); break; case Bchar_syntax: - TOP = Fchar_syntax (TOP, Qnil); + TOP_LVALUE = Fchar_syntax (TOP, Qnil); break; case Bbuffer_substring: { Lisp_Object arg = POP; - TOP = Fbuffer_substring (TOP, arg, Qnil); + TOP_LVALUE = Fbuffer_substring (TOP, arg, Qnil); break; } case Bdelete_region: { Lisp_Object arg = POP; - TOP = Fdelete_region (TOP, arg, Qnil); + TOP_LVALUE = Fdelete_region (TOP, arg, Qnil); break; } case Bnarrow_to_region: { Lisp_Object arg = POP; - TOP = Fnarrow_to_region (TOP, arg, Qnil); + TOP_LVALUE = Fnarrow_to_region (TOP, arg, Qnil); break; } case Bend_of_line: - TOP = Fend_of_line (TOP, Qnil); + TOP_LVALUE = Fend_of_line (TOP, Qnil); break; case Btemp_output_buffer_setup: temp_output_buffer_setup (TOP); - TOP = Vstandard_output; + TOP_LVALUE = Vstandard_output; break; case Btemp_output_buffer_show: { Lisp_Object arg = POP; temp_output_buffer_show (TOP, Qnil); - TOP = arg; + TOP_LVALUE = arg; /* GAG ME!! */ /* pop binding of standard-output */ unbind_to (specpdl_depth() - 1); ＠＠ -1608,38 +1661,78 ＠＠ case Bold_eq: { Lisp_Object arg = POP; - TOP = HACKEQ_UNSAFE (TOP, arg) ? Qt : Qnil; + TOP_LVALUE = HACKEQ_UNSAFE (TOP, arg) ? Qt : Qnil; break; } case Bold_memq: { Lisp_Object arg = POP; - TOP = Fold_memq (TOP, arg); + TOP_LVALUE = Fold_memq (TOP, arg); break; } case Bold_equal: { Lisp_Object arg = POP; - TOP = Fold_equal (TOP, arg); + TOP_LVALUE = Fold_equal (TOP, arg); break; } case Bold_member: { Lisp_Object arg = POP; - TOP = Fold_member (TOP, arg); + TOP_LVALUE = Fold_member (TOP, arg); break; } case Bold_assq: { Lisp_Object arg = POP; - TOP = Fold_assq (TOP, arg); + TOP_LVALUE = Fold_assq (TOP, arg); break; } + case Bbind_multiple_value_limits: + { + Lisp_Object upper = POP, first = TOP, speccount; + + CHECK_NATNUM (upper); + CHECK_NATNUM (first); + + speccount = make_int (bind_multiple_value_limits (XINT (first), + XINT (upper))); + PUSH (upper); + PUSH (speccount); + break; + } + + case Bmultiple_value_call: + { + n = XINT (POP); + DISCARD_PRESERVING_MULTIPLE_VALUES (n - 1); + /* Discard multiple values for the first (function) argument: */ + TOP_LVALUE = TOP; + TOP_LVALUE = multiple_value_call (n, TOP_ADDRESS); + break; + } + + case Bmultiple_value_list_internal: + { + DISCARD_PRESERVING_MULTIPLE_VALUES (3); + TOP_LVALUE = multiple_value_list_internal (4, TOP_ADDRESS); + break; + } + + case Bthrow: + { + Lisp_Object arg = POP_WITH_MULTIPLE_VALUES; + + /* We never throw to a catch tag that is a multiple value: */ + throw_or_bomb_out (TOP, arg, 0, Qnil, Qnil); + break; + } + default: ABORT(); break; diff -r e3feb329bda9 -r 8f1ee2d15784 src/callint.c --- a/src/callint.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/callint.c Sun Aug 16 20:55:49 2009 +0100 ＠＠ -400,7 +400,7 ＠＠ GCPRO3 (function, specs, input); /* Compute the arg values using the user's expression. */ - specs = Feval (specs); + specs = IGNORE_MULTIPLE_VALUES (Feval (specs)); if (EQ (record_flag, Qlambda)) /* XEmacs addition */ { UNGCPRO; ＠＠ -916,7 +916,7 ＠＠ { Lisp_Object tem = call1 (Qread_expression, PROMPT ()); /* visargs[argnum] = Fprin1_to_string (tem, Qnil); */ - args[argnum] = Feval (tem); + args[argnum] = IGNORE_MULTIPLE_VALUES (Feval (tem)); arg_from_tty = 1; break; } diff -r e3feb329bda9 -r 8f1ee2d15784 src/device-x.c --- a/src/device-x.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/device-x.c Sun Aug 16 20:55:49 2009 +0100 ＠＠ -1280,7 +1280,8 ＠＠ enqueue_magic_eval_event (io_error_delete_device, dev); DEVICE_X_BEING_DELETED (d) = 1; } - Fthrow (Qtop_level, Qnil); + + throw_or_bomb_out (Qtop_level, Qnil, 0, Qnil, Qnil); RETURN_NOT_REACHED (0); } diff -r e3feb329bda9 -r 8f1ee2d15784 src/eval.c --- a/src/eval.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/eval.c Sun Aug 16 20:55:49 2009 +0100 ＠＠ -241,6 +241,16 ＠＠ Lisp_Object Vpending_warnings, Vpending_warnings_tail; Lisp_Object Qif; +Lisp_Object Qthrow; +Lisp_Object Qobsolete_throw; + +static int first_desired_multiple_value; +/* Used outside this file, somewhat uncleanly, in the IGNORE_MULTIPLE_VALUES + macro: */ +int multiple_value_current_limit; + +Fixnum Vmultiple_values_limit; + /* Flags specifying which operations are currently inhibited. */ int inhibit_flags; ＠＠ -820,6 +830,9 ＠＠ The remaining ARGS are not evalled at all. If all args return nil, return nil. +Any multiple values from the last form, and only from the last form, are +passed back. See `values' and `multiple-value-bind'. + arguments: (&rest ARGS) */ (args)) ＠＠ -827,13 +840,21 ＠＠ /* This function can GC */ REGISTER Lisp_Object val; - LIST_LOOP_2 (arg, args) - { - if (!NILP (val = Feval (arg))) - return val; - } - - return Qnil; + LIST_LOOP_3 (arg, args, tail) + { + if (!NILP (IGNORE_MULTIPLE_VALUES (val = Feval (arg)))) + { + if (NILP (XCDR (tail))) + { + /* Pass back multiple values if this is the last one: */ + return val; + } + + return IGNORE_MULTIPLE_VALUES (val); + } + } + + return val; } DEFUN ("and", Fand, 0, UNEVALLED, 0, /* ＠＠ -841,6 +862,9 ＠＠ The remaining ARGS are not evalled at all. If no arg yields nil, return the last arg's value. +Any multiple values from the last form, and only from the last form, are +passed back. See `values' and `multiple-value-bind'. + arguments: (&rest ARGS) */ (args)) ＠＠ -848,10 +872,18 ＠＠ /* This function can GC */ REGISTER Lisp_Object val = Qt; - LIST_LOOP_2 (arg, args) - { - if (NILP (val = Feval (arg))) - return val; + LIST_LOOP_3 (arg, args, tail) + { + if (NILP (IGNORE_MULTIPLE_VALUES (val = Feval (arg)))) + { + if (NILP (XCDR (tail))) + { + /* Pass back any multiple values for the last form: */ + return val; + } + + return Qnil; + } } return val; ＠＠ -872,7 +904,7 ＠＠ Lisp_Object then_form = XCAR (XCDR (args)); Lisp_Object else_forms = XCDR (XCDR (args)); - if (!NILP (Feval (condition))) + if (!NILP (IGNORE_MULTIPLE_VALUES (Feval (condition)))) return Feval (then_form); else return Fprogn (else_forms); ＠＠ -935,11 +967,12 ＠＠ LIST_LOOP_2 (clause, args) { CHECK_CONS (clause); - if (!NILP (val = Feval (XCAR (clause)))) + if (!NILP (val = IGNORE_MULTIPLE_VALUES (Feval (XCAR (clause))))) { if (!NILP (clause = XCDR (clause))) { CHECK_TRUE_LIST (clause); + /* Pass back any multiple values here: */ val = Fprogn (clause); } return val; ＠＠ -988,7 +1021,7 ＠＠ Lisp_Object val; struct gcpro gcpro1; - val = Feval (XCAR (args)); + val = IGNORE_MULTIPLE_VALUES (Feval (Fcar (args))); GCPRO1 (val); ＠＠ -1017,7 +1050,9 ＠＠ Feval (XCAR (args)); args = XCDR (args); - val = Feval (XCAR (args)); + + val = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args))); + args = XCDR (args); GCPRO1 (val); ＠＠ -1062,7 +1097,7 ＠＠ else { CHECK_CONS (tem); - value = Feval (XCAR (tem)); + value = IGNORE_MULTIPLE_VALUES (Feval (XCAR (tem))); if (!NILP (XCDR (tem))) sferror ("`let' bindings can have only one value-form", var); ＠＠ -1120,7 +1155,7 ＠＠ else { CHECK_CONS (tem); - *value = Feval (XCAR (tem)); + *value = IGNORE_MULTIPLE_VALUES (Feval (XCAR (tem))); gcpro1.nvars = idx; if (!NILP (XCDR (tem))) ＠＠ -1157,7 +1192,7 ＠＠ Lisp_Object test = XCAR (args); Lisp_Object body = XCDR (args); - while (!NILP (Feval (test))) + while (!NILP (IGNORE_MULTIPLE_VALUES (Feval (test)))) { QUIT; Fprogn (body); ＠＠ -1189,6 +1224,7 ＠＠ GC_PROPERTY_LIST_LOOP_3 (symbol, val, args) { val = Feval (val); + val = IGNORE_MULTIPLE_VALUES (val); Fset (symbol, val); retval = val; } ＠＠ -1311,7 +1347,7 ＠＠ { struct gcpro gcpro1; GCPRO1 (val); - val = Feval (val); + val = IGNORE_MULTIPLE_VALUES (Feval (val)); Fset_default (sym, val); UNGCPRO; } ＠＠ -1361,6 +1397,8 ＠＠ GCPRO1 (val); + val = IGNORE_MULTIPLE_VALUES (val); + Fset_default (sym, val); UNGCPRO; ＠＠ -1663,10 +1701,10 ＠＠ LONGJMP (c->jmp, 1); } -static DECLARE_DOESNT_RETURN (throw_or_bomb_out (Lisp_Object, Lisp_Object, int, - Lisp_Object, Lisp_Object)); - -static DOESNT_RETURN +DECLARE_DOESNT_RETURN (throw_or_bomb_out (Lisp_Object, Lisp_Object, int, + Lisp_Object, Lisp_Object)); + +DOESNT_RETURN throw_or_bomb_out (Lisp_Object tag, Lisp_Object val, int bomb_out_p, Lisp_Object sig, Lisp_Object data) { ＠＠ -1739,12 +1777,29 ＠＠ condition_case_1). See below for more info. */ -DEFUN_NORETURN ("throw", Fthrow, 2, 2, 0, /* +DEFUN_NORETURN ("throw", Fthrow, 2, UNEVALLED, 0, /* Throw to the catch for TAG and return VALUE from it. -Both TAG and VALUE are evalled. Tags are the same iff they are `eq'. -*/ - (tag, value)) -{ + +Both TAG and VALUE are evalled, and multiple values in VALUE will be passed +back. Tags are the same if and only if they are `eq'. + +arguments: (TAG VALUE) +*/ + (args)) +{ + int nargs; + Lisp_Object tag, value; + + GET_LIST_LENGTH (args, nargs); + if (nargs != 2) + { + Fsignal (Qwrong_number_of_arguments, list2 (Qthrow, make_int (nargs))); + } + + tag = IGNORE_MULTIPLE_VALUES (Feval (XCAR(args))); + + value = Feval (XCAR (XCDR (args))); + throw_or_bomb_out (tag, value, 0, Qnil, Qnil); /* Doesn't return */ RETURN_NOT_REACHED (Qnil); } ＠＠ -2360,7 +2415,8 ＠＠ else if (EQ (handler_data, Qt)) { UNGCPRO; - return Fthrow (handlers, Fcons (error_symbol, data)); + throw_or_bomb_out (handlers, Fcons (error_symbol, data), + 0, Qnil, Qnil); } /* `error' is used similarly to the way `t' is used, but in addition it invokes the debugger if debug_on_error. ＠＠ -2379,7 +2435,7 ＠＠ return return_from_signal (tem); tem = Fcons (error_symbol, data); - return Fthrow (handlers, tem); + throw_or_bomb_out (handlers, tem, 0, Qnil, Qnil); } else { ＠＠ -2403,7 +2459,7 ＠＠ /* Doesn't return */ tem = Fcons (Fcons (error_symbol, data), Fcdr (clause)); - return Fthrow (handlers, tem); + throw_or_bomb_out (handlers, tem, 0, Qnil, Qnil); } } } ＠＠ -3665,7 +3721,7 ＠＠ { LIST_LOOP_2 (arg, original_args) { - *p++ = Feval (arg); + *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); gcpro1.nvars++; } } ＠＠ -3696,7 +3752,7 ＠＠ { LIST_LOOP_2 (arg, original_args) { - *p++ = Feval (arg); + *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); gcpro1.nvars++; } } ＠＠ -3729,7 +3785,7 ＠＠ { LIST_LOOP_2 (arg, original_args) { - *p++ = Feval (arg); + *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); gcpro1.nvars++; } } ＠＠ -3778,7 +3834,7 ＠＠ { LIST_LOOP_2 (arg, original_args) { - *p++ = Feval (arg); + *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); gcpro1.nvars++; } } ＠＠ -3958,6 +4014,12 ＠＠ } else if (max_args == UNEVALLED) /* Can't funcall a special form */ { + /* Ugh, ugh, ugh. */ + if (EQ (fun, XSYMBOL_FUNCTION (Qthrow))) + { + args[0] = Qobsolete_throw; + goto retry; + } goto invalid_function; } else ＠＠ -4238,7 +4300,6 ＠＠ } } - /* Apply lambda list FUN to the NARGS evaluated arguments in ARGS and return the result of evaluation. */ ＠＠ -4296,6 +4357,590 ＠＠ } +/* Multiple values. + + A multiple value object is returned by #'values if: + + -- The number of arguments to #'values is not one, and: + -- Some special form in the call stack is prepared to handle more than + one multiple value. + + The return value of #'values-list is analogous to that of #'values. + + Henry Baker, in https://eprints.kfupm.edu.sa/31898/1/31898.pdf ("CONS + Should not CONS its Arguments, or, a Lazy Alloc is a Smart Alloc", ACM + Sigplan Notices 27,3 (March 1992),24-34.) says it should be possible to + allocate Common Lisp multiple-value objects on the stack, but this + assumes that variable-length records can be allocated on the stack, + something not true for us. As far as I can tell, it also ignores the + contexts where multiple-values need to be thrown, or maybe it thinks such + objects should be converted to heap allocation at that point. + + The specific multiple values saved and returned depend on how many + multiple-values special forms in the stack are interested in; for + example, if #'multiple-value-call is somewhere in the call stack, all + values passed to #'values will be saved and returned. If an expansion of + #'multiple-value-setq with 10 SYMS is the only part of the call stack + interested in multiple values, then a maximum of ten multiple values will + be saved and returned. + + (#'throw passes back multiple values in its VALUE argument; this is why + we can't just take the details of the most immediate + #'multiple-value-{whatever} call to work out which values to save, we + need to look at the whole stack, or, equivalently, the dynamic variables + we set to reflect the whole stack.) + + The first value passed to #'values will always be saved, since that is + needed to convert a multiple value object into a single value object, + something that is normally necessary independent of how many functions in + the call stack are interested in multiple values. + + However many values (for values of "however many" that are not one) are + saved and restored, the multiple value object knows how many arguments it + would contain were none to have been discarded, and will indicate this + on being printed from within GDB. + + In lisp-interaction-mode, no multiple values should be discarded (unless + they need to be for the sake of the correctness of the program); + #'eval-interactive-with-multiple-value-list in lisp-mode.el wraps its + #'eval calls with #'multiple-value-list calls to avoid this. This means + that there is a small performance and memory penalty for code evaluated + in *scratch*; use M-: EXPRESSION RET if you really need to avoid + this. Lisp code execution that is not ultimately from hitting C-j in + *scratch*--that is, the vast vast majority of Lisp code execution--does + not have this penalty. + + Probably the most important aspect of multiple values is stated with + admirable clarity by CLTL2: + + "No matter how many values a form produces, if the form is an argument + form in a function call, then exactly one value (the first one) is + used." + + This means that most contexts, most of the time, will never see multiple + values. There are important exceptions; search the web for that text in + quotation marks and read the related chapter. This code handles all of + them, to my knowledge. Aidan Kehoe, Mon Mar 16 00:17:39 GMT 2009. */ + +static Lisp_Object +make_multiple_value (Lisp_Object first_value, Elemcount count, + Elemcount first_desired, Elemcount upper_limit) +{ + Bytecount sizem; + struct multiple_value *mv; + Elemcount i, allocated_count; + + assert (count != 1); + + if (1 != upper_limit && (0 == first_desired)) + { + /* We always allocate element zero, and that's taken into account when + working out allocated_count: */ + first_desired = 1; + } + + if (first_desired >= count) + { + /* We can't pass anything back that our caller is interested in. Only + allocate for the first argument. */ + allocated_count = 1; + } + else + { + allocated_count = 1 + ((upper_limit > count ? count : upper_limit) + - first_desired); + } + + sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (multiple_value, + Lisp_Object, + contents, allocated_count); + mv = (multiple_value *) BASIC_ALLOC_LCRECORD (sizem, + &lrecord_multiple_value); + + mv->count = count; + mv->first_desired = first_desired; + mv->allocated_count = allocated_count; + mv->contents[0] = first_value; + + for (i = first_desired; i < upper_limit && i < count; ++i) + { + mv->contents[1 + (i - first_desired)] = Qunbound; + } + + return wrap_multiple_value (mv); +} + +void +multiple_value_aset (Lisp_Object obj, Elemcount index, Lisp_Object value) +{ + struct multiple_value *mv = XMULTIPLE_VALUE (obj); + Elemcount first_desired = mv->first_desired; + Elemcount allocated_count = mv->allocated_count; + + if (index != 0 && + (index < first_desired || index >= (first_desired + allocated_count))) + { + args_out_of_range (make_int (first_desired), + make_int (first_desired + allocated_count)); + } + + mv->contents[index == 0 ? 0 : 1 + (index - first_desired)] = value; +} + +Lisp_Object +multiple_value_aref (Lisp_Object obj, Elemcount index) +{ + struct multiple_value *mv = XMULTIPLE_VALUE (obj); + Elemcount first_desired = mv->first_desired; + Elemcount allocated_count = mv->allocated_count; + + if (index != 0 && + (index < first_desired || index >= (first_desired + allocated_count))) + { + args_out_of_range (make_int (first_desired), + make_int (first_desired + allocated_count)); + } + + return mv->contents[index == 0 ? 0 : 1 + (index - first_desired)]; +} + +static void +print_multiple_value (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) +{ + struct multiple_value *mv = XMULTIPLE_VALUE (obj); + Elemcount first_desired = mv->first_desired; + Elemcount allocated_count = mv->allocated_count; + Elemcount count = mv->count, index; + + if (print_readably) + { + printing_unreadable_object ("multiple values"); + } + + if (0 == count) + { + write_c_string (printcharfun, "#<zero-length multiple value>"); + } + + for (index = 0; index < count;) + { + if (index != 0 && + (index < first_desired || + index >= (first_desired + (allocated_count - 1)))) + { + write_fmt_string (printcharfun, "#<discarded-multiple-value %d>", + index); + } + else + { + print_internal (multiple_value_aref (obj, index), + printcharfun, escapeflag); + } + + ++index; + + if (count > 1 && index < count) + { + write_c_string (printcharfun, " ;\n"); + } + } +} + +static Lisp_Object +mark_multiple_value (Lisp_Object obj) +{ + struct multiple_value *mv = XMULTIPLE_VALUE (obj); + Elemcount index, allocated_count = mv->allocated_count; + + for (index = 0; index < allocated_count; ++index) + { + mark_object (mv->contents[index]); + } + + return Qnil; +} + +static Bytecount +size_multiple_value (const void *lheader) +{ + return FLEXIBLE_ARRAY_STRUCT_SIZEOF (struct multiple_value, + Lisp_Object, contents, + ((struct multiple_value *) lheader)-> + allocated_count); +} + +static const struct memory_description multiple_value_description[] = { + { XD_LONG, offsetof (struct multiple_value, count) }, + { XD_ELEMCOUNT, offsetof (struct multiple_value, allocated_count) }, + { XD_LONG, offsetof (struct multiple_value, first_desired) }, + { XD_LISP_OBJECT_ARRAY, offsetof (struct multiple_value, contents), + XD_INDIRECT (1, 0) }, + { XD_END } +}; + +DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("multiple-value", multiple_value, + 1, /*dumpable-flag*/ + mark_multiple_value, + print_multiple_value, 0, + 0, /* No equal method. */ + 0, /* No hash method. */ + multiple_value_description, + size_multiple_value, + struct multiple_value); + +/* Given that FIRST and UPPER are the inclusive lower and exclusive upper + bounds for the multiple values we're interested in, modify (or don't) the + special variables used to indicate this to #'values and #'values-list. + Returns the specpdl_depth() value before any modification. */ +int +bind_multiple_value_limits (int first, int upper) +{ + int result = specpdl_depth(); + + if (!(upper > first)) + { + invalid_argument ("MULTIPLE-VALUE-UPPER-LIMIT must be greater than " + " FIRST-DESIRED-MULTIPLE-VALUE", Qunbound); + } + + if (upper > Vmultiple_values_limit) + { + args_out_of_range (make_int (upper), make_int (Vmultiple_values_limit)); + } + + /* In the event that something back up the stack wants more multiple + values than we do, we need to keep its figures for + first_desired_multiple_value or multiple_value_current_limit both. It + may be that the form will throw past us. + + If first_desired_multiple_value is zero, this means it hasn't ever been + bound, and any value we have for first is appropriate to use. + + Zeroth element is always saved, no need to note that: */ + if (0 == first) + { + first = 1; + } + + if (0 == first_desired_multiple_value + || first < first_desired_multiple_value) + { + internal_bind_int (&first_desired_multiple_value, first); + } + + if (upper > multiple_value_current_limit) + { + internal_bind_int (&multiple_value_current_limit, upper); + } + + return result; +} + +Lisp_Object +multiple_value_call (int nargs, Lisp_Object *args) +{ + /* The argument order here is horrible: */ + int i, speccount = XINT (args[3]); + Lisp_Object result = Qnil, head = Fcons (args[0], Qnil), list_offset; + struct gcpro gcpro1, gcpro2; + Lisp_Object apply_args[2]; + + GCPRO2 (head, result); + list_offset = head; + + assert (!(MULTIPLE_VALUEP (args[0]))); + CHECK_FUNCTION (args[0]); + + /* Start at 4, to ignore the function, the speccount, and the arguments to + multiple-values-limit (which we don't discard because + #'multiple-value-list-internal needs them): */ + for (i = 4; i < nargs; ++i) + { + result = args[i]; + if (MULTIPLE_VALUEP (result)) + { + Lisp_Object val; + Elemcount i, count = XMULTIPLE_VALUE_COUNT (result); + + for (i = 0; i < count; i++) + { + val = multiple_value_aref (result, i); + assert (!UNBOUNDP (val)); + + XSETCDR (list_offset, Fcons (val, Qnil)); + list_offset = XCDR (list_offset); + } + } + else + { + XSETCDR (list_offset, Fcons (result, Qnil)); + list_offset = XCDR (list_offset); + } + } + + apply_args [0] = XCAR (head); + apply_args [1] = XCDR (head); + + unbind_to (speccount); + + RETURN_UNGCPRO (Fapply (countof(apply_args), apply_args)); +} + +DEFUN ("multiple-value-call", Fmultiple_value_call, 1, UNEVALLED, 0, /* +Call FUNCTION with arguments FORMS, using multiple values when returned. + +All of the (possibly multiple) values returned by each form in FORMS are +gathered together, and given as arguments to FUNCTION; conceptually, this +function is a version of `apply' that by-passes the multiple values +infrastructure, treating multiple values as intercalated lists. + +arguments: (FUNCTION &rest FORMS) +*/ + (args)) +{ + int listcount, i = 0, speccount; + Lisp_Object *constructed_args; + struct gcpro gcpro1; + + GET_EXTERNAL_LIST_LENGTH (args, listcount); + + constructed_args = alloca_array (Lisp_Object, listcount + 3); + + /* Fcar so we error on non-cons: */ + constructed_args[i] = IGNORE_MULTIPLE_VALUES (Feval (Fcar (args))); + + GCPRO1 (*constructed_args); + gcpro1.nvars = ++i; + + /* The argument order is horrible here. */ + constructed_args[i] = make_int (0); + gcpro1.nvars = ++i; + constructed_args[i] = make_int (Vmultiple_values_limit); + gcpro1.nvars = ++i; + + speccount = bind_multiple_value_limits (0, Vmultiple_values_limit); + constructed_args[i] = make_int (speccount); + gcpro1.nvars = ++i; + + { + LIST_LOOP_2 (elt, XCDR (args)) + { + constructed_args[i] = Feval (elt); + gcpro1.nvars = ++i; + } + } + + RETURN_UNGCPRO (multiple_value_call (listcount + 3, constructed_args)); +} + +Lisp_Object +multiple_value_list_internal (int nargs, Lisp_Object *args) +{ + int first = XINT (args[0]), upper = XINT (args[1]), + speccount = XINT(args[2]); + Lisp_Object result = Qnil; + + assert (nargs == 4); + + result = args[3]; + + unbind_to (speccount); + + if (MULTIPLE_VALUEP (result)) + { + Lisp_Object head = Fcons (Qnil, Qnil); + Lisp_Object list_offset = head, val; + Elemcount count = XMULTIPLE_VALUE_COUNT(result); + + for (; first < upper && first < count; ++first) + { + val = multiple_value_aref (result, first); + assert (!UNBOUNDP (val)); + + XSETCDR (list_offset, Fcons (val, Qnil)); + list_offset = XCDR (list_offset); + } + + return XCDR (head); + } + else + { + if (first == 0) + { + return Fcons (result, Qnil); + } + else + { + return Qnil; + } + } +} + +DEFUN ("multiple-value-list-internal", Fmultiple_value_list_internal, 3, + UNEVALLED, 0, /* +Evaluate FORM. Return a list of multiple vals reflecting the other two args. + +Don't use this. Use `multiple-value-list', the macro specified by Common +Lisp, instead. + +FIRST-DESIRED-MULTIPLE-VALUE is the first element in list of multiple values +to pass back. MULTIPLE-VALUE-UPPER-LIMIT is the exclusive upper limit on +the indexes within the values that may be passed back; this function will +never return a list longer than MULTIPLE-VALUE-UPPER-LIMIT - +FIRST-DESIRED-MULTIPLE-VALUE. It may return a list shorter than that, if +`values' or `values-list' do not supply enough elements. + +arguments: (FIRST-DESIRED-MULTIPLE-VALUE MULTIPLE-VALUE-UPPER-LIMIT FORM) +*/ + (args)) +{ + Lisp_Object argv[4]; + int first, upper; + struct gcpro gcpro1; + + argv[0] = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args))); + CHECK_NATNUM (argv[0]); + first = XINT (argv[0]); + + GCPRO1 (argv[0]); + gcpro1.nvars = 1; + + args = XCDR (args); + + argv[1] = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args))); + CHECK_NATNUM (argv[1]); + upper = XINT (argv[1]); + gcpro1.nvars = 2; + + /* The unintuitive order of things here is for the sake of the bytecode; + the alternative would be to encode the number of arguments in the + bytecode stream, which complicates things if we have more than 255 + arguments. */ + argv[2] = make_int (bind_multiple_value_limits (first, upper)); + gcpro1.nvars = 3; + args = XCDR (args); + + /* GCPROing in this function is not strictly necessary, this Feval is the + only point that may cons up data that is not immediately discarded, and + within it is the only point (in Fmultiple_value_list_internal and + multiple_value_list) that we can garbage collect. But I'm conservative, + and this function is called so rarely (only from interpreted code) that + it doesn't matter for performance. */ + argv[3] = Feval (XCAR (args)); + gcpro1.nvars = 4; + + RETURN_UNGCPRO (multiple_value_list_internal (countof (argv), argv)); +} + +DEFUN ("multiple-value-prog1", Fmultiple_value_prog1, 1, UNEVALLED, 0, /* +Similar to `prog1', but return any multiple values from the first form. +`prog1' itself will never return multiple values. + +arguments: (FIRST &rest BODY) +*/ + (args)) +{ + /* This function can GC */ + Lisp_Object val; + struct gcpro gcpro1; + + val = Feval (XCAR (args)); + + GCPRO1 (val); + + { + LIST_LOOP_2 (form, XCDR (args)) + Feval (form); + } + + RETURN_UNGCPRO (val); +} + +DEFUN ("values", Fvalues, 0, MANY, 0, /* +Return all ARGS as multiple values. + +arguments: (&rest ARGS) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object result = Qnil; + int counting = 1; + + /* Pathological cases, no need to cons up an object: */ + if (1 == nargs || 1 == multiple_value_current_limit) + { + return nargs ? args[0] : Qnil; + } + + /* If nargs is zero, this code is correct and desirable. With + #'multiple-value-call, we want zero-length multiple values in the + argument list to be discarded entirely, and we can't do this if we + transform them to nil. */ + result = make_multiple_value (nargs ? args[0] : Qnil, nargs, + first_desired_multiple_value, + multiple_value_current_limit); + + for (; counting < nargs; ++counting) + { + if (counting >= first_desired_multiple_value && + counting < multiple_value_current_limit) + { + multiple_value_aset (result, counting, args[counting]); + } + } + + return result; +} + +DEFUN ("values-list", Fvalues_list, 1, 1, 0, /* +Return all the elements of LIST as multiple values. +*/ + (list)) +{ + Lisp_Object result = Qnil; + int counting = 1, listcount; + + GET_EXTERNAL_LIST_LENGTH (list, listcount); + + /* Pathological cases, no need to cons up an object: */ + if (1 == listcount || 1 == multiple_value_current_limit) + { + return Fcar_safe (list); + } + + result = make_multiple_value (Fcar_safe (list), listcount, + first_desired_multiple_value, + multiple_value_current_limit); + + list = Fcdr_safe (list); + + { + EXTERNAL_LIST_LOOP_2 (elt, list) + { + if (counting >= first_desired_multiple_value && + counting < multiple_value_current_limit) + { + multiple_value_aset (result, counting, elt); + } + ++counting; + } + } + + return result; +} + +Lisp_Object +values2 (Lisp_Object first, Lisp_Object second) +{ + Lisp_Object argv[2]; + + argv[0] = first; + argv[1] = second; + + return Fvalues (countof (argv), argv); +} + + /************************************************************************/ /* Run hook variables in various ways. */ /************************************************************************/ ＠＠ -4968,7 +5613,7 ＠＠ p->error_conditions = error_conditions; p->data = data; - Fthrow (p->catchtag, Qnil); + throw_or_bomb_out (p->catchtag, Qnil, 0, Qnil, Qnil); RETURN_NOT_REACHED (Qnil); } ＠＠ -6555,6 +7200,7 ＠＠ syms_of_eval (void) { INIT_LRECORD_IMPLEMENTATION (subr); + INIT_LRECORD_IMPLEMENTATION (multiple_value); DEFSYMBOL (Qinhibit_quit); DEFSYMBOL (Qautoload); ＠＠ -6578,6 +7224,8 ＠＠ DEFSYMBOL (Qrun_hooks); DEFSYMBOL (Qfinalize_list); DEFSYMBOL (Qif); + DEFSYMBOL (Qthrow); + DEFSYMBOL (Qobsolete_throw); DEFSUBR (For); DEFSUBR (Fand); ＠＠ -6611,6 +7259,11 ＠＠ DEFSUBR (Fautoload); DEFSUBR (Feval); DEFSUBR (Fapply); + DEFSUBR (Fmultiple_value_call); + DEFSUBR (Fmultiple_value_list_internal); + DEFSUBR (Fmultiple_value_prog1); + DEFSUBR (Fvalues); + DEFSUBR (Fvalues_list); DEFSUBR (Ffuncall); DEFSUBR (Ffunctionp); DEFSUBR (Ffunction_min_args); ＠＠ -6636,6 +7289,9 ＠＠ debug_on_next_call = 0; lisp_eval_depth = 0; entering_debugger = 0; + + first_desired_multiple_value = 0; + multiple_value_current_limit = 1; } void ＠＠ -6805,6 +7461,14 ＠＠ */ ); Vdebugger = Qnil; + DEFVAR_CONST_INT ("multiple-values-limit", &Vmultiple_values_limit /* +The exclusive upper bound on the number of multiple values. + +This applies to `values', `values-list', `multiple-value-bind' and related +macros and special forms. +*/); + Vmultiple_values_limit = EMACS_INT_MAX > INT_MAX ? INT_MAX : EMACS_INT_MAX; + staticpro (&Vcatch_everything_tag); Vcatch_everything_tag = make_opaque (OPAQUE_CLEAR, 0); diff -r e3feb329bda9 -r 8f1ee2d15784 src/event-msw.c --- a/src/event-msw.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/event-msw.c Sun Aug 16 20:55:49 2009 +0100 ＠＠ -1769,7 +1769,7 ＠＠ return Qnil; GCPRO1 (obj); - obj = Feval (XCAR (obj)); + obj = IGNORE_MULTIPLE_VALUES (Feval (XCAR (obj))); RETURN_UNGCPRO (obj); } diff -r e3feb329bda9 -r 8f1ee2d15784 src/event-stream.c --- a/src/event-stream.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/event-stream.c Sun Aug 16 20:55:49 2009 +0100 ＠＠ -843,7 +843,7 ＠＠ call1 (Qcurrent_window_configuration, Qnil)); reset_key_echo (command_builder, 1); - help = Feval (Vhelp_form); + help = IGNORE_MULTIPLE_VALUES (Feval (Vhelp_form)); if (STRINGP (help)) internal_with_output_to_temp_buffer (build_string ("*Help*"), print_help, help, Qnil); diff -r e3feb329bda9 -r 8f1ee2d15784 src/glade.c --- a/src/glade.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/glade.c Sun Aug 16 20:55:49 2009 +0100 ＠＠ -42,7 +42,8 ＠＠ if (signal_data && signal_data[0]) { - lisp_data = Feval (Fread (build_string (signal_data))); + lisp_data + = IGNORE_MULTIPLE_VALUES (Feval (Fread (build_string (signal_data)))); } /* obj, name, func, cb_data, object_signal, after_p */ diff -r e3feb329bda9 -r 8f1ee2d15784 src/glyphs-widget.c --- a/src/glyphs-widget.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/glyphs-widget.c Sun Aug 16 20:55:49 2009 +0100 ＠＠ -222,7 +222,7 ＠＠ glyph = XSYMBOL (glyph)->value; if (CONSP (glyph)) - glyph = Feval (glyph); + glyph = IGNORE_MULTIPLE_VALUES (Feval (glyph)); /* Be really helpful to the user. */ if (VECTORP (glyph)) diff -r e3feb329bda9 -r 8f1ee2d15784 src/glyphs.c --- a/src/glyphs.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/glyphs.c Sun Aug 16 20:55:49 2009 +0100 ＠＠ -3079,7 +3079,7 ＠＠ value = XCDR (cons); CHECK_CONS (value); value = XCAR (value); - value = Feval (value); + value = IGNORE_MULTIPLE_VALUES (Feval (value)); if (NILP (value)) continue; if (!STRINGP (value) && !COLOR_SPECIFIERP (value)) diff -r e3feb329bda9 -r 8f1ee2d15784 src/gui-x.c --- a/src/gui-x.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/gui-x.c Sun Aug 16 20:55:49 2009 +0100 ＠＠ -325,8 +325,9 ＠＠ Lisp_Object wses_form = (form); \ (slot) = (NILP (wses_form) ? 0 : \ EQ (wses_form, Qt) ? 1 : \ - !NILP (in_display ? eval_within_redisplay (wses_form) \ - : Feval (wses_form))); \ + !NILP (in_display ? \ + IGNORE_MULTIPLE_VALUES (eval_within_redisplay (wses_form)) \ + : IGNORE_MULTIPLE_VALUES (Feval (wses_form)))); \ } while (0) #else /* Treat the activep slot of the menu item as a boolean */ ＠＠ -436,7 +437,7 ＠＠ #endif /* HAVE_MENUBARS */ if (!STRINGP (pgui->name)) - pgui->name = Feval (pgui->name); + pgui->name = IGNORE_MULTIPLE_VALUES (Feval (pgui->name)); CHECK_STRING (pgui->name); if (accel_p) ＠＠ -459,7 +460,7 ＠＠ suffix2 = pgui->suffix; else { - suffix2 = Feval (pgui->suffix); + suffix2 = IGNORE_MULTIPLE_VALUES (Feval (pgui->suffix)); CHECK_STRING (suffix2); } diff -r e3feb329bda9 -r 8f1ee2d15784 src/gui.c --- a/src/gui.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/gui.c Sun Aug 16 20:55:49 2009 +0100 ＠＠ -386,7 +386,6 ＠＠ gui_item_value (Lisp_Object form) { /* This function can call Lisp. */ - #ifndef ERROR_CHECK_DISPLAY /* Shortcut to avoid evaluating Qt/Qnil each time; but don't do it when error-checking so we catch unprotected eval within redisplay quicker */ ＠＠ -395,7 +394,9 ＠＠ if (EQ (form, Qt)) return 1; #endif - return !NILP (in_display ? eval_within_redisplay (form) : Feval (form)); + return !NILP (in_display ? + IGNORE_MULTIPLE_VALUES (eval_within_redisplay (form)) +: IGNORE_MULTIPLE_VALUES (Feval (form))); } /* ＠＠ -511,6 +512,7 ＠＠ if (!STRINGP (suffix)) { suffix = Feval (suffix); + suffix = IGNORE_MULTIPLE_VALUES (suffix); CHECK_STRING (suffix); } diff -r e3feb329bda9 -r 8f1ee2d15784 src/inline.c --- a/src/inline.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/inline.c Sun Aug 16 20:55:49 2009 +0100 ＠＠ -64,6 +64,7 ＠＠ #include "process.h" #include "rangetab.h" #include "specifier.h" +#include "symeval.h" #include "syntax.h" #include "window.h" diff -r e3feb329bda9 -r 8f1ee2d15784 src/lisp.h --- a/src/lisp.h Sun Aug 16 14:58:57 2009 +0100 +++ b/src/lisp.h Sun Aug 16 20:55:49 2009 +0100 ＠＠ -4269,11 +4269,15 ＠＠ EXFUN (Finteractive_p, 0); EXFUN (Fprogn, UNEVALLED); MODULE_API EXFUN (Fsignal, 2); -MODULE_API EXFUN_NORETURN (Fthrow, 2); +MODULE_API EXFUN_NORETURN (Fthrow, UNEVALLED); MODULE_API EXFUN (Fcall_with_condition_handler, MANY); EXFUN (Ffunction_max_args, 1); EXFUN (Ffunction_min_args, 1); +MODULE_API DECLARE_DOESNT_RETURN (throw_or_bomb_out (Lisp_Object, + Lisp_Object, int, + Lisp_Object, Lisp_Object)); + MODULE_API DECLARE_DOESNT_RETURN (signal_error_1 (Lisp_Object, Lisp_Object)); void maybe_signal_error_1 (Lisp_Object, Lisp_Object, Lisp_Object, Error_Behavior); diff -r e3feb329bda9 -r 8f1ee2d15784 src/lread.c --- a/src/lread.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/lread.c Sun Aug 16 20:55:49 2009 +0100 ＠＠ -372,7 +372,7 ＠＠ Lisp_Object val; GCPRO1 (reloc); - val = Feval (XCDR (acons)); + val = IGNORE_MULTIPLE_VALUES (Feval (XCDR (acons))); UNGCPRO; if (!NILP (val)) diff -r e3feb329bda9 -r 8f1ee2d15784 src/lrecord.h --- a/src/lrecord.h Sun Aug 16 14:58:57 2009 +0100 +++ b/src/lrecord.h Sun Aug 16 20:55:49 2009 +0100 ＠＠ -224,6 +224,7 ＠＠ lrecord_type_max_symbol_value_magic = lrecord_type_symbol_value_buffer_local, lrecord_type_symbol, lrecord_type_subr, + lrecord_type_multiple_value, lrecord_type_cons, lrecord_type_vector, lrecord_type_string, diff -r e3feb329bda9 -r 8f1ee2d15784 src/macros.c --- a/src/macros.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/macros.c Sun Aug 16 20:55:49 2009 +0100 ＠＠ -197,7 +197,7 ＠＠ with Qt to force an early exit. */ signal_error (Qinvalid_state, "junk in executing-macro", Qunbound); - Fthrow (Qexecute_kbd_macro, Qt); + throw_or_bomb_out (Qexecute_kbd_macro, Qt, 0, Qnil, Qnil); } diff -r e3feb329bda9 -r 8f1ee2d15784 src/menubar-gtk.c --- a/src/menubar-gtk.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/menubar-gtk.c Sun Aug 16 20:55:49 2009 +0100 ＠＠ -666,13 +666,14 ＠＠ if ((!NILP (config_tag) && NILP (Fmemq (config_tag, Vmenubar_configuration))) - || (included_spec && NILP (Feval (include_p)))) + || (included_spec && + NILP (IGNORE_MULTIPLE_VALUES (Feval (include_p))))) { return (NULL); } if (active_spec) - active_p = Feval (active_p); + active_p = IGNORE_MULTIPLE_VALUES (Feval (active_p)); gtk_widget_set_sensitive (GTK_WIDGET (menu_item), ! NILP (active_p)); } ＠＠ -853,7 +854,8 ＠＠ #ifdef HAVE_MENUBARS if ((!NILP (config_tag) && NILP (Fmemq (config_tag, Vmenubar_configuration))) - || (included_spec && NILP (Feval (include_p)))) + || (included_spec && NILP (IGNORE_MULTIPLE_VALUES (Feval (include_p))))) + { /* the include specification says to ignore this item. */ return 0; ＠＠ -866,7 +868,8 ＠＠ accel = menu_name_to_accelerator (XSTRING_DATA (name)); if (!NILP (suffix)) - suffix = Feval (suffix); + suffix = IGNORE_MULTIPLE_VALUES (Feval (suffix)); + if (!separator_string_p (XSTRING_DATA (name))) { ＠＠ -901,7 +904,7 ＠＠ } else { - selected_p = Feval (selected_p); + selected_p = IGNORE_MULTIPLE_VALUES (Feval (selected_p)); } } ＠＠ -911,7 +914,7 ＠＠ } else { - active_p = Feval (active_p); + active_p = IGNORE_MULTIPLE_VALUES (Feval (active_p)); } if (0 || diff -r e3feb329bda9 -r 8f1ee2d15784 src/menubar-msw.c --- a/src/menubar-msw.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/menubar-msw.c Sun Aug 16 20:55:49 2009 +0100 ＠＠ -326,7 +326,7 ＠＠ } if (!STRINGP (pgui_item->name)) - pgui_item->name = Feval (pgui_item->name); + pgui_item->name = IGNORE_MULTIPLE_VALUES (Feval (pgui_item->name)); if (!gui_item_active_p (gui_item)) item_info.fState = MFS_GRAYED; diff -r e3feb329bda9 -r 8f1ee2d15784 src/print.c --- a/src/print.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/print.c Sun Aug 16 20:55:49 2009 +0100 ＠＠ -821,7 +821,7 ＠＠ #endif GCPRO2 (name, val); - name = Feval (XCAR (args)); + name = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args))); CHECK_STRING (name); diff -r e3feb329bda9 -r 8f1ee2d15784 src/symbols.c --- a/src/symbols.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/symbols.c Sun Aug 16 20:55:49 2009 +0100 ＠＠ -2146,7 +2146,7 ＠＠ GC_PROPERTY_LIST_LOOP_3 (symbol, val, args) { - val = Feval (val); + val = IGNORE_MULTIPLE_VALUES (Feval (val)); Fset_default (symbol, val); retval = val; } diff -r e3feb329bda9 -r 8f1ee2d15784 src/symeval.h --- a/src/symeval.h Sun Aug 16 14:58:57 2009 +0100 +++ b/src/symeval.h Sun Aug 16 20:55:49 2009 +0100 ＠＠ -488,6 +488,83 ＠＠ void flush_all_buffer_local_cache (void); +struct multiple_value { + struct LCRECORD_HEADER header; + Elemcount count; + Elemcount allocated_count; + Elemcount first_desired; + Lisp_Object contents[1]; +}; +typedef struct multiple_value multiple_value; + +DECLARE_LRECORD (multiple_value, multiple_value); +#define MULTIPLE_VALUEP(x) RECORDP (x, multiple_value) + +#define XMULTIPLE_VALUE(x) XRECORD (x, multiple_value, multiple_value) +#define wrap_multiple_value(p) wrap_record (p, multiple_value) + +#define CHECK_MULTIPLE_VALUE(x) CHECK_RECORD (x, multiple_value) +#define CONCHECK_MULTIPLE_VALUE(x) CONCHECK_RECORD (x, multiple_value) + +#define multiple_value_count(x) ((x)->count) +#define multiple_value_allocated_count(x) ((x)->allocated_count) +#define multiple_value_first_desired(x) ((x)->first_desired) +#define multiple_value_contents(x) ((x)->contents) + +#define XMULTIPLE_VALUE_COUNT(x) multiple_value_count (XMULTIPLE_VALUE (x)) +#define XMULTIPLE_VALUE_ALLOCATED_COUNT(x) \ + multiple_value_allocated_count (XMULTIPLE_VALUE (x)) +#define XMULTIPLE_VALUE_FIRST_DESIRED(x) \ + multiple_value_first_desired (XMULTIPLE_VALUE(x)) +#define XMULTIPLE_VALUE_CONTENTS(x) multiple_value_contents (XMULTIPLE_VALUE(x)) + +Lisp_Object multiple_value_call (int nargs, Lisp_Object *args); +Lisp_Object multiple_value_list_internal (int nargs, Lisp_Object *args); + +/* It's slightly ugly to expose this here, but it does cut down the amount + of work the bytecode interpreter has to do substantially. */ +extern int multiple_value_current_limit; + +/* Bind the multiple value limits that #'values and #'values-list pay + attention to. Used by bytecode and interpreted code. */ +int bind_multiple_value_limits (int first, int upper); + +Lisp_Object multiple_value_aref (Lisp_Object, Elemcount); +void multiple_value_aset (Lisp_Object, Elemcount, Lisp_Object); + +Lisp_Object values2 (Lisp_Object first, Lisp_Object second); + +DECLARE_INLINE_HEADER ( +Lisp_Object +ignore_multiple_values (Lisp_Object obj) +) +{ + return MULTIPLE_VALUEP (obj) ? multiple_value_aref (obj, 0) : obj; +} + +#ifdef ERROR_CHECK_MULTIPLE_VALUES + +DECLARE_INLINE_HEADER ( +Lisp_Object +ignore_multiple_values_1 (Lisp_Object obj) +) +{ + if (1 == multiple_value_current_limit) + { + assert (!MULTIPLE_VALUEP (obj)); + return obj; + } + + return ignore_multiple_values (obj); +} + +#define IGNORE_MULTIPLE_VALUES(X) ignore_multiple_values_1 (X) + +#else +#define IGNORE_MULTIPLE_VALUES(X) (multiple_value_current_limit == 1 ? (X) \ +: ignore_multiple_values (X)) +#endif + END_C_DECLS #endif /* INCLUDED_symeval_h_ */ -- ¿Dónde estará ahora mi sobrino Yoghurtu Nghe, que tuvo que huir precipitadamente de la aldea por culpa de la escasez de rinocerontes? _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches

1 participants
0 comments

commit: Test the multiple-value functionality. 15 years, 4 months

Aidan Kehoe

changeset: 4679:2c64d2bbb316 tag: tip user: Aidan Kehoe <kehoea(a)parhasard.net> date: Sun Aug 16 21:00:08 2009 +0100 files: tests/ChangeLog tests/automated/lisp-tests.el description: Test the multiple-value functionality. tests/ChangeLog addition: 2009-08-16 Aidan Kehoe <kehoea(a)parhasard.net> * automated/lisp-tests.el (foo): Test the Common Lisp-compatibile multiple value functionality. diff -r b5e1d4f6b66f -r 2c64d2bbb316 tests/ChangeLog --- a/tests/ChangeLog Tue Aug 11 17:59:23 2009 +0100 +++ b/tests/ChangeLog Sun Aug 16 21:00:08 2009 +0100 ＠＠ -1,3 +1,8 ＠＠ +2009-08-16 Aidan Kehoe <kehoea(a)parhasard.net> + + * automated/lisp-tests.el (foo): + Test the Common Lisp-compatibile multiple value functionality. + 2009-08-11 Aidan Kehoe <kehoea(a)parhasard.net> * automated/lisp-tests.el: diff -r b5e1d4f6b66f -r 2c64d2bbb316 tests/automated/lisp-tests.el --- a/tests/automated/lisp-tests.el Tue Aug 11 17:59:23 2009 +0100 +++ b/tests/automated/lisp-tests.el Sun Aug 16 21:00:08 2009 +0100 ＠＠ -1939,3 +1939,140 ＠＠ (princ (list 'quote (multiple-value-list (ftruncate first)))) (princ " :two-ftruncate-result ") (princ (list 'quote (multiple-value-list (ftruncate first second)))))) + +;; Multiple value tests. + +(flet ((foo (x y) + (floor (+ x y) y)) + (foo-zero (x y) + (values (floor (+ x y) y))) + (multiple-value-function-returning-t () + (values t pi e degrees-to-radians radians-to-degrees)) + (multiple-value-function-returning-nil () + (values t pi e radians-to-degrees degrees-to-radians)) + (function-throwing-multiple-values () + (let* ((listing '(0 3 4 nil "string" symbol)) + (tail listing) + elt) + (while t + (setq tail (cdr listing) + elt (car listing) + listing tail) + (when (null elt) + (throw 'VoN61Lo4Y (multiple-value-function-returning-t))))))) + (Assert + (= (+ (floor 5 3) (floor 19 4)) (+ 1 4) 5) + "Checking that multiple values are discarded correctly as func args") + (Assert + (= 2 (length (multiple-value-list (foo 400 (1+ most-positive-fixnum))))) + "Checking multiple values are passed through correctly as return values") + (Assert + (= 1 (length (multiple-value-list + (foo-zero 400 (1+ most-positive-fixnum))))) + "Checking multiple values are discarded correctly when forced") + (Check-Error setting-constant (setq multiple-values-limit 20)) + (Assert + (equal '(-1 1) + (multiple-value-list (floor -3 4))) + "Checking #'multiple-value-list gives a sane result") + (let ((ey 40000) + (bee "this is a string") + (cee #s(hash-table size 256 data (969 ?\xF9)))) + (Assert + (equal + (multiple-value-list (values ey bee cee)) + (multiple-value-list (values-list (list ey bee cee)))) + "Checking that #'values and #'values-list are correctly related") + (Assert + (equal + (multiple-value-list (values-list (list ey bee cee))) + (multiple-value-list (apply #'values (list ey bee cee)))) + "Checking #'values-list and #'apply with #values are correctly related")) + (Assert + (= (multiple-value-call #'+ (floor 5 3) (floor 19 4)) 10) + "Checking #'multiple-value-call gives reasonable results.") + (Assert + (= (multiple-value-call (values '+ '*) (floor 5 3) (floor 19 4)) 10) + "Checking #'multiple-value-call correct when first arg multiple.") + (Assert + (= 1 (length (multiple-value-list (prog1 (floor pi) "hi there")))) + "Checking #'prog1 does not pass back multiple values") + (Assert + (= 2 (length (multiple-value-list + (multiple-value-prog1 (floor pi) "hi there")))) + "Checking #'multiple-value-prog1 passes back multiple values") + (multiple-value-bind (floored remainder this-is-nil) + (floor pi 1.0) + (Assert (= floored 3) + "Checking floored bound correctly") + (Assert (eql remainder (- pi 3.0)) + "Checking remainder bound correctly") + (Assert (null this-is-nil) + "Checking trailing arg bound but nil")) + (let ((ey 40000) + (bee "this is a string") + (cee #s(hash-table size 256 data (969 ?\xF9)))) + (multiple-value-setq (ey bee cee) + (ffloor e 1.0)) + (Assert (eql 2.0 ey) "Checking ey set correctly") + (Assert (eql bee (- e 2.0)) "Checking bee set correctly") + (Assert (null cee) "Checking cee set to nil correctly")) + (Assert + (= 3 (length (multiple-value-list (eval '(values nil t pi))))) + "Checking #'eval passes back multiple values") + (Assert + (= 2 (length (multiple-value-list (apply #'floor '(5 3))))) + "Checking #'apply passes back multiple values") + (Assert + (= 2 (length (multiple-value-list (funcall #'floor 5 3)))) + "Checking #'funcall passes back multiple values") + (Assert + (equal '(1 2) (multiple-value-list + (multiple-value-call #'floor (values 5 3)))) + "Checking #'multiple-value-call passes back multiple values correctly") + (Assert + (= 1 (length (multiple-value-list + (and (multiple-value-function-returning-nil) t)))) + "Checking multiple values from non-trailing forms discarded by #'and") + (Assert + (= 5 (length (multiple-value-list + (and t (multiple-value-function-returning-nil))))) + "Checking multiple values from final forms not discarded by #'and") + (Assert + (= 1 (length (multiple-value-list + (or (multiple-value-function-returning-t) t)))) + "Checking multiple values from non-trailing forms discarded by #'and") + (Assert + (= 5 (length (multiple-value-list + (or nil (multiple-value-function-returning-t))))) + "Checking multiple values from final forms not discarded by #'and") + (Assert + (= 1 (length (multiple-value-list + (cond ((multiple-value-function-returning-t)))))) + "Checking cond doesn't pass back multiple values in tests.") + (Assert + (equal (list t pi e degrees-to-radians radians-to-degrees) + (multiple-value-list + (cond (t (multiple-value-function-returning-nil))))) + "Checking cond passes back multiple values in clauses.") + (Assert + (= 1 (length (multiple-value-list + (prog1 (multiple-value-function-returning-nil))))) + "Checking prog1 discards multiple values correctly.") + (Assert + (= 5 (length (multiple-value-list + (multiple-value-prog1 + (multiple-value-function-returning-nil))))) + "Checking multiple-value-prog1 passes back multiple values correctly.") + (Assert + (equal (list t pi e degrees-to-radians radians-to-degrees) + (multiple-value-list + (catch 'VoN61Lo4Y (function-throwing-multiple-values))))) + (Assert + (equal (list t pi e radians-to-degrees degrees-to-radians) + (multiple-value-list + (loop + for eye in `(a b c d ,e f g ,nil ,pi) + do (when (null eye) + (return (multiple-value-function-returning-t)))))) + "Checking #'loop passes back multiple values correctly.")) _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches

1 participants
0 comments

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

2003

XEmacs-Patches August 2009