home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / LISP / PDLISP.ZIP / TEST.L < prev   
Encoding:
Text File  |  1986-04-28  |  4.4 KB  |  202 lines
  1. ; test.l - Copyright (c) 1984 by David Morein
  2. ; this file contains miscellaneous test functions.
  3. ; every expression should return T as the file is LOADV'ed
  4. ;
  5. ; arithmetic functions:
  6. ;
  7.  
  8. "testing arithmetic functions:"
  9.  
  10. (equal 4   (setq a 4))
  11. (equal t   (atom 'a))
  12. (equal nil (atom '(a b)))
  13. (equal t   (numberp 432))
  14. (equal 'a  (setq b 'a))
  15. (equal nil (numberp b))
  16. (equal 4   (setq a 4))
  17. (equal 5   (setq b 5))
  18. (equal 0   (div a b))
  19. (equal 1   (div b a))
  20. (equal 1   (mod b a))
  21. (equal 4   (mod a b))
  22. (equal 20  (* a b))
  23. (equal 1   (- b a))
  24. ;
  25. ; logic functions:
  26. ;
  27.  
  28. "testing logic functions:"
  29.  
  30. (equal t   (and t t))
  31. (equal nil (and t nil))
  32. (equal nil (and nil t))
  33. (equal t   (or t t))
  34. (equal t   (or t nil))
  35. (equal t   (or nil t))
  36. (equal nil (or nil nil))
  37. (equal t   (not nil))
  38. (equal nil (not t))
  39. ;
  40. ; string functions
  41.  
  42. "testing string functions"
  43.  
  44. (streq "abcde" "abcde")
  45. (eql 0 (strcmp "abcde" "abcde"))
  46. (eql 5 (strlen "abcde"))
  47. (streq "abcdef" (strcat "abc" "def"))
  48. ;
  49. ; set functions:
  50. ;
  51.  
  52. "testing set functions"
  53.  
  54. (equal '(b c) (member 'b '(a b c)))
  55. (equal '(b c) (membq  'b '(a b c)))
  56. ;
  57. ; apply & funcall:
  58. ;
  59. "testing apply & funcall"
  60. (equal '((+ 2 3) . 5) (apply 'cons '((+ 2 3) 5)))
  61. (equal '(1 . 2) (funcall 'cons 1 2))
  62. ;
  63. ; mapping functions:
  64. ;
  65. "testing mapping functions"
  66. ;
  67. ; from Hasemer [1984], p244
  68. (equal '((a b) (c d) (e f)) (setq q '((a b) (c d) (e f))))
  69. (equal '(a c e) (mapcar 'car q))
  70. ;
  71. ; from Steele [1984], p128, without functional closure:
  72. (equal '((a . 1) (b . 2) (c . 3)) (mapcar 'cons '(a b c) '(1 2 3)))
  73. ;
  74. ; from Steele [1984], p128
  75. (equal 'foo (defun foo (x) (and (numberp x) (list x))))
  76. (equal '(1 2 3 4) (mapcan 'foo '(a 1 b c 2 3 d 4)))
  77. ;
  78. ; from ???
  79. ;
  80. (equal 'square (defun square (n) (* n n)))
  81. (equal 'square-list (defun square-list (l) (mapcar 'square l)))
  82. (equal '(4 9) (square-list '(2 3)))
  83. ;
  84. ; define consfoo:
  85. (equal 'consfoo (defun consfoo (x) (cons 'foo x)))
  86. ;
  87. ; apply consfoo through maplist:
  88. (equal '((foo a b c d) (foo b c d) (foo c d) (foo d))
  89.         (maplist 'consfoo '(a b c d)))
  90. ;
  91. ; see if we get the same result with an anonymous form:
  92. (equal '((foo a b c d) (foo b c d) (foo c d) (foo d))
  93.         (maplist '(lambda (x) (cons 'foo x)) '(a b c d)))
  94. ;
  95. ; miscellaneous tests:
  96. (equal '((a . x) (b . y)) (mapcar  'cons '(a b) '(x y)))
  97. (equal '(((a b) x y) ((b) y)) (maplist 'cons '(a b) '(x y)))
  98. ;
  99. ; do:
  100. ;
  101.  
  102. "testing do"
  103.  
  104. (equal 'our-expt
  105.   (defun our-expt (m n)
  106.     (do ((result 1)                     ;initialize result to 1
  107.          (exponent n))                  ;initialize exponent to n
  108.          ((zerop exponent) result)      ;termination test
  109. ;
  110. ; body of do:
  111. ;
  112.          (setq result (* m result))
  113.          (setq exponent (- exponent 1)))))
  114. ;
  115. (equal 16 (our-expt 2 4))
  116. (equal 32 (our-expt 2 5))
  117. ;
  118. ; misc predicates:
  119. ;
  120. (eql t (consp '(a . b)))
  121. (eql nil (consp nil))
  122. (eql t (listp '(a b)))
  123. (eql t (listp nil))
  124. (eql nil (listp 'a))
  125. ;
  126. ; macros:
  127. ;
  128. "testing macros"
  129. ;
  130. (eql 'mactest 
  131.     (def mactest (macro (arg1 arg2)
  132.         (list 'cons arg1 arg2))))
  133. ;
  134. (eql 'mac1
  135.     (def mac1 (lambda (a b)
  136.         (mactest a b))))
  137. ;
  138. ; the following should return (1 . 2)
  139. ;
  140. (equal '(1 . 2) (mac1 1 2))
  141. ;
  142. ;
  143. "testing backquote"
  144. (eq 'bqtest (def bqtest (macro (carpart cdrpart)
  145.         `(cons ,carpart ,cdrpart))))
  146. ;
  147. (equal '(1 . 2) (bqtest 1 2))
  148. ;
  149. (equal '(silvery moon) (setq planetoid '(silvery moon)))
  150. ;
  151. (equal '(by the light of the silvery moon)
  152.        `(by the light of the ,@planetoid))
  153. ;
  154. ;
  155. ; miscellaneous tests of catch, throw, err, and errset:
  156. ;
  157. "testing catch and throw"
  158. ;
  159. ; ctest1 just tests a simple THROW to an enclosing CATCH
  160. ;
  161. (eql 'ctest1 (
  162.     (def ctest1 (lambda (x)
  163.         (catch 'cflag (throw 'cflag x))))))
  164. ;
  165. (eql 4 (ctest1 4))
  166. ;
  167. ;
  168. ; ctest2 tests a throw to a catch which has a list of tags
  169. ; which it is supposed to intercept
  170. ;
  171. (eql 'ctest2 (
  172.     (def ctest2 (lambda (x)
  173.         (catch '(cflag1 cflag2 cflag3) (throw 'cflag2 x))))))
  174. ;
  175. (eql 5 (ctest2 5))
  176. ;
  177. ; ctest3 tests a throw to a catch which has a tag of NIL
  178. ;
  179. (eql 'ctest3 (
  180.     (def ctest3 (lambda (x)
  181.         (catch '() (throw nil x))))))
  182. ;
  183. (eql 7 (ctest3 7))
  184. ;
  185. ;
  186.  
  187. "loading examples"                    ;herald examples
  188.  
  189. (load "examples.l")                    ;load examples
  190.  
  191. "testing examples"                    ;run examples
  192.  
  193. ;
  194. (eql 233 (rfib 12))
  195. (eql 610 (rfib 14))
  196. (eql 40320 (ifact 8))
  197. (eql 479001600 (ifact 12))
  198. (equal '(a b c d e f) (app '(a b c) '(d e f)))
  199. ;
  200. ;
  201. ;end of file
  202.