It struck me as odd that there was no way to implement something analagous to the Common Lisp Cookbook #'replace-all in XEmacs, because there was nothing (apart from #'write-char) which could write a subsequence of a string to a buffer (or whatever) without consing. This fills that lacuna. The most-used function in Common Lisp of the three this introduces is probably #'write-string. APPROVE COMMIT NOTE: This patch has been committed. # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net&gt; # Date 1387301350 -7200 # Node ID cd4f5f1f1f4c20036b18e7b7ab56c919614b9bea # Parent 72a9467f93fc5510ba331627ca9581719053c51c Add #'write-sequence, on the model of #'write-char, API from Common Lisp. src/ChangeLog addition: 2013-12-17 Aidan Kehoe <kehoea(a)parhasard.net&gt; * lisp.h: * lisp.h (PARSE_KEYWORDS_8): Correct this in cases where we can have noticeably fewer arguments than KEYWORDS_OFFSET, check whether nargs > pk_offset. Declare check_sequence_range in this header. * print.c: * print.c (Fwrite_sequence) New: Write a sequence to a stream, in the same way #'write-char and #'terpri do. API from Common Lisp, not GNU, so while there is some char-int confoundance, it's more limited than usual with GNU APIs. * print.c (syms_of_print): Make it available. * sequence.c (check_sequence_range): Export this to other files. lisp/ChangeLog addition: 2013-12-17 Aidan Kehoe <kehoea(a)parhasard.net&gt; * cl-extra.el: * cl-extra.el (write-string): New. * cl-extra.el (write-line): New. Add these here, implemented in terms of #'write-sequence in print.c. tests/ChangeLog addition: 2013-12-17 Aidan Kehoe <kehoea(a)parhasard.net&gt; * automated/lisp-tests.el: Up max-lisp-eval-depth when compiling this file, some of what we're doing in testing #'write-sequence is demanding. * automated/lisp-tests.el (make-circular-list): New argument VALUE, the car of the conses to create. * automated/lisp-tests.el: Test #'write-sequence, #'write-string, #'write-line with function, buffer and marker STREAMs; test argument types, keyword argument ranges and values. diff -r 72a9467f93fc -r cd4f5f1f1f4c lisp/ChangeLog --- a/lisp/ChangeLog Sun Dec 15 17:01:58 2013 +0000 +++ b/lisp/ChangeLog Tue Dec 17 19:29:10 2013 +0200 ＠＠ -1,3 +1,10 ＠＠ +2013-12-17 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * cl-extra.el: + * cl-extra.el (write-string): New. + * cl-extra.el (write-line): New. + Add these here, implemented in terms of #'write-sequence in print.c. + 2013-09-15 Mats Lidell <matsl(a)cxemacs.org&gt; * files.el (mode-require-final-newline): Variable synced from diff -r 72a9467f93fc -r cd4f5f1f1f4c lisp/cl-extra.el --- a/lisp/cl-extra.el Sun Dec 15 17:01:58 2013 +0000 +++ b/lisp/cl-extra.el Tue Dec 17 19:29:10 2013 +0200 ＠＠ -618,6 +618,38 ＠＠ ;; files to do the same, multiple times. (eval-when-compile (or (cl-compiling-file) (load "cl-macs"))) +;; XEmacs, functions from Common Lisp. +(defun* write-string (string &optional output-stream &key (start 0) end) + "Output STRING to stream OUTPUT-STREAM. + +OUTPUT-STREAM defaults to the value of `standard-output', which see. + +Keywords:start and :end, if given, specify indices of a subsequence +of STRING to output. They default to 0 and nil, meaning write the +entire string. + +Returns STRING (not the subsequence of STRING that has been written to +OUTPUT-STREAM)." + (check-type string string) + (write-sequence string output-stream :start start :end end)) + +(defun* write-line (string &optional output-stream &key (start 0) end) + "Output STRING, followed by a newline, to OUTPUT-STREAM. + +STRING must be a string. OUTPUT-STREAM defaults to the value of +`standard-output' (which see). + +Keywords:start and :end, if given, specify indices of a subsequence +of STRING to output. They default to 0 and nil, meaning write the +entire string. + +Returns STRING (note, not the subsequence of STRING that has been written to +OUTPUT-STREAM)." + (check-type string string) + (prog1 + (write-sequence string output-stream :start start :end end) + (terpri output-stream))) + ;; Implementation limits. ;; XEmacs; call cl-float-limits at dump time. diff -r 72a9467f93fc -r cd4f5f1f1f4c src/ChangeLog --- a/src/ChangeLog Sun Dec 15 17:01:58 2013 +0000 +++ b/src/ChangeLog Tue Dec 17 19:29:10 2013 +0200 ＠＠ -1,3 +1,20 ＠＠ +2013-12-17 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * lisp.h: + * lisp.h (PARSE_KEYWORDS_8): + Correct this in cases where we can have noticeably fewer arguments + than KEYWORDS_OFFSET, check whether nargs > pk_offset. + Declare check_sequence_range in this header. + * print.c: + * print.c (Fwrite_sequence) New: + Write a sequence to a stream, in the same way #'write-char and + #'terpri do. API from Common Lisp, not GNU, so while there is some + char-int confoundance, it's more limited than usual with GNU APIs. + * print.c (syms_of_print): + Make it available. + * sequence.c (check_sequence_range): + Export this to other files. + 2013-12-15 Aidan Kehoe <kehoea(a)parhasard.net&gt; * number.h: diff -r 72a9467f93fc -r cd4f5f1f1f4c src/lisp.h --- a/src/lisp.h Sun Dec 15 17:01:58 2013 +0000 +++ b/src/lisp.h Tue Dec 17 19:29:10 2013 +0200 ＠＠ -3633,7 +3633,7 ＠＠ Elemcount pk_i = nargs - 1, pk_offset = keywords_offset; \ Boolint pk_allow_other_keys = allow_other_keys; \ \ - if ((nargs - pk_offset) & 1) \ + if ((nargs - pk_offset) & 1 && (nargs > pk_offset)) \ { \ if (!allow_other_keys \ && !(pk_allow_other_keys \ ＠＠ -5307,6 +5307,9 ＠＠ EXFUN (Fsubseq, 3); EXFUN (Fvalid_plist_p, 1); +extern void check_sequence_range (Lisp_Object, Lisp_Object, Lisp_Object, + Lisp_Object); + extern Boolint check_eq_nokey (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); extern Boolint check_lss_key_car (Lisp_Object, Lisp_Object, Lisp_Object, diff -r 72a9467f93fc -r cd4f5f1f1f4c src/print.c --- a/src/print.c Sun Dec 15 17:01:58 2013 +0000 +++ b/src/print.c Tue Dec 17 19:29:10 2013 +0200 ＠＠ -143,6 +143,8 ＠＠ Lisp_Object Qdisplay_error; Lisp_Object Qprint_message_label; +Lisp_Object Qwrite_sequence; + /* Force immediate output of all printed data. Used for debugging. */ int print_unbuffered; ＠＠ -838,6 +840,180 ＠＠ return character; } +DEFUN ("write-sequence", Fwrite_sequence, 1, MANY, 0, /* +Output string, list, vector or bit-vector SEQUENCE to STREAM. + +STREAM defaults to the value of `standard-output', which see. + +Keywords:start and :end, if given, specify indices of a subsequence +of SEQUENCE to output. They default to 0 and nil, meaning write the +entire sequence. + +Elements of SEQUENCE can be characters (all are accepted by this function, +though they may be corrupted depending on the coding system associated with +STREAM) or integers below #x100, which are treated as equivalent to the +characters with the corresponding code. This function is from Common Lisp, +rather GNU Emacs API, so GNU Emacs' character-integer equivalence doesn't +hold. + +Returns SEQUENCE (not the subsequence of SEQUENCE that has been written to +STREAM). + +arguments: (SEQUENCE &optional STREAM &key (START 0) END) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object sequence = args[0], stream = (nargs > 1) ? args[1] : Qnil; + Lisp_Object reloc = Qnil; + Charcount starting = 0, ending = 1 + MOST_POSITIVE_FIXNUM; + Ibyte *nonreloc = NULL, *all = NULL, *allptr = all; + Bytecount bstart = 0, blen = 0; + Elemcount ii = 0; + + PARSE_KEYWORDS_8 (Qwrite_sequence, nargs, args, 2, (start, end), + (start = Qzero), 2, 0); + + CHECK_SEQUENCE (sequence); + CHECK_NATNUM (start); + + if (!NILP (end)) + { + CHECK_NATNUM (end); + } + + stream = canonicalize_printcharfun (stream); + + if (BIGNUMP (start) || (BIGNUMP (end))) + { + /* None of the sequences will have bignum lengths. */ + check_sequence_range (sequence, start, end, Flength (sequence)); + + RETURN_NOT_REACHED (sequence); + } + + starting = XFIXNUM (start); + if (FIXNUMP (end)) + { + ending = XFIXNUM (end); + } + + if (STRINGP (sequence)) + { + Ibyte *stringp = XSTRING_DATA (sequence); + Ibyte *strend = stringp + XSTRING_LENGTH (sequence); + + reloc = sequence; + + for (ii = 0; ii < starting && stringp < strend; ++ii) + { + INC_IBYTEPTR (stringp); + } + + if (ii != starting) + { + /* Bad value for start. */ + check_sequence_range (sequence, start, end, + Flength (sequence)); + RETURN_NOT_REACHED (sequence); + } + + bstart = stringp - XSTRING_DATA (sequence); + + for (; ii < ending && stringp < strend; ++ii) + { + INC_IBYTEPTR (stringp); + } + + if (ii != ending && ending != (1 + MOST_POSITIVE_FIXNUM)) + { + /* Bad value for end. */ + check_sequence_range (sequence, start, end, + Flength (sequence)); + RETURN_NOT_REACHED (sequence); + } + + blen = stringp - (XSTRING_DATA (sequence) + bstart); + } + else + { + Lisp_Object length = Flength (sequence); + + check_sequence_range (sequence, start, end, length); + ending = NILP (end) ? XFIXNUM (length) : XFIXNUM (end); + + if (VECTORP (sequence)) + { + Lisp_Object *vdata = XVECTOR_DATA (sequence); + /* Worst case scenario; all characters, all the longest possible. More + likely: lots of small integers. */ + nonreloc = allptr + = alloca_ibytes (((ending - starting)) * MAX_ICHAR_LEN); + + for (ii = starting; ii < ending; ++ii) + { + if (!CHARP (vdata[ii])) + { + check_integer_range (vdata[ii], Qzero, make_fixnum (0xff)); + } + + allptr += set_itext_ichar (allptr, + XCHAR_OR_CHAR_INT (vdata[ii])); + } + } + else if (CONSP (sequence)) + { + /* Worst case scenario; all characters, all the longest + possible. More likely: lots of small integers. */ + nonreloc = allptr + = alloca_ibytes (((ending - starting)) * MAX_ICHAR_LEN); + ii = 0; + { + EXTERNAL_LIST_LOOP_2 (elt, sequence) + { + if (ii >= starting) + { + if (ii >= ending) + { + break; + } + + if (!CHARP (elt)) + { + check_integer_range (elt, Qzero, make_fixnum (0xff)); + } + allptr += set_itext_ichar (allptr, + XCHAR_OR_CHAR_INT (elt)); + } + ++ii; + } + } + } + else if (BIT_VECTORP (sequence)) + { + Ibyte one [MAX_ICHAR_LEN]; + Lisp_Bit_Vector *vv = XBIT_VECTOR (sequence); + + nonreloc = allptr + = alloca_ibytes (((ending - starting) * + (set_itext_ichar (one, (Ichar)1)))); + for (ii = starting; ii < ending; ++ii) + { + allptr += set_itext_ichar (allptr, bit_vector_bit (vv, ii)); + } + } + else if (NILP (sequence)) + { + nonreloc = allptr = alloca_ibytes (1); + } + + bstart = 0; + blen = allptr - nonreloc; + } + + output_string (stream, nonreloc, reloc, bstart, blen); + return sequence; +} + void temp_output_buffer_setup (Lisp_Object bufname) { ＠＠ -2977,6 +3153,7 ＠＠ DEFSYMBOL (Qdisplay_error); DEFSYMBOL (Qprint_message_label); + DEFSYMBOL (Qwrite_sequence); DEFSUBR (Fprin1); DEFSUBR (Fprin1_to_string); ＠＠ -2986,6 +3163,7 ＠＠ DEFSUBR (Fdisplay_error); DEFSUBR (Fterpri); DEFSUBR (Fwrite_char); + DEFSUBR (Fwrite_sequence); DEFSUBR (Falternate_debugging_output); DEFSUBR (Fset_device_clear_left_side); DEFSUBR (Fdevice_left_side_clear_p); diff -r 72a9467f93fc -r cd4f5f1f1f4c src/sequence.c --- a/src/sequence.c Sun Dec 15 17:01:58 2013 +0000 +++ b/src/sequence.c Tue Dec 17 19:29:10 2013 +0200 ＠＠ -44,7 +44,7 ＠＠ invalid_state_2 ("object modified while traversing it", func, object); } -static void +void check_sequence_range (Lisp_Object sequence, Lisp_Object start, Lisp_Object end, Lisp_Object length) { diff -r 72a9467f93fc -r cd4f5f1f1f4c tests/ChangeLog --- a/tests/ChangeLog Sun Dec 15 17:01:58 2013 +0000 +++ b/tests/ChangeLog Tue Dec 17 19:29:10 2013 +0200 ＠＠ -1,3 +1,15 ＠＠ +2013-12-17 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * automated/lisp-tests.el: + Up max-lisp-eval-depth when compiling this file, some of what + we're doing in testing #'write-sequence is demanding. + * automated/lisp-tests.el (make-circular-list): + New argument VALUE, the car of the conses to create. + * automated/lisp-tests.el: + Test #'write-sequence, #'write-string, #'write-line with function, + buffer and marker STREAMs; test argument types, keyword argument + ranges and values. + 2013-12-15 Aidan Kehoe <kehoea(a)parhasard.net&gt; * automated/lisp-tests.el (character): diff -r 72a9467f93fc -r cd4f5f1f1f4c tests/automated/lisp-tests.el --- a/tests/automated/lisp-tests.el Sun Dec 15 17:01:58 2013 +0000 +++ b/tests/automated/lisp-tests.el Tue Dec 17 19:29:10 2013 +0200 ＠＠ -29,6 +29,9 ＠＠ ;;; See test-harness.el for instructions on how to run these tests. (eval-when-compile + ;; The labels below give trouble with a max-lisp-eval-depth of less than + ;; about 2000, work around that: + (setq max-lisp-eval-depth (max 2000 max-lisp-eval-depth)) (condition-case nil (require 'test-harness) (file-error ＠＠ -102,12 +105,16 ＠＠ (Assert (eq (elt my-bit-vector 2) 0)) ) -(defun make-circular-list (length) - "Create evil emacs-crashing circular list of length LENGTH" +(defun make-circular-list (length &optional value) + "Create evil emacs-crashing circular list of length LENGTH. + +Optional VALUE is the value to go into the cars. If nil, some non-nil value +will be used to make debugging easier." (let ((circular-list (make-list length - 'you-are-trapped-in-a-twisty-maze-of-cons-cells-all-alike))) + (or value + 'you-are-trapped-in-a-twisty-maze-of-cons-cells-all-alike)))) (setcdr (last circular-list) circular-list) circular-list)) ＠＠ -2867,8 +2874,10 ＠＠ #'(lambda (object) (if (fixnump object) 1 0)) list)) (string (map 'string #'(lambda (object) (or (and (fixnump object) - (int-char object)) - (decode-char 'ucs #x20ac))) list)) + (int-char object)) + (decode-char 'ucs #x20ac) + ?\x20)) + list)) (gensym (gensym))) (Assert (null (find 'not-in-it list))) (Assert (null (find 'not-in-it vector))) ＠＠ -3119,4 +3128,327 ＠＠ (map nil #'set-marker markers fixnums) (Assert-arith-equivalences markers "with Euro sign restored")))) +;;----------------------------------------------------- +;; Test #'write-sequence and friends. +;;----------------------------------------------------- + +(macrolet + ((Assert-write-results (function context &key short-string long-string + sequences-too output-stream + clear-output get-last-output) + "Check correct output in CONTEXT for `write-sequence' and friends." + (let* ((short-bit-vector (map 'bit-vector #'logand short-string + (make-circular-list 1 1))) + (long-bit-vector (map 'bit-vector #'logand long-string + (make-circular-list 1 1))) + (short-bit-vector-string + (map #'string #'int-char short-bit-vector)) + (long-bit-vector-string + (map #'string #'int-char long-bit-vector))) + `(progn + (,clear-output ,output-stream) + (,function ,short-string ,output-stream) + (Assert (equal ,short-string + (,get-last-output ,output-stream + ,(length short-string))) + ,(format "checking %s with short string, %s" + function context)) + ,＠(when sequences-too + `((,clear-output ,output-stream) + (,function ,(vconcat short-string) ,output-stream) + (Assert (equal ,short-string + (,get-last-output ,output-stream + ,(length short-string))) + ,(format "checking %s with short vector, %s" + function context)) + (,clear-output ,output-stream) + (,function ',(append short-string nil) ,output-stream) + (Assert (equal ,short-string + (,get-last-output ,output-stream + ,(length short-string))) + ,(format "checking %s with short list, %s" + function context)) + (,clear-output ,output-stream) + (,function ,short-bit-vector ,output-stream) + (Assert (equal ,short-bit-vector-string + (,get-last-output + ,output-stream + ,(length short-bit-vector-string))) + ,(format + "checking %s with short bit-vector, %s" + function context)) + (,clear-output ,output-stream) + (,function ,long-bit-vector ,output-stream) + (Assert (equal ,long-bit-vector-string + (,get-last-output + ,output-stream + ,(length long-bit-vector-string))) + ,(format + "checking %s with long bit-vector, %s" + function context)))) + ,(cons + 'progn + (loop + for (subseq-start subseq-end description) + in `((0 ,(length short-string) "trivial range") + (4 7 "harder range")) + nconc + `((,clear-output ,output-stream) + (,function ,short-string ,output-stream :start ,subseq-start +:end ,subseq-end) + (Assert + (equal ,(subseq short-string subseq-start subseq-end) + (,get-last-output ,output-stream + ,(- subseq-end subseq-start))) + ,(format + "checking %s with short string, %s, %s" + function context description)) + ,＠(when sequences-too + `((,clear-output ,output-stream) + (,function ,(vconcat short-string) ,output-stream +:start ,subseq-start :end ,subseq-end) + (Assert + (equal ,(subseq short-string subseq-start subseq-end) + (,get-last-output ,output-stream + ,(- subseq-end subseq-start))) + ,(format + "checking %s with short vector, %s, %s" + function context description)) + (,clear-output ,output-stream) + (,function ',(append short-string nil) ,output-stream +:start ,subseq-start :end ,subseq-end) + (Assert + (equal ,(subseq short-string subseq-start subseq-end) + (,get-last-output + ,output-stream + ,(- subseq-end subseq-start ))) + ,(format "checking %s with short list, %s, %s" + function context description)) + (,clear-output ,output-stream) + (,function ,short-bit-vector ,output-stream +:start ,subseq-start :end ,subseq-end) + (Assert + (equal ,(subseq short-bit-vector-string subseq-start + subseq-end) + (,get-last-output ,output-stream + ,(- subseq-end subseq-start))) + ,(format + "checking %s with short bit-vector, %s, %s" + function context description))))))) + ,(cons + 'progn + (loop + for (subseq-start subseq-end description) + in `((0 ,(length long-string) "trivial range") + (4 90 "harder range")) + nconc + `((,clear-output ,output-stream) + (,function ,long-string ,output-stream :start ,subseq-start +:end ,subseq-end) + (Assert + (equal ,(subseq long-string subseq-start subseq-end) + (,get-last-output ,output-stream + ,(- subseq-end subseq-start))) + ,(format + "checking %s with long string, %s, %s" + function context description)) + ,＠(when sequences-too + `((,clear-output ,output-stream) + (,function ,(vconcat long-string) ,output-stream +:start ,subseq-start :end ,subseq-end) + (Assert + (equal ,(subseq long-string subseq-start subseq-end) + (,get-last-output + ,output-stream + ,(- subseq-end subseq-start))) + ,(format + "checking %s with long vector, %s, %s" + function context description)) + (,clear-output ,output-stream) + (,function ',(append long-string nil) ,output-stream +:start ,subseq-start :end ,subseq-end) + (Assert + (equal ,(subseq long-string subseq-start subseq-end) + (,get-last-output ,output-stream + ,(- subseq-end subseq-start))) + ,(format "checking %s with long list, %s, %s" + function context description)) + (,clear-output ,output-stream) + (,function ,long-bit-vector ,output-stream +:start ,subseq-start :end ,subseq-end) + (Assert + (equal ,(subseq long-bit-vector-string + subseq-start subseq-end) + (,get-last-output + ,output-stream + ,(- subseq-end subseq-start))) + ,(format + "checking %s with long bit-vector, %s, %s" + function context description))))))) + (,clear-output ,output-stream)))) + (test-write-string (function &key sequences-too worry-about-newline) + (let* ((short-string "hello there") + (long-string + (decode-coding-string + (concat + "\xd8\xb3\xd9\x84\xd8\xa7\xd9\x85 \xd8\xb9\xd9\x84" + "\xdb\x8c\xda\xa9\xd9\x85\x2c \xd8\xa7\xd8\xb3\xd9" + "\x85 \xd9\x85\xd9\x86 \xd8\xa7\xdb\x8c\xd8\xaf\xd9" + "\x86 \xda\xa9\xdb\x8c\xd9\x88 \xd8\xa7\xd8\xb3\xd8" + "\xaa\x2e \xd9\x85\xd9\x86 \xd8\xa7\xdb\x8c\xd8\xb1" + "\xd9\x84\xd9\x86\xd8\xaf\xdb\x8c \xd8\xa7\xd9\x85" + "\x2c \xd9\x88 \xd9\x85\xd9\x86 \xd8\xaf\xd8\xb1 " + "\xd8\xa8\xdb\x8c\xd9\x85\xd8\xa7\xd8\xb1\xd8\xb3" + "\xd8\xaa\xd8\xa7\xd9\x86 \xda\xa9\xd8\xa7\xd8\xb1" + "\xd9\x85\xdb\x8c\xe2\x80\x8c\xda\xa9\xd9\x86\xd9" + "\x85\x2e") + (if (featurep 'mule) 'utf-8 'raw-text-unix))) + (long-string (concat long-string long-string long-string + long-string long-string long-string + long-string long-string long-string + long-string long-string long-string))) + `(with-temp-buffer + (let* ((long-string ,long-string) + (stashed-data + (get-buffer-create + (generate-new-buffer-name " *stash*"))) + (function-output-stream + (apply-partially + #'(lambda (buffer character) + (insert-char character 1 nil buffer)) + stashed-data)) + (marker-buffer + (get-buffer-create + (generate-new-buffer-name " *for-marker*"))) + (marker-base-position 40) + (marker + (progn + (insert-char ?\xff 90 nil marker-buffer) + (set-marker (make-marker) 40 marker-buffer)))) + (unwind-protect + (labels + ((clear-buffer (buffer) + (delete-region (point-min buffer) (point-max buffer) + buffer)) + (clear-stashed-data (ignore) + (delete-region (point-min stashed-data) + (point-max stashed-data) + stashed-data)) + (clear-marker-data (marker) + (delete-region marker-base-position marker + (marker-buffer marker))) + (buffer-output (buffer length) + (and (> (point buffer) length) + (buffer-substring (- (point buffer) length) + (point buffer) buffer))) + (stashed-data-output (ignore length) + (and (> (point stashed-data) length) + (buffer-substring (- (point stashed-data) + length) + (point stashed-data) + stashed-data))) + (marker-data (marker length) + (and (> marker length) + (buffer-substring (- marker length) marker + (marker-buffer marker)))) + (buffer-output-sans-newline (buffer length) + (and (> (point buffer) (+ length 1)) + (buffer-substring (- (point buffer) length 1) + (1- (point buffer))))) + (stashed-data-output-sans-newline (ignore length) + (and (> (point stashed-data) (+ length 1)) + (buffer-substring (- (point stashed-data) + length 1) + (1- (point stashed-data)) + stashed-data))) + (marker-data-sans-newline (marker length) + (and (> marker (+ length 1)) + (buffer-substring (- marker length 1) + (1- marker) + (marker-buffer marker))))) + (Check-Error wrong-number-of-arguments (,function)) + (,(if (subrp (symbol-function function)) + 'progn + 'Implementation-Incomplete-Expect-Failure) + (Check-Error wrong-number-of-arguments + (,function ,short-string + (current-buffer) :start)) + (Check-Error wrong-number-of-arguments + (,function ,short-string + (current-buffer) :start 0 + :end nil :start))) + (Check-Error invalid-keyword-argument + (,function ,short-string + (current-buffer) +:test #'eq)) + (Check-Error wrong-type-argument (,function pi)) + ,＠(if sequences-too + `((Check-Error + args-out-of-range + (,function (vector most-positive-fixnum))) + (Check-Error + args-out-of-range + (,function (list most-positive-fixnum))) + ,＠(if (featurep 'mule) + `((Check-Error + args-out-of-range + (,function + (vector + (char-int + (decode-char 'ucs #x20ac)))))))) + `((Check-Error wrong-type-argument + (,function + ',(append short-string nil))) + (Check-Error wrong-type-argument + (,function + ,(vconcat long-string))) + (Check-Error wrong-type-argument + (,function #*010010001010101)))) + (Check-Error wrong-type-argument + (,function ,short-string (current-buffer) +:start 0.0)) + (Check-Error wrong-type-argument + (,function ,short-string (current-buffer) +:end 4.0)) + (Check-Error invalid-function + (,function ,short-string pi)) + (Check-Error args-out-of-range + (,function ,short-string (current-buffer) +:end ,(1+ (length short-string)))) + (Check-Error args-out-of-range + (,function ,short-string nil +:start + ,(1+ (length short-string)))) + ;; Not checked here; output to a stdio stream, output + ;; to an lstream, output to a frame. + (Assert-write-results + ,function "buffer point" :short-string ,short-string +:long-string ,long-string :sequences-too ,sequences-too +:output-stream (current-buffer) +:clear-output clear-buffer +:get-last-output + ,(if worry-about-newline 'buffer-output-sans-newline + 'buffer-output)) + (Assert-write-results + ,function "function output" :short-string ,short-string +:long-string ,long-string :sequences-too ,sequences-too +:output-stream function-output-stream +:clear-output clear-stashed-data +:get-last-output + ,(if worry-about-newline + 'stashed-data-output-sans-newline + 'stashed-data-output)) + (Assert-write-results + ,function "marker output" :short-string ,short-string +:long-string ,long-string :sequences-too ,sequences-too +:output-stream marker :clear-output clear-marker-data +:get-last-output ,(if worry-about-newline + 'marker-data-sans-newline + 'marker-data))) + (kill-buffer stashed-data) + (kill-buffer marker-buffer))))))) + (test-write-string write-sequence :sequences-too t) + (test-write-string write-string :sequences-too nil) + (test-write-string write-line :worry-about-newline t :sequences-too nil)) + ;;; end of lisp-tests.el -- ‘Liston operated so fast that he once accidentally amputated an assistant’s fingers along with a patient’s leg, […] The patient and the assistant both died of sepsis, and a spectator reportedly died of shock, resulting in the only known procedure with a 300% mortality.’ (Atul Gawande, NEJM, 2012) _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://lists.xemacs.org/mailman/listinfo/xemacs-patches