disassemble.lsp 2.38 KB
Newer Older
pfdietz's avatar
pfdietz committed
1 2 3 4 5
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sun May 18 20:47:58 2003
;;;; Contains: Tests of DISASSEMBLE

6

pfdietz's avatar
pfdietz committed
7 8 9 10 11 12 13

(defun disassemble-it (fn)
  (let (val)
    (values
     (notnot
      (stringp
       (with-output-to-string (*standard-output*)
sds's avatar
sds committed
14
                              (setf val (disassemble fn)))))
pfdietz's avatar
pfdietz committed
15 16 17 18 19 20 21 22 23 24 25 26 27 28 29
     val)))

(deftest disassemble.1
  (disassemble-it 'car)
  t nil)

(deftest disassemble.2
  (disassemble-it (symbol-function 'car))
  t nil)

(deftest disassemble.3
  (disassemble-it '(lambda (x y) (cons y x)))
  t nil)

(deftest disassemble.4
30
  (disassemble-it (eval '(function (lambda (x y) (cons x y)))))
pfdietz's avatar
pfdietz committed
31 32 33
  t nil)

(deftest disassemble.5
34 35
  (disassemble-it
   (funcall (compile nil '(lambda () (let ((x 0)) #'(lambda () (incf x)))))))
pfdietz's avatar
pfdietz committed
36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51
  t nil)

(deftest disassemble.6
  (let ((name 'disassemble.fn.1))
    (fmakunbound name)
    (eval `(defun ,name (x) x))
    (disassemble-it name))
  t nil)

(deftest disassemble.7
  (let ((name 'disassemble.fn.2))
    (fmakunbound name)
    (eval `(defun ,name (x) x))
    (compile name)
    (disassemble-it name))
  t nil)
52 53 54 55

(deftest disassemble.8
  (progn
    (eval '(defun (setf disassemble-example-fn) (val arg)
sds's avatar
sds committed
56
             (setf (car arg) val)))
57 58 59 60 61 62 63 64 65 66 67 68 69 70 71
    (disassemble-it '(setf disassemble-example-fn)))
  t nil)

(deftest disassemble.9
  (progn
    (eval '(defgeneric disassemble-example-fn2 (x y z)))
    (disassemble-it 'disassemble-example-fn2))
  t nil)

(deftest disassemble.10
  (progn
    (eval '(defgeneric disassemble-example-fn3 (x y z)))
    (eval '(defmethod disassemble-example-fn3 ((x t)(y t)(z t)) (list x y z)))
    (disassemble-it 'disassemble-example-fn3))
  t nil)
72

73 74 75 76 77 78 79 80 81
(deftest disassemble.11
  (let ((fn 'disassemble-example-fn4))
    (when (fboundp fn) (fmakunbound fn))
    (eval `(defun ,fn (x) x))
    (let ((is-compiled? (typep (symbol-function fn) 'compiled-function)))
      (multiple-value-call
       #'values
       (disassemble-it fn)
       (if is-compiled? (notnot (typep (symbol-function fn) 'compiled-function))
sds's avatar
sds committed
82
         (not (typep (symbol-function fn) 'compiled-function))))))
83 84
  t nil t)

85 86 87 88 89 90 91 92 93 94 95 96
;;; Error tests

(deftest disassemble.error.1
  (signals-error (disassemble) program-error)
  t)

(deftest disassemble.error.2
  (signals-error (disassemble 'car nil) program-error)
  t)

(deftest disassemble.error.3
  (check-type-error #'disassemble
sds's avatar
sds committed
97
                    (typef '(or function symbol (cons (eql setf) (cons symbol null)))))
98 99
  nil)