home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-1.LHA / CLISP960530-sr.lha / tests / genstream.tst < prev    next >
Encoding:
Text File  |  1996-04-15  |  8.5 KB  |  259 lines
  1. ;;; This test program creates several input and output
  2. ;;; `string' streams to test the generic stream facility.
  3. ;;; Generic-streams are used as wrappers to the string-streams.
  4. ;;; Written by Marcus Daniels, April 1994
  5.  
  6. (use-package "CLOS")
  7. T
  8.  
  9. (progn
  10.  
  11. ;; The controller is an instance of this class.
  12. (defclass generic-stream-controller-class ()
  13.   (source-stream      ; Input methods get/check-for characters on this stream
  14.    destination-stream ; Output methods put/clear characters on this stream 
  15.    ;; Flags are used to indicate the success of the finish/force/clear
  16.    ;; generic-stream methods.
  17.    ;; The semantics of CLISP's `close' function is still CLt1, so closed check
  18.    ;; is done with a flag too.
  19.    (flags :initform (copy-tree '((finish-output . nil)
  20.                  (force-output . nil)        
  21.                  (clear-input . nil)
  22.                  (closed . nil))))))
  23.  
  24. ;; A subclass of the controller class that has a flag for controlling
  25. ;; capitalization of characters which it prints.
  26. (defclass generic-stream-controller-class-2 (generic-stream-controller-class)
  27.   ((capitalize :initarg capitalize :initform nil)))
  28.  
  29. (defmethod convert (ch (controller generic-stream-controller-class))
  30.   (if (standard-char-p ch) ch #\_))
  31.  
  32. (defmethod convert (ch (controller generic-stream-controller-class-2))
  33.   (call-next-method (if (slot-value controller 'capitalize)
  34.             (char-upcase ch)
  35.               ch) controller))
  36.  
  37. ;; Generic-stream methods invoked for respective stream operations..
  38. (defmethod generic-stream-read-char ((controller generic-stream-controller-class))
  39.   (with-slots (source-stream) controller
  40.               (if (listen source-stream) (read-char source-stream))
  41.               ))
  42.  
  43. ;; Notice this function does not return boolean values.
  44. (defmethod generic-stream-listen ((controller generic-stream-controller-class))
  45.   (if (listen (slot-value controller 'source-stream)) 0 -1))
  46.  
  47. (defmethod generic-stream-clear-input ((controller generic-stream-controller-class))
  48.   (rplacd (assoc 'clear-input (slot-value controller 'flags)) t))
  49.  
  50. (defmethod generic-stream-read-byte ((controller generic-stream-controller-class))
  51.   (char-code (read-char (slot-value controller 'source-stream))))
  52.  
  53. (defmethod generic-stream-write-byte ((controller generic-stream-controller-class) by)
  54.   (write-char (code-char by) (slot-value controller 'destination-stream)))
  55.  
  56. (defmethod generic-stream-write-char ((controller generic-stream-controller-class) ch)
  57.   (format (slot-value controller 'destination-stream) "~C"
  58.       (convert ch controller)))
  59.  
  60. (defmethod generic-stream-write-string ((controller generic-stream-controller-class) str start len)
  61.   (format (slot-value controller 'destination-stream)
  62.       "~A" str start len))
  63.  
  64. (defmethod generic-stream-finish-output ((controller generic-stream-controller-class))
  65.   (rplacd (assoc 'finish-output (slot-value controller 'flags)) t))
  66.  
  67. (defmethod generic-stream-force-output ((controller generic-stream-controller-class))
  68.   (rplacd (assoc 'force-output (slot-value controller 'flags)) t))
  69.  
  70. (defmethod generic-stream-close ((controller generic-stream-controller-class))
  71.   (rplacd (assoc 'closed (slot-value controller 'flags)) t))
  72.  
  73. ;;; ------------------------------
  74. ;; Creates a generic stream, assigns source-destination stream values
  75. (defun make-test-stream (source-stream destination-stream controller)
  76.   (let ((genstream (make-generic-stream controller)))
  77.     (setf (slot-value controller 'source-stream) source-stream)
  78.     (setf (slot-value controller 'destination-stream) destination-stream)
  79.     genstream))
  80.  
  81. ;; There are several test strings, since several operations are to be
  82. ;; independently tested.
  83.  
  84. (setq str1 "0123")    ; for testing read-char & write-char
  85. (setq str1s "4567")   ; for testing write-string
  86. (setq str2 "abc")     ; for testing read-byte & write-byte
  87. (setq str2c "def")    ; for testing capitalization (subclassing controller)
  88. (setq str3 "xyz")     ; for testing read-char eof-error-p, eof-value
  89.  
  90. ;; A input and output stream for each test string
  91. (setq *string-input-stream-1* (make-string-input-stream str1))
  92. (setq *string-output-stream-1* (make-string-output-stream))
  93. (setq *string-input-stream-1s* (make-string-input-stream str1s))
  94. (setq *string-output-stream-1s* (make-string-output-stream))
  95. (setq *string-input-stream-2* (make-string-input-stream str2))
  96. (setq *string-output-stream-2* (make-string-output-stream))
  97. (setq *string-input-stream-2c* (make-string-input-stream str2c))
  98. (setq *string-output-stream-2c* (make-string-output-stream))
  99. (setq *string-input-stream-3* (make-string-input-stream str3))
  100.  
  101. ;; Create the generic-streams
  102. (setq s1 (make-test-stream
  103.       *string-input-stream-1* *string-output-stream-1*
  104.       (make-instance 'generic-stream-controller-class)))
  105.  
  106. (setq s1s (make-test-stream
  107.       *string-input-stream-1s* *string-output-stream-1s*
  108.       (make-instance 'generic-stream-controller-class)))
  109.  
  110. (setq s2 (make-test-stream
  111.       *string-input-stream-2* *string-output-stream-2*
  112.       (make-instance 'generic-stream-controller-class-2)))
  113.  
  114. (setq s2c (make-test-stream
  115.        *string-input-stream-2c* *string-output-stream-2c*
  116.        (make-instance 'generic-stream-controller-class-2 'capitalize t)))
  117.  
  118. (setq s3 (make-test-stream
  119.        *string-input-stream-3* nil
  120.        (make-instance 'generic-stream-controller-class)))
  121.  
  122. ;; Test listen, read-char, and write-char methods
  123. (defun copy-string-char (str stream)
  124.   (dotimes (i (length str) t)
  125.     (if (and (listen stream) (char-equal (char str i) (read-char stream)))
  126.     (write-char (char str i) stream)
  127.       (return nil))
  128.     ))
  129.  
  130. ;; Test listen, read-byte, and write-byte methods
  131. (defun copy-string-byte (str stream)
  132.   (dotimes (i (length str) t)
  133.     (if (and (listen stream) (eq (char-code (char str i)) (read-byte stream)))
  134.     (write-byte (char-code (char str i)) stream)
  135.       (return nil))
  136.     ))
  137.  
  138. ;; Compare str to data in string-output-stream (results of wr* methods)
  139. (defun check-output-string (str stream &key capitalize)
  140.   (let* ((strval (if capitalize (string-upcase str) str))
  141.      (controller (generic-stream-controller stream))
  142.      (stream (slot-value controller 'destination-stream))
  143.      (output-string (get-output-stream-string stream)))
  144.     (format t "   ~S ~S ~S" str strval output-string)
  145.     (string= strval output-string)))
  146.  
  147. ;; Report results of read/write-char 
  148. (defun check-char (str stream &key capitalize)
  149.   (let* ((test (copy-string-char str stream))
  150.      (testr (check-output-string str stream :capitalize capitalize)))
  151.     (format t "  char-check: ~S listen/read-char: ~S write chk: ~S~%" str test testr)
  152.     (and test testr)))
  153.  
  154. ;; Report results of read/write-byte
  155. (defun check-byte (str stream)
  156.   (let* ((test (copy-string-byte str stream))
  157.      (testr (check-output-string str stream)))
  158.     (format t " byte-check: ~S listen/read-byte: ~S write chk: ~S~%" str test testr)
  159.     (and test testr)))
  160.  
  161. ;; Report results of read/write-string
  162. (defun check-write-string (str stream)
  163.   (write-string str stream)
  164.   (let ((testr (check-output-string str stream)))
  165.     (format t "  write-string-check: ~S write chk: ~S~%" str testr)
  166.     testr))
  167.  
  168. ;; Report flag-set status
  169. (defun check-flag (flag controller)
  170.   (let ((status
  171.      (cdr
  172.       (assoc flag (slot-value controller 'flags)))))
  173.     (format t "Checking ~S flag status: ~S~%" flag status)
  174.     status))
  175.  
  176. (terpri)
  177. nil
  178. )
  179. nil
  180.  
  181. ;;; ----------
  182. (progn 
  183.   (format t "Checking READ-CHAR & WRITE-CHAR~%")
  184.   (check-char str1 s1))
  185. t
  186.  
  187. (progn
  188.   (format t "Checking WRITE-STRING~%")
  189.   (check-write-string str1s s1s))
  190. t
  191.  
  192. (progn
  193.   (format t "Checking READ-BYTE & WRITE-BYTE~%")
  194.   (check-byte str2 s2))
  195. t
  196.  
  197. (progn
  198.   (format t "Checking READ-CHAR & WRITE-CHAR with a subclass~%")
  199.    (check-char str2c s2c :capitalize t))
  200. t
  201.  
  202. ;;; ----------
  203. (progn 
  204.   (setq controller-instance (generic-stream-controller s1))
  205.   nil)
  206. nil
  207.  
  208. (progn
  209.   (clear-input s1)
  210.   (check-flag 'clear-input controller-instance))
  211. t
  212.  
  213. (progn
  214.   (finish-output s1)
  215.   (check-flag 'finish-output controller-instance))
  216. t
  217.  
  218. (progn
  219.   (force-output s1)
  220.   (check-flag 'force-output controller-instance))
  221. t
  222.  
  223. (prog2
  224.   (format t "Checking generic-stream-p (T): ")
  225.   (princ (generic-stream-p s1))
  226.   (terpri))
  227. t
  228.  
  229. (prog2
  230.   (format t "Checking generic-stream-p (NIL): ")
  231.   (princ (generic-stream-p *string-input-stream-1*))
  232.   (terpri))
  233. nil
  234.  
  235. ;;; ----------
  236. (prog2
  237.   (format t "Checking READ-CHAR's eof-error-p, eof-value: ")
  238.   (princ 
  239.    (and 
  240.     (eql (read-char s3) #\x)
  241.     (eql (read-char s3) #\y)
  242.     (eql (read-char s3) #\z)
  243.     (eql (read-char s3 nil 2) 2)))
  244.   (terpri))
  245. t
  246.  
  247. ;;; ----------
  248. (progn
  249.   (format t "Checking CLOSE (NIL,T)~%")
  250.   (close s1)
  251.   (princ 
  252.    (and
  253.     (eq (check-flag 'closed (generic-stream-controller s2)) NIL)
  254.     ;; Can't run generic-stream method anymore, must use saved variable.
  255.     (check-flag 'closed controller-instance))))
  256. t
  257.  
  258.  
  259.