Skip to content

Instantly share code, notes, and snippets.

@southly

southly/framework.l

Forked from bowbow99/framework.l
Created February 28, 2012 05:18
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save southly/1929896 to your computer and use it in GitHub Desktop.
Save southly/1929896 to your computer and use it in GitHub Desktop.
Download ZIP
#xyzzy nanri-master から multiframe へ取り込んだ変更のテスト
Raw
framework.l
;;; -*- mode: lisp; package: user -*-
#|
使い方（暫定）:
1. どこかへ framework.l と nanri-master-change-tests.l をダウンロード
2. M-x load-file
load file: path/to/framework.l
3. M-x load-test-file
test file: path/to/nanri-master-change-tests.l
4. M-x change-tests
で *Test Results* だかいう名前のバッファが開いて結果が表示される。
|#
#|
;; FORM の戻り値が VALUE と equal でないと fail
(deftest NAME ()
FORM
=> VALUE)
;; FORM が多値を返すという指定
;; 実際に返ってきた多値が指定したより多くても少なくても fail
(deftest NAME ()
FORM
=> VALUE-0
=> VALUE-1)
;; 罠注意: 戻り値を省略した場合、FORM が non-nil を返さないと fail
(deftest NAME ()
FORM)
;; 比較関数を指定
(deftest NAME (:compare '=)
0
=> 0/0)
;; 出力のテスト。string= で比較される。>> 直後の空白は区切りであって出力の一部ではない。
(deftest NAME ()
(princ "hello")
>> hello)
;; 改行もそのまま書ける
(deftest NAME ()
(format t "foo~%bar")
>> foo
>> bar
=> nil)
;; 指定されたエラーを投げないと fail
(deftest NAME ()
(+ 'foo 'bar)
!! type-error)
|#
(in-package :user)
(when (fboundp 'stop-watch-test-file)
(stop-watch-test-file))
;;;; test file loader
(defparameter *test-file-readtable* (copy-readtable nil))
(defun expected-output-reader (stream char)
(let ((next (peek-char nil stream nil #1='#:eof t)))
(case next
(#\>
(read-char stream nil nil t) ; discard 2nd >
(if (peek-char #\space stream nil #1# t)
(read-char stream nil nil t) ; discard following space
(error 'reader-error :stream stream :datum "不正な期待出力です"))
(list :expected-output
(with-output-to-string (s)
(while (and (setf next (read-char stream nil nil t))
(not (eql next #\LFD)))
(princ next s)))))
((#\space #1#) '>)
(t
(let ((follow (read stream nil "" t)))
(intern (format nil ">~A" follow) *package*))))))
(set-macro-character #\> 'expected-output-reader t *test-file-readtable*)
(defun load-test-file (filename)
(interactive "ftest file: ")
(let ((*readtable* *test-file-readtable*))
(load-file filename)))
;;;; macro deftest
(defparameter *change-tests* nil)
(defun make-test-thunk (name form expected-result expected-output)
(multiple-value-bind (expected-type expected-datum compare-fn)
(case (car expected-result)
(:return (values :return (cddr expected-result) (second expected-result)))
(:error (values :error (second expected-result))))
(multiple-value-bind (output-stream expected-output)
(values (car expected-output) (cdr expected-output))
(let ((capture-stream (gensym "capture-stream-")))
`(lambda ()
(format t "~&~A..." ',name)
(multiple-value-bind (actual-type actual-datum actual-output)
(let ((,capture-stream (make-string-output-stream)))
(handler-case
(let ((,output-stream ,capture-stream))
(values :return (multiple-value-list ,form)
#1=(get-output-stream-string ,capture-stream)))
(error (error)
(values :error error #1#))))
(let ((failed-p nil))
(labels ((fail (fmt &rest args)
(unless failed-p
(setf failed-p t)
(format t "Failed~%"))
(apply #'format t fmt args)))
,(when (stringp expected-output)
`(unless (string= actual-output ,expected-output)
(fail " Output (~S):~% Expected:~%~{ >> ~A~%~} Actually:~%~{ >> ~A~%~}"
',output-stream
',(split-string expected-output #\LFD t)
(split-string actual-output #\LFD t))))
,(case expected-type
;; WTF...
(:return
`(case actual-type
(:return
(unless (and (= (length actual-datum) ,(length expected-datum))
(every ,compare-fn ',expected-datum actual-datum))
(fail " Return values (~S):~% Expected:~%~{ => ~S~%~} Actually:~%~{ => ~S~%~}"
,compare-fn ',expected-datum actual-datum)))
(:error
(fail " Return values (~S):~% Expected:~%~{ => ~S~%~} Actually:~% !! ~S: ~A~%"
,compare-fn ',expected-datum
#2=(si:*structure-definition-name (si:*structure-definition actual-datum))
actual-datum))))
(:error
`(case actual-type
(:return
(fail " Error:~% Expected:~% !! ~S~% Actually:~%~{ => ~S~%~}"
',expected-datum actual-datum))
(:error
(unless (si:*structure-subtypep
(si:*structure-definition actual-datum)
(get ',expected-datum 'si:structure-definition))
(fail " Error:~% Expected:~% !! ~S~% Actually:~% !! ~S: ~A~%"
',expected-datum #2# actual-datum))))))
(unless failed-p
(format t "OK.~%"))
(if failed-p :fail :pass)))))))))
(defun non-nil-p (#:ignore actual) actual)
(defun parse-expectations (name expectations options)
"Return followings:
- expected values
- expected output"
(let ((result-type nil)
(result-data '())
(output nil)
(dest (getf options :output '*standard-output*))
(state nil))
(dolist (x expectations)
(cond
((member x '(=> !!)) (setf state x))
((and (consp x) (eql (first x) :expected-output))
;(msgbox "~S~% >> ~S" name x)
(setf output (if output (format nil "~A~%~A" output (second x)) (second x))))
(t (case state
(=> (case result-type
((nil) (setf result-type :return))
(:return)
(:error (error "Don't expect both return value(s) and error: ~S" name)))
(push x result-data))
;(>> (setf output (if output (format nil "~A~%~A" output x) x)))
(!! (case result-type
(:return (error "Don't expect both return value(s) and error: ~S" name))
(:error (error "Don't expect multiple errors: ~S" name)))
(unless (symbolp x)
(error 'type-error :datum x :expected-type 'symbol))
(setf result-type :error
result-data x))))))
;(multiple-value-bind (r o)
(values (case result-type
(:return (list* :return (getf options :compare ''equal) (nreverse result-data)))
(:error (list :error result-data))
((nil) (list :return ''non-nil-p ':non-nil))
(t (error "parse-expectations - unknown result-type: ~S: ~S" result-type name)))
(cons dest output))
;(msgbox "name = ~S~2%expected-result = ~S~%expected-output = ~S" name r o)
;(values r o))
))
(defun expand-deftest (name options form expectations)
(multiple-value-bind (expected-result expected-output)
(parse-expectations name expectations options)
`(setf *change-tests*
(acons ',name ,(make-test-thunk name form expected-result expected-output)
(remove ',name *change-tests* :key 'car)))))
(defmacro deftest (name (&rest options) form &rest expected)
(expand-deftest name options form expected))
(setf (get 'deftest 'ed:lisp-indent-hook) 2)
;;;; runner
(defun test-changes ()
(interactive)
(let ((buffer (get-buffer-create "*Test Results*"))
(pass-count 0)
(fail-count 0)
(error-count 0))
(setup-temp-buffer buffer)
(erase-buffer buffer)
(pop-to-buffer buffer)
(with-output-to-buffer (buffer)
(dolist (x *change-tests*)
(case (funcall (cdr x))
(:pass (incf pass-count))
(:fail (incf fail-count) (ding))
(:error (incf error-count) (ding))))
(format t "----------------------------------------------------------------------~%")
(format t "total ~D tests, ~D passed, ~D failed, ~D Errors"
(+ pass-count fail-count error-count) pass-count fail-count error-count)
(goto-char (point-max)))))
;;;; utilities
;;;;; load and run tests automatically
(defparameter *testfile-name* nil)
(defparameter *testfile-last-update* nil)
(defun test-on-update ()
(when (and (file-exist-p *testfile-name*)
(> (file-write-time *testfile-name*) *testfile-last-update*))
(setf *testfile-last-update* (file-write-time *testfile-name*)
*change-tests* nil)
(load-test-file *testfile-name*)
(test-changes)
(refresh-screen)))
(defun watch-test-file (filename)
(interactive "ftest file: ")
(setf *testfile-name* filename
*testfile-last-update* (file-write-time filename))
(start-timer 1 'test-on-update))
(defun stop-watch-test-file ()
(interactive)
(while (stop-timer 'test-on-update)))
;;;;; compile and evaluate
(defmacro compile-and-eval (&body body)
`(funcall (compile nil (eval '(lambda () ,@body)))))
(setf (get 'compile-and-eval 'ed:lisp-indent-hook) 0)
;;; framework.l ends here.
Raw
nanri-master-change-tests.l
;;; -*- mode: lisp -*-
;; 2011-12-21 NANRI Masaoki <southly@gmail.com>
;;
;; * lisp : fix saving session file.
;; ヒストリファイルと同様にセッションファイルも書き込み時に *print-length*
;; などの影響を受けないよう修正。
;;
;; (progn
;; (ed::write-session-file "0ssn.l")
;; (let ((*print-circle* t)
;; (*print-pretty* nil)
;; (*print-length* 1)
;; (*print-level* 1))
;; (ed::write-session-file "1ssn.l")))
;;
;; * lisp : fix saving history-file.
;; ヒストリファイル書き込み時に *print-length* などの影響を受けるのを修正。
;;
;; (progn
;; (let ((*history-file-name* "0hist.l"))
;; (ed::save-history-file))
;; (let ((*history-file-name* "1hist.l")
;; (*print-circle* t)
;; (*print-pretty* nil)
;; (*print-length* 1)
;; (*print-level* 1))
;; (ed::save-history-file)))
;;
;; 2011-12-20 NANRI Masaoki <southly@gmail.com>
;;
;; * src : fix equalp for hash-table.
;; equalp に hash-table を渡すと多値が返ってくる問題を修正。
;; https://gist.github.com/1480046
;;
(deftest equalp-for-hash-table ()
(let ((a (make-hash-table))
(b (make-hash-table)))
(setf (gethash 1 a) "foo"
(gethash 1 b) "foo")
(equalp a b))
=> t)
;; 2011-06-17 NANRI Masaoki <southly@gmail.com>
;;
;; * src : fix sxhash.
;; sxhash の値が equalp 用の値になっているが equal 用の値になるように修正。
;; (= (sxhash (list "ABC")) (sxhash (list "ABC"))) => t
;; (= (sxhash (list "abc")) (sxhash (list "ABC"))) => nil
;;
;; NOTE: これは元からオッケー
; (deftest sxhash-fix-00 ()
; (= (sxhash (list "ABC")) (sxhash (list "ABC")))
; => t)
(deftest sxhash-fix-01 ()
(= (sxhash (list "abc")) (sxhash (list "ABC")))
=> nil)
;; 2011-06-15 NANRI Masaoki <southly@gmail.com>
;;
;; * lisp : fix compiling lambda form.
;; lambda form をコンパイルするとレキシカル変数を参照できなくなっていた問
;; 題を修正。
;; https://gist.github.com/998414
;; https://gist.github.com/1000096
;;
(deftest fix-compiling-lambda-form ()
(compile-and-eval
(let ((a 1))
((lambda () a))))
=> 1)
;; 2011-06-14 NANRI Masaoki <southly@gmail.com>
;;
;; * lisp : fix typo in lisp/compile.l.
;; 関数名のミスを修正。
;; https://twitter.com/#!/bowbow99/status/80332901014704128
;;
(deftest fix-typo-in-lisp/compile.l ()
(progn
(require "compile")
(functionp (get 'ninth (find-symbol "optimize-form" :compiler)))))
;; 2011-01-30 NANRI Masaoki <southly@gmail.com>
;;
;; * src : fix abbreviate-display-string.
;; abbreviate-display-string で必要以上に文字列が省略されることがあるのを
;; 修正。以下のようになる場合があった。
;; (abbreviate-display-string "D:/src/cmigemo-1.3c-MIT/src/wordlist.h" 40 t)
;; => "D:/..."
;;
;; string.cc の 1109 行目、以下のようになっていた。
;; strcpy (le, "...");
;; strcpy (le + 3, rb);
;; はじめの strcpy で '\0' が書き込まれ、その位置がちょうど rb と一致した
;; ときに発生した。
;;
(deftest fix-abbreviate-display-string ()
(abbreviate-display-string "D:/src/cmigemo-1.3c-MIT/src/wordlist.h" 40 t)
=> "D:/.../cmigemo-1.3c-MIT/src/wordlist.h")
;; 2011-01-21 NANRI Masaoki <southly@gmail.com>
;;
;; * lisp : fix pipe-command.
;; 「plink name@example.jp ls」と plink を利用しようとすると
;; 「Unable to read from standard input: ハンドルが無効です。」
;; というエラーになるのを修正。
;;
;; execute-shell-command の第二引数に文字列・nil以外の引数を渡すとファイル
;; 名が空のファイルを開こうとするので、エラーになっていた模様。
;;
;; TODO: (?_?)
;; * src : fix wheel icon.
;; なんとなくホイールボタンをクリックしたときのアイコンをいじってみた。
;;
;; NOTE: テスト不要かと。無理だし。
;; * src : fix multiple binding of special variables in let, let*.
;; http://d.hatena.ne.jp/bowbow99/20101127/1290818576
;; let や let* で同一のスペシャル変数に対して複数回の束縛を作ったときの値
;; がおかしいのを修正。
;; コンパイルしたときの動作は修正できていない。
;; (progn
;; (defparameter *special* :global)
;; (let ((*special* :local-1)
;; (*special* :local-2))
;; *special*))
;; => :local-2
;;
;; レキシカルな環境には逆順に登録されるので、スペシャル変数に値を設定する
;; 前に順序を元に戻している。
;;
(deftest fix-multiple-binding-of-special-variable-in-let/let*-00 ()
(progn
(defparameter *special* :global)
(let ((*special* :local-1)
(*special* :local-2))
*special*))
=> :local-2)
(deftest fix-multiple-binding-of-special-variable-in-let/let*-01 ()
(progn
(defparameter *special* :global)
(let* ((*special* :local-1)
(*special* :local-2))
*special*))
=> :local-2)
;; 2011-01-05 NANRI Masaoki <southly@gmail.com>
;;
;; * src : fix let, let*.
;; http://d.hatena.ne.jp/bowbow99/20101127/1290818576
;; コンパイルしたときは値が変わることはないが、インタプリタと同様に逆順で
;; 値をリストアするように修正。
;;
;; NOTE: これは元から壊れてない（挙動は変わってない）はず
; (deftest fix-let/let*-multiple-bind-for-special-variable-in-compiled-code ()
; (progn
; (defparameter *special* :global)
; (funcall
; (compile nil
; ;; NOTE: need empty lexenv to compile
; (eval '(lambda ()
; (let ((*special* :local-1)
; (*special* :local-2))
; *special*)))))
; *special*)
; => :global)
;; 2011-01-04 NANRI Masaoki <southly@gmail.com>
;;
;; * src : fix special variables restore at the end of let, let*.
;; http://d.hatena.ne.jp/bowbow99/20101127/1290818576
;; let や let* で同一のスペシャル変数に対して複数回の束縛を作ると、スコー
;; プが外れたときに値が書き換わってしまうのを修正。
;; (progn
;; (defparameter *special* :global)
;; (let ((*special* :local-1)
;; (*special* :local-2))
;; *special*)
;; *special*)
;; => :global
;;
;; 値を保存するとき(src/eval.cc 347行目辺り)と逆順に値をリストアするように
;; した。
;;
(deftest fix-special-variables-restore-at-the-end-of-let/let*-00 ()
(progn
(defparameter *special* :global)
(let ((*special* :local-1)
(*special* :local-2))
*special*)
*special*)
=> :global)
(deftest fix-special-variables-restore-at-the-end-of-let/let*-01 ()
(progn
(defparameter *special* :global)
(let* ((*special* :local-1)
(*special* :local-2))
*special*)
*special*)
=> :global)
;; 2010-12-14 NANRI Masaoki <southly@gmail.com>
;;
;; * src : fix eol-code of zero size file.
;; ファイルサイズが 0 のときの (正確には改行がないファイルのときの) 改行コー
;; ドが常に CRLF になるのを修正し *default-eol-code* に基づいた改行コード
;; になるようにする。
;; xyzzy Part16 577
;;
;; FIXME: 手元の xyzzy は nanri-master をいじったものでこの変更も入ってるはずなん
;; だけど fail する。何か勘違いしてる？
(deftest fix-eol-code-of-zero-size-file ()
(let ((name (make-temp-file-name))
buffer)
(with-open-file (out name :direction :output :if-does-not-exist :create))
(unwind-protect
(let ((*default-eol-code* *eol-lf*))
(declare (special *default-eol-code*))
(setq buffer (ed::find-file-internal name))
(buffer-eol-code buffer))
(delete-buffer buffer)))
=> 0)
;; 2010-12-13 NANRI Masaoki <southly@gmail.com>
;;
;; * src : fix DLL loading (hhctrl.ocx).
;; JVNVU#707943: Windows プログラムの DLL 読み込みに脆弱性
;; http://jvn.jp/cert/JVNVU707943/index.html
;; の修正の続き。
;; hhctrl.ocx のロードは静的変数の初期化時に行われるため、先の修正の効果が
;; 及ばない。よって、ロードのタイミングを関数 html-help 呼び出し時に変更。
;;
;; * src : fix DLL loading.
;; JVNVU#707943: Windows プログラムの DLL 読み込みに脆弱性
;; http://jvn.jp/cert/JVNVU707943/index.html
;; の修正。
;; 統合アーカイバの DLL と WSOCK32.DLL と ctl3d32.dll が対象。
;; foreign:define-dll-entry (si:load-dll-module) で指定する DLL も対象だが、
;; こちらはフルパスで指定するのが望ましいだろう。
;;
;; TODO: テキトーな dll を読み込んでテストする？？
;; 2010-12-12 NANRI Masaoki <southly@gmail.com>
;;
;; * src : update zlib(version 1.2.5).
;; zlibをバージョン1.2.5にアップデート。
;;
;; * lisp : support lzma and xz in filer.
;; lzma および xz の圧縮と展開をファイラから利用できるように修正。
;;
;; * src : support lzma and xz.
;; tar32.dll Ver2.35 から利用できるようになった lzma および xz の圧縮と展
;; 開に対応。
;;
;; TODO: よくわからんので後で。
;; 2010-12-11 NANRI Masaoki <southly@gmail.com>
;;
;; * src : fix hash-table.
;; rehash 時に不要なハッシュオブジェクトのエントリーを NULL に設定している
;; ので、サイズも 0 に設定する。hash-table のマークフェーズ(data.ccの613行
;; 目あたり)で NULL を参照するのを防止する。
;; 以下のような hash-table が rehash した後の GC のタイミングで落ちる現象
;; がおそらく解消すると思われる。
;; http://twitter.com/miyamuko/status/14229437114
;; http://d.hatena.ne.jp/knenet/20091223/1261578863
;;
;; TODO: xyzzy を起動するマクロ書く
;; 2010-12-10 NANRI Masaoki <southly@gmail.com>
;;
;; * src : fix (cdr '#1='#1#) printing.
;; http://blog.bugyo.tk/lyrical/archives/610
;; http://blog.practical-scheme.net/gauche/20100609-curious-circular-list
;; 「(cdr '#1='#1#)」の評価結果の印字でスタックオーバーフローするのを修正。
;; '#1='#1# => #1='#1#
;; (cdr '#1='#1#) => #1=((quote . #1#))
;; (cdr '#1=(quote #1#)) => #1=((quote . #1#))
;; (cdr '#1=(q #1#)) => #1=((q . #1#))
;;
;; FIXME: handler-case ではスタックオーバーフローを止められずテスト実行がクラッシュしてまう
;; FIXME: 手元の nanri-master をちょっといじったものだと「致命的な例外」だかで xyzzy 自体が
;; 落ちてしまう
; (deftest |fix (cdr '#1='#1#) printing| ()
; (write (cdr '#1='#1#) :circle t)
; >> #1=((quote . #1#))
; => #2=((quote . #2#)))
;; 2010-12-01 NANRI Masaoki <southly@gmail.com>
;;
;; * src : fix macroexpand.
;; http://twitter.com/bowbow99/status/9887141152694272
;; 二番目の戻り値が返っていなかったのを修正。
;; (macroexpand '(push 1 x))
;; => (setq x (cons 1 x))
;; => t
;; (macroexpand '(setq x (cons 1 x)))
;; => (setq x (cons 1 x))
;; => nil
;;
(deftest fix-macroexpand-00 ()
(macroexpand '(push 1 x))
=> (setq x (cons 1 x))
=> t)
(deftest fix-macroexpand-01 ()
(macroexpand '(setq x (cons 1 x)))
=> (setq x (cons 1 x))
=> nil)
;; * src : fix flet, labels, macrolet.
;; http://twitter.com/bowbow99/status/8011887295856640
;; 引数のチェックがおかしかったのを修正。
;; (flet () 3) => 3
;; (flet ()) => nil
;; (labels () 3) => 3
;; (labels ()) => nil
;; (macrolet () 3) => 3
;; (macrolet ()) => nil
;;
(deftest fix-flet/labels/macrolet-00 ()
(flet ()) => nil)
(deftest fix-flet/labels/macrolet-01 ()
(labels ()) => nil)
(deftest fix-flet/labels/macrolet-02 ()
(macrolet ()) => nil)
;; * src : add "listp" Macro.
;; オブジェクトが cons である、又は nil であるかどうか調べる listp マクロ
;; を追加。
;;
;; 2010-11-09 NANRI Masaoki <southly@gmail.com>
;;
;; * src : fix type-check in list-length.
;; http://twitter.com/bowbow99/status/1742537278623744
;; (list-length :foo)
;; -> 不正なデータ型です: :foo: list
;; (list-length '(a . b))
;; -> 不正なデータ型です: b: list
;;
;; 引数にdotted listを渡したときのエラーメッセージがいまいちだが、
;; とりあえずそのまま。
;;
(deftest fix-type-check-in-list-length-00 ()
(list-length :foo)
!! type-error)
(deftest fix-type-check-in-list-length-01 ()
(list-length '(a . b))
!! type-error)
;; * src : fix nthcdr given dotted list.
;; http://twitter.com/bowbow99/status/1746294087352320
;; (nthcdr 0 '()) => nil
;; (nthcdr 3 '()) => nil
;; (nthcdr 0 '(a b c)) => (a b c)
;; (nthcdr 2 '(a b c)) => (c)
;; (nthcdr 4 '(a b c)) => nil
;; (nthcdr 1 '(0 . 1)) => 1
;; (nthcdr 3 '(0 . 1)) => nil
;;
;; 最後のケースはエラーにすべきだけど、とりあえずそのまま。
;;
;; NOTE: 05 以外は元からちゃんと動く
; (deftest fix-nthcdr-given-dotted-list-00 ()
; (nthcdr 0 '()) => nil)
; (deftest fix-nthcdr-given-dotted-list-01 ()
; (nthcdr 3 '()) => nil)
; (deftest fix-nthcdr-given-dotted-list-02 ()
; (nthcdr 0 '(a b c)) => (a b c))
; (deftest fix-nthcdr-given-dotted-list-03 ()
; (nthcdr 2 '(a b c)) => (c))
; (deftest fix-nthcdr-given-dotted-list-04 ()
; (nthcdr 4 '(a b c)) => nil)
(deftest fix-nthcdr-given-dotted-list-05 ()
(nthcdr 1 '(0 . 1)) => 1)
; (deftest fix-nthcdr-given-dotted-list-06 ()
; (nthcdr 3 '(0 . 1)) => nil)
;; * src : fix single-float-epsilon, single-float-negative-epsilon.
;; http://twitter.com/TwilightClover/status/26251344464
;; http://gist.github.com/608561
;; http://gist.github.com/608467
;; (dolist (sym '((double-float-epsilon t)
;; (double-float-negative-epsilon nil)
;; (long-float-epsilon t)
;; (long-float-negative-epsilon nil)
;; (short-float-epsilon t)
;; (short-float-negative-epsilon nil)
;; (single-float-epsilon t)
;; (single-float-negative-epsilon nil)))
;; (let ((epsilon (symbol-value (car sym)))
;; (positive (cadr sym)))
;; (format t "~30S = ~@30S, test = ~S~%"
;; (car sym)
;; epsilon
;; (if positive
;; (not (= (float 1 epsilon) (+ (float 1 epsilon) epsilon)))
;; (not (= (float 1 epsilon) (- (float 1 epsilon) epsilon)))))
;; ))
;; double-float-epsilon = 2.220446049250313d-16, test = t
;; double-float-negative-epsilon = 1.110223024625157d-16, test = t
;; long-float-epsilon = 2.220446049250313d-16, test = t
;; long-float-negative-epsilon = 1.110223024625157d-16, test = t
;; short-float-epsilon = 1.192093e-7, test = t
;; short-float-negative-epsilon = 5.960464e-8, test = t
;; single-float-epsilon = 1.192093e-7, test = t
;; single-float-negative-epsilon = 5.960464e-8, test = t
;; nil
;;
(deftest fix-single-float-eplilon ()
(dolist (sym '((double-float-epsilon t)
(double-float-negative-epsilon nil)
(long-float-epsilon t)
(long-float-negative-epsilon nil)
(short-float-epsilon t)
(short-float-negative-epsilon nil)
(single-float-epsilon t)
(single-float-negative-epsilon nil)))
(let ((epsilon (symbol-value (car sym)))
(positive (cadr sym)))
(format t "~30S = ~@30S, test = ~S~%"
(car sym)
epsilon
(if positive
(not (= (float 1 epsilon) (+ (float 1 epsilon) epsilon)))
(not (= (float 1 epsilon) (- (float 1 epsilon) epsilon)))))
))
>> double-float-epsilon = 2.220446049250313d-16, test = t
>> double-float-negative-epsilon = 1.110223024625157d-16, test = t
>> long-float-epsilon = 2.220446049250313d-16, test = t
>> long-float-negative-epsilon = 1.110223024625157d-16, test = t
>> short-float-epsilon = 1.192093e-7, test = t
>> short-float-negative-epsilon = 5.960464e-8, test = t
>> single-float-epsilon = 1.192093e-7, test = t
>> single-float-negative-epsilon = 5.960464e-8, test = t
>>
=> nil
)
;; 2010-09-30 MIYAMUKO Katsuyuki <miyamuko@gmail.com>
;;
;; * src : add deleted-window-p
;; 削除された Window なら t を返す。
;; deleted-buffer-p の Window バージョン。
;; http://twitter.com/bowbow99/status/25935896653
;;
;; NOTE: 自前で用意してた場合 pass してしまう。
(deftest add-deleted-window-p-00 ()
(fboundp 'deleted-window-p))
;; NOTE: 自前で用意してた場合 pass してしまう。
(deftest add-deleted-window-p-01 ()
(let ((current (selected-window))
(new (save-window-excursion
(split-window -20)
(selected-window))))
(deleted-window-p new)))
(deftest add-deleted-window-p-02 ()
(si:*builtin-function-p (symbol-function 'deleted-window-p)))
;; 2010-09-12 MIYAMUKO Katsuyuki <miyamuko@gmail.com>
;;
;; * src : add optional value parameter to si:putenv.
;; 引数を環境変数名とオプショナルな値をとるように変更。
;; 値を省略した場合や nil を指定した場合は環境変数を削除する。
;; 戻り値は環境変数の設定に成功した場合は設定した値を返し、
;; 環境変数を削除した場合または設定に失敗した場合は nil を返すように変更。
;; (si:putenv "FOO" "bar")
;; => "bar"
;; (si:putenv "FOO")
;; => nil
;; (si:putenv "=FOO" "bar")
;; => nil
;;
(deftest add-putenv-00 ()
(multiple-value-bind (sym class)
(find-symbol "putenv" :system)
class)
=> :external)
(deftest add-putend-01 ()
(fboundp (find-symbol "putenv" :system)))
(deftest add-putenv-02 ()
(funcall (find-symbol "putenv" :system) "FOO" "bar")
=> "bar")
(deftest add-putenv-03 ()
(progn
(funcall (find-symbol "putenv" :system) "FOO" "baz")
(si:getenv "FOO"))
=> "baz")
(deftest add-putenv-04 ()
(values
(funcall (find-symbol "putenv" :system) "FOO" nil)
(si:getenv "FOO"))
=> nil
=> nil)
;; 2010-09-11 NANRI Masaoki <southly@gmail.com>
;;
;; * src : remove redefinition.
;; Microsoft Visual C++ 2010 では wingdi.h がインクルードされて、
;; tagWCRANGE と tagGLYPHSET が定義されるようなので gen-fontrange.cc での
;; 定義を削除。
;; とりあえずVC2010でのみ削除。
;;
;; * src : remove pragma optimize.
;; 「internal compiler error」対策とのコメントがあるが、Microsoft Visual
;; C++ 2010 ではエラーが発生しないので削除。
;; とりあえずVC2010でのみ削除。
;;
;; * src : add si:putenv.
;; si:putenv を追加。
;; via http://d.hatena.ne.jp/miyamuko/20100910/xyzzy_putenv
;;
;; NOTE: その後変更されてるんでそっちでテスト
;; 2010-08-31 NANRI Masaoki <southly@gmail.com>
;;
;; * src : fix call-process.
;; call-processの標準入力・標準出力等の指定がうまく設定されない現象がおき
;; ていたのを修正。
;;
;; FIXME: command prompt が一瞬表示されるのうざい
;; FIXME: 0.2.2.235 で pass してしまう。どういう場合に上手く設定されないのかわからん。
; (deftest fix-call-process-input/output ()
; (labels ((make-file (name &optional contents)
; (with-open-file (out name
; :direction :output
; :if-does-not-exist :create)
; (when (princ contents out)))
; name))
; (let ((infile (make-file (make-temp-file-name) "hello"))
; (outfile (make-file (make-temp-file-name) "")))
; (call-process "sort" :input infile :output outfile :wait t)
; (unwind-protect
; (with-open-file (in outfile :direction :input)
; (read in))
; (delete-file infile)
; (delete-file outfile))))
; => hello
; )
;; 2010-07-14 NANRI Masaoki <southly@gmail.com>
;;
;; * src : fix format "~T".
;; 「~colnum,colincT」のとき、「colnum+k*colinc」を満たす最小の正の整数kで
;; 桁を求めるように修正。
;; (format nil "~0,1T")
;; => " "
;;
(deftest fix-format-T ()
(format t "~0,1Tx")
>> x
=> nil)
;; * src : fox format "~VT" in the case of being provided '() as a prefix parameter.
;; Vに引数としてnilを渡したときの動作を修正。
;; (format t "~VA" nil 'x)
;; == (format t "~A" 'x)
;;
(deftest fix-format-VT ()
(format t "~VA" nil 'x)
>> x
=> nil)
;; * src : fix for VC2010.
;; Microsoft Visual C++ 2010 でのビルド用に修正。
;; Makefileの修正のみ。
;;
;; 2010-04-04 NANRI Masaoki <southly@gmail.com>
;;
;; * src : add repl.
;; コマンドプロンプトを表示するバージョンxyzzyrpl.exeを作成できるようにし
;; た。「nmake repl」で作成できる。
;;
;; ;;; 簡易REPL
;; (defun repl ()
;; (interactive)
;; (let ((*standard-input* *terminal-io*)
;; (*standard-output* *terminal-io*))
;; (loop
;; (format t "~%> ")
;; (format t "~A" (eval (read *standard-input*))))))
;;
;; NOTE: merge されてない（xyzzy Part17 >>593 http://toro.2ch.net/test/read.cgi/win/1303662374/593）
;; 2010-03-01 NANRI Masaoki <southly@gmail.com>
;;
;; * src : fix "*load-pathname*" initialization.
;; ダンプ作成時にロードしたファイル名がそのままダンプファイルに保存される
;; ようなので、起動時にも初期化するように修正。
;;
;; TODO: xyzzy を起動するマクロ書く
;; * src : fix format "~F".
;; formatの"~F"の第一パラメータwを指定しないと第三パラメータkが機能しない
;; のを修正。
;;
;; (dotimes (i 10)
;; (format t "~,,VF~%" i pi))
;; 3.141592653589793
;; 31.41592653589793
;; 314.1592653589793
;; 3141.592653589793
;; 31415.92653589793
;; 314159.2653589793
;; 3141592.653589793
;; 31415926.53589793
;; 314159265.3589793
;; 3141592653.589793
;; nil
;;
;; (do ((i -9 (1+ i)))
;; ((> i 9))
;; (format t "~,,VF~%" i pi))
;; -0.000000009
;; -0.00000008
;; -0.0000007
;; -0.000006
;; -0.00005
;; -0.0004
;; -0.003
;; -0.02
;; -0.1
;; 0.0
;; 10.0
;; 200.0
;; 3000.0
;; 40000.0
;; 500000.0
;; 6000000.0
;; 70000000.0
;; 800000000.0
;; 9000000000.0
;; nil
;;
(deftest fix-format-F-01 ()
(dotimes (i 10)
(format t "~,,VF~%" i pi))
>> 3.141592653589793
>> 31.41592653589793
>> 314.1592653589793
>> 3141.592653589793
>> 31415.92653589793
>> 314159.2653589793
>> 3141592.653589793
>> 31415926.53589793
>> 314159265.3589793
>> 3141592653.589793
>>
=> nil
)
(deftest fix-format-F-02 ()
(do ((i -9 (1+ i)))
((> i 9))
(format t "~,,VF~%" i i))
>> -0.000000009
>> -0.00000008
>> -0.0000007
>> -0.000006
>> -0.00005
>> -0.0004
>> -0.003
>> -0.02
>> -0.1
>> 0.0
>> 10.0
>> 200.0
>> 3000.0
>> 40000.0
>> 500000.0
>> 6000000.0
>> 70000000.0
>> 800000000.0
>> 9000000000.0
>>
=> nil
)
;; 2010-02-21 NANRI Masaoki <southly@gmail.com>
;;
;; * src : fix applyhook.
;; applyhook, *applyhook* をローカル関数に対応させた。
;; call_applyhookの第一引数にクロージャを渡すように変更した。
;;
(deftest fix-applyhook-00 ()
(let ((*applyhook* (lambda (fn args)
(functionp fn))))
(car 1)))
;; * src : add "*read-eval*".
;; スペシャル変数*read-eval*が機能するようにした。
;; *read-eval*の出力への影響の理解が怪しい。
;; *read-eval*がnilの場合はencodingをunreadable-objectとして出力するようし
;; ているが、自信なし。
;;
(deftest add-*read-eval*-00 ()
(si:*specialp '*read-eval*))
(deftest add-*read-eval*-01 ()
(let ((*read-eval* nil))
(read-from-string "#.(+ 1 2)"))
!! reader-error)
;; TODO: 出力への影響？
;; 2010-01-23 NANRI Masaoki <southly@gmail.com>
;;
;; * src : fix for VC2008.
;; Microsoft Visual C++ 2008 でのビルド用に修正。
;; http://xyzzy.s53.xrea.com/wiki/index.php?Memo%2F%A5%BD%A1%BC%A5%B9%A4%AB%A4%E9%A5%D3%A5%EB%A5%C9%A4%B7%A4%C6%A4%DF%A4%EB3
;;
;; NOTE: テストはいらんと思うけど、commit 見当たらない。
;; * src : add get-buffer-colors.
;; 関数get-buffer-colorsを追加。
;; set-buffer-colorsと対となる現在のバッファの色設定を取得する関数。
;;
;; NOTE: もうちょっとちゃんとテストした方が良いと思います。。。
(deftest add-get-buffer-colors ()
(fboundp 'get-buffer-colors))
;; 2010-01-22 NANRI Masaoki <southly@gmail.com>
;;
;; * src : fix listen.
;; EOFのときにnilを返すように修正。
;; 分かる範囲ということでstring-streamとfile-streamだけ。
;;
(deftest fix-listen-for-string-stream ()
(let ((stream (make-string-input-stream "")))
(listen stream))
=> nil)
(deftest fix-listen-for-file-stream ()
(let* ((file (make-temp-file-name))
(buffer (ed::find-file-internal file)))
(save-excursion
(with-set-buffer
(set-buffer buffer)
(save-buffer)))
(unwind-protect
(with-open-file (in file :direction :input)
(listen in))
(delete-buffer buffer)))
=> nil)
;; 2010-01-11 NANRI Masaoki <southly@gmail.com>
;;
;; * src : fix save-window-excursion.
;; (save-window-excursion (values 1 2 3))
;; で正しく多値が返らない場合があるのを修正。
;; xyzzy Part11 8 http://www.bookshelf.jp/2ch/win/1085301777.html
;;
;; FIXME: 未修正でも正しく多値が返ることもあるみたいなので、その時は pass してしまう
(deftest fix-save-window-excursion ()
(save-window-excursion (values 1 2 3))
=> 1
=> 2
=> 3)
;; WindowConfigurationのデストラクタ内でLispのコードが実行されるので、
;; WindowConfigurationのデストラクタを実行したあとで、多値を元の値に戻
;; す必要がある。
;;
;; * lisp : fix long-operation.
;; long-operationの戻り値がprog1相当になっているのをprogn相当になるよ
;; うに修正。
;; xyzzy Part10 470
;;
(deftest fix-long-operation ()
(long-operation
1
2)
=> 2)
;; 2009-12-26 NANRI Masaoki <southly@gmail.com>
;;
;; * src : update zlib.
;; zlibをバージョン1.2.3にアップデート。
;;
;; FIXME: テストする方法が思いつかない、というかテスト必要なんだろうか
;; 2009-12-17 NANRI Masaoki <southly@gmail.com>
;;
;; * lisp : modify tags-setup-buffer.
;; XTAGSファイルを探す位置を少々変更。
;;
;; NOTE: merge されてない（xyzzy Part17 >>593 http://toro.2ch.net/test/read.cgi/win/1303662374/593）
;; * lisp : modify edict-lookup-word.
;; 辞書を引く単語をカーソルの前方に変更。
;;
;; NOTE: merge されてない（xyzzy Part17 >>593 http://toro.2ch.net/test/read.cgi/win/1303662374/593）
;; * lisp : modify start point in buffer-menu.
;; buffer-menuを実行したときのカーソル位置を現在のバッファの位置に変更。
;;
;; NOTE: merge されてない（xyzzy Part17 >>593 http://toro.2ch.net/test/read.cgi/win/1303662374/593）
; (deftest modify-start-point-in-buffer-menu ()
; (let ((buffers '()))
; (do ((i 0 (1+ i)))
; ((>= i 4))
; (push (create-new-buffer "*Test Example*") buffers))
; (prog1
; (save-window-excursion
; (with-set-buffer
; (set-buffer (car buffers))
; (buffer-menu)
; (and (bolp)
; (looking-at "^\\."))))
; (dolist (b buffers)
; (delete-buffer b)))))
;; * src : add key parameter ":show" to make-process.
;; make-processにキーパラメータ :show を追加する。
;; http://xyzzy.s53.xrea.com/wiki/index.php?patch%2F12
;;
;; FIXME: テストする方法が思いつかない
;; 2009-12-16 NANRI Masaoki <southly@gmail.com>
;;
;; * src : support IMR_DOCUMENTFEED.
;; via http://fixdap.com/p/xyzzy/7376/
;; 以下で動作を確認。
;; さいた　　　　　あたたかい
;; 布を　　　　　　牛乳
;; 花が　　　　　　春
;; 時間を　　　　　
;;
;; FIXME: テストする方法が思いつかない
;; * src : fix set-buffer-modified-p.
;; (set-buffer-modified-p nil) をした時に以前更新なし状態だった点が更
;; 新無し状態のままなのを修正。
;;
;; TODO: 変更の内容がよくわからんので後回し
; (deftest fix-set-buffer-modified-p ()
; (let ((buffer (create-new-buffer "*Example*")))
; (set-buffer-modified-p nil buffer)
; (buffer-modified-p buffer))
; => nil)
;; * src : fix inverse-cursor-line.
;; (setq inverse-cursor-line t)
;; の状態にすると行カーソルと折り返し線の交点が反転したまま残ってしま
;; うのを修正。
;;
;; FIXME: テストする方法が思いつかない
;; 2009-12-10 NANRI Masaoki <southly@gmail.com>
;;
;; * src : fix format "~n@A".
;; http://d.hatena.ne.jp/bowbow99/20090829/1251547986
;;
;; NOTE: merge されてなさげ（これは外したのかも）
(deftest fix-format-n@A ()
(format t "~10@A" "foo")
>> foo
=> nil)
;; 2009-12-09 NANRI Masaoki <southly@gmail.com>
;;
;; * src : add "*brackets-is-wildcard-character*" to history-variable.
;; 共通設定の「[...]はワイルドカード」の設定が保存されないので、対応す
;; る変数をヒストリに追加。
;;
(deftest add-*brackets-is-wildcard-character*-to-history-variable ()
(member '*brackets-is-wildcard-character* ed::*history-variable-list*))
;; * src : fix dump hash-table.
;; シンボルがキーのハッシュテーブルをダンプファイルに入れた場合、
;; gethashで値がとれない問題があった。ただし、maphashで全要素を取得す
;; ることはできた。
;; ---- $XYZZY/site-lisp/siteinit.l の内容
;; (defparameter *hash* (make-hash-table))
;; (dolist (i '((aaa . abab) (bbb . bcbc) (ccc . cdcd)))
;; (setf (gethash (car i) *hash*) (cdr i)))
;; ---- ダンプファイルをロードしたあとに評価
;; (gethash 'aaa *hash*)
;; =>nil ; 本来は abab
;; =>nil ; t
;;
;; (maphash #'(lambda (key val) (format t "~S: ~S~%" key val)) *hash*)
;; aaa: abab
;; bbb: bcbc
;; ccc: cdcd
;; =>nil
;; ----
;; シンボルのハッシュ値はオブジェクトのアドレスを元に計算しているが、
;; ダンプファイル作成時とダンプファイルロード後ではシンボルオブジェク
;; トのアドレスが異なり、同一のハッシュ値にならないのが原因。
;;
;; ダンプファイルをロードしたあとにrehashするように修正。
;;
;; * lisp : fix defpackage.
;; defpackageマクロで:exportオプションを指定できない不具合を修正。
;; [xyzzy:09241]
;;
;; * lisp : fix shell-alternate-send-input.
;; http://xyzzy.s53.xrea.com/wiki/index.php?patch%2F15
;;
;; * lisp : fix calendar.
;; カレンダーの祝日を現行法にあわせる。
;; [xyzzy:09224]
;;
;; * lisp : fix typo in lisp/timestmp.l.
;; コメントのtypoを修正。
;; [xyzzy:09158]
;;
;; * lisp : fix typo in lisp/encoding.l.
;; provideのtypoを修正。
;; [xyzzy:09158]
;;
(deftest fix-typo-in-lisp/encoding.l ()
(modulep "encoding"))
;; * lisp : fix typo in lisp/css-mode.l.
;; provideのtypoを修正。
;; [xyzzy:09158]
;;
(deftest fix-typo-in-lisp/css-mode.l ()
(progn
(require "css-mode")
(and (modulep "css-mode")
(not (modulep "cssmode")))))
;; * lisp : fix typo in lisp/builtin.l.
;; 主に引数のtypoを修正。
;; [xyzzy:09158]
;;
;; TODO: 数が多いんで後回し
;; * src : fix hash-table rehash size.
;; ハッシュテーブルの要素数が80000を越える辺りから、ハッシュテーブルの
;; サイズの増加量が100に固定される。そのため頻繁にrehashされパフォーマ
;; ンスが低下していた。
;; rehashするときは最低でも前のサイズの1.5倍になるようにした。
;;
;; NOTE: やたらと時間掛かるんで保留
;; Ref: https://gist.github.com/227683
;; * src : fix ole-method.
;; ole-method で文字列を渡すと余計な 0x00 が付く問題
;; via http://fixdap.com/p/xyzzy/8379/
;; via http://d.hatena.ne.jp/miyamuko/20080304/xyzzy_ole_method_bug
;;
;; TODO: どうやってテストすりゃいいもんか miyamuko さんに聞く
;; * src : fix for FFI.
;; 戻り値が double, float の C 関数を呼ぶとクラッシュする
;; http://xyzzy.s53.xrea.com/wiki/index.php?patch%2F25
;; via http://d.hatena.ne.jp/miyamuko/20070509/p1
;;
;; TODO: xyzzy を起動するマクロ書く
;; * src : fix start-timer.
;; http://xyzzy.s53.xrea.com/wiki/index.php?patch%2F21
;;
; ;; FIXME: *scratch* では動くんだけどテストにすると返ってこなくなるっぽい
; (let ((n 0)
; (start (get-internal-real-time))
; thunk
; (finish nil))
; (setf thunk (lambda ()
; (when (>= (incf n) 3)
; (stop-timer thunk)
; (setf finish (get-internal-real-time)))))
; (start-timer 1 thunk)
; (while (not finish)
; (sleep-for 0.2))
; (> (- finish start) 2900))
;; * src : fix format "~G".
;; [xyzzy:09204]
;;
;; http://hie.s64.xrea.com/xyzzy/ml/msg09203.html
(deftest fix-format-G ()
(format t "~10g" 1.23456d+38)
>> 123456000000000000000000000000000000000.0
=> nil)
;; * src : fix format "~E".
;; [xyzzy:09204]
;;
;; http://hie.s64.xrea.com/xyzzy/ml/msg09202.html
(deftest fix-format-E-00 ()
(format t "~E" 123.45)
>> 1.2345e+2
=> nil)
(deftest fix-format-E-01 ()
(format t "~0E" 123.45)
>> 1.2345e+2
=> nil)
;; * src : fix format "~F".
;; [xyzzy:09204]
;;
;; http://hie.s64.xrea.com/xyzzy/ml/msg09202.html
(deftest fix-format-F-00 ()
(format t "~@F" 123.45)
>> +123.45
=> nil)
;; * src : fix format "~R".
;; [xyzzy:09198] http://hie.s64.xrea.com/xyzzy/ml/msg09197.html
;;
(deftest fix-format-R ()
(format t "~16,10,'*,'-,2:R" #x123abc)
>> **12-3a-bc
=> nil)
;; * src : fix for VC2005.
;; Microsoft Visual C++ 2005 でビルドできるように、こまごまと修正。
;; http://xyzzy.s53.xrea.com/wiki/index.php?patch%2F13
;;
;(when (yes-or-no-p "今すぐテストする？")
; (test-changes))
;; ;;; nanri-master-change-tests.l ends here.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment