Mercurial > hg > xemacs-beta

comparison tests/automated/lisp-tests.el @ 5772:cd4f5f1f1f4c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Add #'write-sequence, on the model of #'write-char, API from Common Lisp. src/ChangeLog addition: 2013-12-17 Aidan Kehoe <kehoea@parhasard.net> * 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@parhasard.net> * 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@parhasard.net> * 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.
author Aidan Kehoe <kehoea@parhasard.net>
date Tue, 17 Dec 2013 19:29:10 +0200
parents 72a9467f93fc
children e9bb3688e654 750fab17b299
comparison
equal deleted inserted replaced
5771:72a9467f93fc 5772:cd4f5f1f1f4c
27 27
28 ;;; Test basic Lisp engine functionality 28 ;;; Test basic Lisp engine functionality
29 ;;; See test-harness.el for instructions on how to run these tests. 29 ;;; See test-harness.el for instructions on how to run these tests.
30 30
31 (eval-when-compile 31 (eval-when-compile
32 ;; The labels below give trouble with a max-lisp-eval-depth of less than
33 ;; about 2000, work around that:
34 (setq max-lisp-eval-depth (max 2000 max-lisp-eval-depth))
32 (condition-case nil 35 (condition-case nil
33 (require 'test-harness) 36 (require 'test-harness)
34 (file-error 37 (file-error
35 (push "." load-path) 38 (push "." load-path)
36 (when (and (boundp 'load-file-name) (stringp load-file-name)) 39 (when (and (boundp 'load-file-name) (stringp load-file-name))
100 (fillarray my-bit-vector 0) 103 (fillarray my-bit-vector 0)
101 (Assert (eq 4 (length my-bit-vector))) 104 (Assert (eq 4 (length my-bit-vector)))
102 (Assert (eq (elt my-bit-vector 2) 0)) 105 (Assert (eq (elt my-bit-vector 2) 0))
103 ) 106 )
104 107
105 (defun make-circular-list (length) 108 (defun make-circular-list (length &optional value)
106 "Create evil emacs-crashing circular list of length LENGTH" 109 "Create evil emacs-crashing circular list of length LENGTH.
110
111 Optional VALUE is the value to go into the cars. If nil, some non-nil value
112 will be used to make debugging easier."
107 (let ((circular-list 113 (let ((circular-list
108 (make-list 114 (make-list
109 length 115 length
110 'you-are-trapped-in-a-twisty-maze-of-cons-cells-all-alike))) 116 (or value
117 'you-are-trapped-in-a-twisty-maze-of-cons-cells-all-alike))))
111 (setcdr (last circular-list) circular-list) 118 (setcdr (last circular-list) circular-list)
112 circular-list)) 119 circular-list))
113 120
114 ;;----------------------------------------------------- 121 ;;-----------------------------------------------------
115 ;; Test `nconc' 122 ;; Test `nconc'
2865 (vector (map 'vector #'identity list)) 2872 (vector (map 'vector #'identity list))
2866 (bit-vector (map 'bit-vector 2873 (bit-vector (map 'bit-vector
2867 #'(lambda (object) (if (fixnump object) 1 0)) list)) 2874 #'(lambda (object) (if (fixnump object) 1 0)) list))
2868 (string (map 'string 2875 (string (map 'string
2869 #'(lambda (object) (or (and (fixnump object) 2876 #'(lambda (object) (or (and (fixnump object)
2870 (int-char object)) 2877 (int-char object))
2871 (decode-char 'ucs #x20ac))) list)) 2878 (decode-char 'ucs #x20ac)
2879 ?\x20))
2880 list))
2872 (gensym (gensym))) 2881 (gensym (gensym)))
2873 (Assert (null (find 'not-in-it list))) 2882 (Assert (null (find 'not-in-it list)))
2874 (Assert (null (find 'not-in-it vector))) 2883 (Assert (null (find 'not-in-it vector)))
2875 (Assert (null (find 'not-in-it bit-vector))) 2884 (Assert (null (find 'not-in-it bit-vector)))
2876 (Assert (null (find 'not-in-it string))) 2885 (Assert (null (find 'not-in-it string)))
3117 (put-char-table ?\x7f character translation) 3126 (put-char-table ?\x7f character translation)
3118 (translate-region (point-min) (point-max) translation) 3127 (translate-region (point-min) (point-max) translation)
3119 (map nil #'set-marker markers fixnums) 3128 (map nil #'set-marker markers fixnums)
3120 (Assert-arith-equivalences markers "with Euro sign restored")))) 3129 (Assert-arith-equivalences markers "with Euro sign restored"))))
3121 3130
3131 ;;-----------------------------------------------------
3132 ;; Test #'write-sequence and friends.
3133 ;;-----------------------------------------------------
3134
3135 (macrolet
3136 ((Assert-write-results (function context &key short-string long-string
3137 sequences-too output-stream
3138 clear-output get-last-output)
3139 "Check correct output in CONTEXT for `write-sequence' and friends."
3140 (let* ((short-bit-vector (map 'bit-vector #'logand short-string
3141 (make-circular-list 1 1)))
3142 (long-bit-vector (map 'bit-vector #'logand long-string
3143 (make-circular-list 1 1)))
3144 (short-bit-vector-string
3145 (map #'string #'int-char short-bit-vector))
3146 (long-bit-vector-string
3147 (map #'string #'int-char long-bit-vector)))
3148 `(progn
3149 (,clear-output ,output-stream)
3150 (,function ,short-string ,output-stream)
3151 (Assert (equal ,short-string
3152 (,get-last-output ,output-stream
3153 ,(length short-string)))
3154 ,(format "checking %s with short string, %s"
3155 function context))
3156 ,@(when sequences-too
3157 `((,clear-output ,output-stream)
3158 (,function ,(vconcat short-string) ,output-stream)
3159 (Assert (equal ,short-string
3160 (,get-last-output ,output-stream
3161 ,(length short-string)))
3162 ,(format "checking %s with short vector, %s"
3163 function context))
3164 (,clear-output ,output-stream)
3165 (,function ',(append short-string nil) ,output-stream)
3166 (Assert (equal ,short-string
3167 (,get-last-output ,output-stream
3168 ,(length short-string)))
3169 ,(format "checking %s with short list, %s"
3170 function context))
3171 (,clear-output ,output-stream)
3172 (,function ,short-bit-vector ,output-stream)
3173 (Assert (equal ,short-bit-vector-string
3174 (,get-last-output
3175 ,output-stream
3176 ,(length short-bit-vector-string)))
3177 ,(format
3178 "checking %s with short bit-vector, %s"
3179 function context))
3180 (,clear-output ,output-stream)
3181 (,function ,long-bit-vector ,output-stream)
3182 (Assert (equal ,long-bit-vector-string
3183 (,get-last-output
3184 ,output-stream
3185 ,(length long-bit-vector-string)))
3186 ,(format
3187 "checking %s with long bit-vector, %s"
3188 function context))))
3189 ,(cons
3190 'progn
3191 (loop
3192 for (subseq-start subseq-end description)
3193 in `((0 ,(length short-string) "trivial range")
3194 (4 7 "harder range"))
3195 nconc
3196 `((,clear-output ,output-stream)
3197 (,function ,short-string ,output-stream :start ,subseq-start
3198 :end ,subseq-end)
3199 (Assert
3200 (equal ,(subseq short-string subseq-start subseq-end)
3201 (,get-last-output ,output-stream
3202 ,(- subseq-end subseq-start)))
3203 ,(format
3204 "checking %s with short string, %s, %s"
3205 function context description))
3206 ,@(when sequences-too
3207 `((,clear-output ,output-stream)
3208 (,function ,(vconcat short-string) ,output-stream
3209 :start ,subseq-start :end ,subseq-end)
3210 (Assert
3211 (equal ,(subseq short-string subseq-start subseq-end)
3212 (,get-last-output ,output-stream
3213 ,(- subseq-end subseq-start)))
3214 ,(format
3215 "checking %s with short vector, %s, %s"
3216 function context description))
3217 (,clear-output ,output-stream)
3218 (,function ',(append short-string nil) ,output-stream
3219 :start ,subseq-start :end ,subseq-end)
3220 (Assert
3221 (equal ,(subseq short-string subseq-start subseq-end)
3222 (,get-last-output
3223 ,output-stream
3224 ,(- subseq-end subseq-start )))
3225 ,(format "checking %s with short list, %s, %s"
3226 function context description))
3227 (,clear-output ,output-stream)
3228 (,function ,short-bit-vector ,output-stream
3229 :start ,subseq-start :end ,subseq-end)
3230 (Assert
3231 (equal ,(subseq short-bit-vector-string subseq-start
3232 subseq-end)
3233 (,get-last-output ,output-stream
3234 ,(- subseq-end subseq-start)))
3235 ,(format
3236 "checking %s with short bit-vector, %s, %s"
3237 function context description)))))))
3238 ,(cons
3239 'progn
3240 (loop
3241 for (subseq-start subseq-end description)
3242 in `((0 ,(length long-string) "trivial range")
3243 (4 90 "harder range"))
3244 nconc
3245 `((,clear-output ,output-stream)
3246 (,function ,long-string ,output-stream :start ,subseq-start
3247 :end ,subseq-end)
3248 (Assert
3249 (equal ,(subseq long-string subseq-start subseq-end)
3250 (,get-last-output ,output-stream
3251 ,(- subseq-end subseq-start)))
3252 ,(format
3253 "checking %s with long string, %s, %s"
3254 function context description))
3255 ,@(when sequences-too
3256 `((,clear-output ,output-stream)
3257 (,function ,(vconcat long-string) ,output-stream
3258 :start ,subseq-start :end ,subseq-end)
3259 (Assert
3260 (equal ,(subseq long-string subseq-start subseq-end)
3261 (,get-last-output
3262 ,output-stream
3263 ,(- subseq-end subseq-start)))
3264 ,(format
3265 "checking %s with long vector, %s, %s"
3266 function context description))
3267 (,clear-output ,output-stream)
3268 (,function ',(append long-string nil) ,output-stream
3269 :start ,subseq-start :end ,subseq-end)
3270 (Assert
3271 (equal ,(subseq long-string subseq-start subseq-end)
3272 (,get-last-output ,output-stream
3273 ,(- subseq-end subseq-start)))
3274 ,(format "checking %s with long list, %s, %s"
3275 function context description))
3276 (,clear-output ,output-stream)
3277 (,function ,long-bit-vector ,output-stream
3278 :start ,subseq-start :end ,subseq-end)
3279 (Assert
3280 (equal ,(subseq long-bit-vector-string
3281 subseq-start subseq-end)
3282 (,get-last-output
3283 ,output-stream
3284 ,(- subseq-end subseq-start)))
3285 ,(format
3286 "checking %s with long bit-vector, %s, %s"
3287 function context description)))))))
3288 (,clear-output ,output-stream))))
3289 (test-write-string (function &key sequences-too worry-about-newline)
3290 (let* ((short-string "hello there")
3291 (long-string
3292 (decode-coding-string
3293 (concat
3294 "\xd8\xb3\xd9\x84\xd8\xa7\xd9\x85 \xd8\xb9\xd9\x84"
3295 "\xdb\x8c\xda\xa9\xd9\x85\x2c \xd8\xa7\xd8\xb3\xd9"
3296 "\x85 \xd9\x85\xd9\x86 \xd8\xa7\xdb\x8c\xd8\xaf\xd9"
3297 "\x86 \xda\xa9\xdb\x8c\xd9\x88 \xd8\xa7\xd8\xb3\xd8"
3298 "\xaa\x2e \xd9\x85\xd9\x86 \xd8\xa7\xdb\x8c\xd8\xb1"
3299 "\xd9\x84\xd9\x86\xd8\xaf\xdb\x8c \xd8\xa7\xd9\x85"
3300 "\x2c \xd9\x88 \xd9\x85\xd9\x86 \xd8\xaf\xd8\xb1 "
3301 "\xd8\xa8\xdb\x8c\xd9\x85\xd8\xa7\xd8\xb1\xd8\xb3"
3302 "\xd8\xaa\xd8\xa7\xd9\x86 \xda\xa9\xd8\xa7\xd8\xb1"
3303 "\xd9\x85\xdb\x8c\xe2\x80\x8c\xda\xa9\xd9\x86\xd9"
3304 "\x85\x2e")
3305 (if (featurep 'mule) 'utf-8 'raw-text-unix)))
3306 (long-string (concat long-string long-string long-string
3307 long-string long-string long-string
3308 long-string long-string long-string
3309 long-string long-string long-string)))
3310 `(with-temp-buffer
3311 (let* ((long-string ,long-string)
3312 (stashed-data
3313 (get-buffer-create
3314 (generate-new-buffer-name " *stash*")))
3315 (function-output-stream
3316 (apply-partially
3317 #'(lambda (buffer character)
3318 (insert-char character 1 nil buffer))
3319 stashed-data))
3320 (marker-buffer
3321 (get-buffer-create
3322 (generate-new-buffer-name " *for-marker*")))
3323 (marker-base-position 40)
3324 (marker
3325 (progn
3326 (insert-char ?\xff 90 nil marker-buffer)
3327 (set-marker (make-marker) 40 marker-buffer))))
3328 (unwind-protect
3329 (labels
3330 ((clear-buffer (buffer)
3331 (delete-region (point-min buffer) (point-max buffer)
3332 buffer))
3333 (clear-stashed-data (ignore)
3334 (delete-region (point-min stashed-data)
3335 (point-max stashed-data)
3336 stashed-data))
3337 (clear-marker-data (marker)
3338 (delete-region marker-base-position marker
3339 (marker-buffer marker)))
3340 (buffer-output (buffer length)
3341 (and (> (point buffer) length)
3342 (buffer-substring (- (point buffer) length)
3343 (point buffer) buffer)))
3344 (stashed-data-output (ignore length)
3345 (and (> (point stashed-data) length)
3346 (buffer-substring (- (point stashed-data)
3347 length)
3348 (point stashed-data)
3349 stashed-data)))
3350 (marker-data (marker length)
3351 (and (> marker length)
3352 (buffer-substring (- marker length) marker
3353 (marker-buffer marker))))
3354 (buffer-output-sans-newline (buffer length)
3355 (and (> (point buffer) (+ length 1))
3356 (buffer-substring (- (point buffer) length 1)
3357 (1- (point buffer)))))
3358 (stashed-data-output-sans-newline (ignore length)
3359 (and (> (point stashed-data) (+ length 1))
3360 (buffer-substring (- (point stashed-data)
3361 length 1)
3362 (1- (point stashed-data))
3363 stashed-data)))
3364 (marker-data-sans-newline (marker length)
3365 (and (> marker (+ length 1))
3366 (buffer-substring (- marker length 1)
3367 (1- marker)
3368 (marker-buffer marker)))))
3369 (Check-Error wrong-number-of-arguments (,function))
3370 (,(if (subrp (symbol-function function))
3371 'progn
3372 'Implementation-Incomplete-Expect-Failure)
3373 (Check-Error wrong-number-of-arguments
3374 (,function ,short-string
3375 (current-buffer) :start))
3376 (Check-Error wrong-number-of-arguments
3377 (,function ,short-string
3378 (current-buffer) :start 0
3379 :end nil :start)))
3380 (Check-Error invalid-keyword-argument
3381 (,function ,short-string
3382 (current-buffer)
3383 :test #'eq))
3384 (Check-Error wrong-type-argument (,function pi))
3385 ,@(if sequences-too
3386 `((Check-Error
3387 args-out-of-range
3388 (,function (vector most-positive-fixnum)))
3389 (Check-Error
3390 args-out-of-range
3391 (,function (list most-positive-fixnum)))
3392 ,@(if (featurep 'mule)
3393 `((Check-Error
3394 args-out-of-range
3395 (,function
3396 (vector
3397 (char-int
3398 (decode-char 'ucs #x20ac))))))))
3399 `((Check-Error wrong-type-argument
3400 (,function
3401 ',(append short-string nil)))
3402 (Check-Error wrong-type-argument
3403 (,function
3404 ,(vconcat long-string)))
3405 (Check-Error wrong-type-argument
3406 (,function #*010010001010101))))
3407 (Check-Error wrong-type-argument
3408 (,function ,short-string (current-buffer)
3409 :start 0.0))
3410 (Check-Error wrong-type-argument
3411 (,function ,short-string (current-buffer)
3412 :end 4.0))
3413 (Check-Error invalid-function
3414 (,function ,short-string pi))
3415 (Check-Error args-out-of-range
3416 (,function ,short-string (current-buffer)
3417 :end ,(1+ (length short-string))))
3418 (Check-Error args-out-of-range
3419 (,function ,short-string nil
3420 :start
3421 ,(1+ (length short-string))))
3422 ;; Not checked here; output to a stdio stream, output
3423 ;; to an lstream, output to a frame.
3424 (Assert-write-results
3425 ,function "buffer point" :short-string ,short-string
3426 :long-string ,long-string :sequences-too ,sequences-too
3427 :output-stream (current-buffer)
3428 :clear-output clear-buffer
3429 :get-last-output
3430 ,(if worry-about-newline 'buffer-output-sans-newline
3431 'buffer-output))
3432 (Assert-write-results
3433 ,function "function output" :short-string ,short-string
3434 :long-string ,long-string :sequences-too ,sequences-too
3435 :output-stream function-output-stream
3436 :clear-output clear-stashed-data
3437 :get-last-output
3438 ,(if worry-about-newline
3439 'stashed-data-output-sans-newline
3440 'stashed-data-output))
3441 (Assert-write-results
3442 ,function "marker output" :short-string ,short-string
3443 :long-string ,long-string :sequences-too ,sequences-too
3444 :output-stream marker :clear-output clear-marker-data
3445 :get-last-output ,(if worry-about-newline
3446 'marker-data-sans-newline
3447 'marker-data)))
3448 (kill-buffer stashed-data)
3449 (kill-buffer marker-buffer)))))))
3450 (test-write-string write-sequence :sequences-too t)
3451 (test-write-string write-string :sequences-too nil)
3452 (test-write-string write-line :worry-about-newline t :sequences-too nil))
3453
3122 ;;; end of lisp-tests.el 3454 ;;; end of lisp-tests.el