From 913d061bda496fda6f64cd04906a8455d814b903 Mon Sep 17 00:00:00 2001 From: pfdietz <pfdietz@localhost> Date: Thu, 27 May 2004 04:08:30 +0000 Subject: [PATCH] Add a structure printing test --- ansi-tests/load-printer.lsp | 3 ++- ansi-tests/print-structure.lsp | 36 ++++++++++++++++++++++++++++++++++ 2 files changed, 38 insertions(+), 1 deletion(-) create mode 100644 ansi-tests/print-structure.lsp diff --git a/ansi-tests/load-printer.lsp b/ansi-tests/load-printer.lsp index 6f354d9c..5acb9e87 100644 --- a/ansi-tests/load-printer.lsp +++ b/ansi-tests/load-printer.lsp @@ -21,4 +21,5 @@ (load "print-vector.lsp") (load "print-array.lsp") (load "print-random-state.lsp") -(load "print-pathname.lsp") \ No newline at end of file +(load "print-pathname.lsp") +(load "print-structure.lsp") diff --git a/ansi-tests/print-structure.lsp b/ansi-tests/print-structure.lsp new file mode 100644 index 00000000..0f68fdfb --- /dev/null +++ b/ansi-tests/print-structure.lsp @@ -0,0 +1,36 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed May 26 22:19:52 2004 +;;;; Contains: Printing tests for structures + +(in-package :cl-test) + +(compile-and-load "printer-aux.lsp") + +(defstruct print-struct-1 + foo bar) + +(deftest print-structure.1 + (let ((s (make-print-struct-1 :foo 1 :bar 2))) + (with-standard-io-syntax + (let ((*package* (find-package "CL-TEST"))) + (let ((str (write-to-string s :readably nil :case :upcase :escape nil))) + (assert (string= (subseq str 0 3) "#S(")) + (let ((vals (read-from-string (subseq str 2)))) + (assert (listp vals)) + (assert (= (length vals) 5)) + (assert (eq (car vals) 'print-struct-1)) + (assert (symbolp (cadr vals))) + (assert (symbolp (cadddr vals))) + (cond + ((string= (symbol-name (cadr vals)) "FOO") + (assert (string= (symbol-name (cadddr vals)) "BAR")) + (assert (= (caddr vals) 1)) + (assert (= (car (cddddr vals)) 2))) + (t + (assert (string= (symbol-name (cadr vals)) "BAR")) + (assert (string= (symbol-name (cadddr vals)) "FOO")) + (assert (= (caddr vals) 2)) + (assert (= (car (cddddr vals)) 1)))) + nil))))) + nil) -- GitLab