fix errors in print object caused by slot unboundedness

src/document/document.lisp

@@ -6,7 +6,7 @@
 
 (defmethod print-object ((self document) stream)
   (print-unreadable-object (self stream :type T :identity T)
-    (with-slots (fields) self
+    (with-slots-ignoring-unbound (fields) self
       (let ((field-names (table-keys fields)))
 	(format stream "~{~A~^ ~}" (reverse field-names))))))
 

src/document/field.lisp

@@ -57,8 +57,9 @@
 
 (defmethod print-object ((self field) stream)
   (print-unreadable-object (self stream :type T :identity T)
-    (with-slots (name data stored-p compressed-p  indexed-p tokenized-p store-term-vector-p
-		      store-offsets-p store-positions-p omit-norms-p binary-p) self
+    (with-slots-ignoring-unbound
+        (name data stored-p compressed-p  indexed-p tokenized-p store-term-vector-p
+              store-offsets-p store-positions-p omit-norms-p binary-p) self
       (when stored-p
 	(format stream "stored")
 	(if compressed-p

src/index/document-writer.lisp

@@ -244,7 +244,7 @@
 
 (defmethod print-object ((self posting) stream)
   (print-unreadable-object (self stream :type T :identity T)
-    (with-slots (term freq positions offsets) self
+    (with-slots-ignoring-unbound (term freq positions offsets) self
       (format stream "term: ~S freq: ~S positions: ~S offsets: ~S"
 	      term freq positions offsets))))
 

src/index/multi-reader.lisp

@@ -233,8 +233,8 @@
 
 (defmethod print-object ((self multi-term-doc-enum) stream)
   (print-unreadable-object (self stream :type T)
-    (let ((term (term self)))
-      (format stream "~S:~S" (term-field term) (term-text term)))))
+    (to-string (ignore-slot-unbound (term self))
+               stream)))
 
 (defmethod initialize-instance :after ((self multi-term-doc-enum) &key)
   (with-slots (reader-term-docs readers) self

src/index/segment-infos.lisp

@@ -7,7 +7,7 @@
 
 (defmethod print-object ((self segment-info) stream)
   (print-unreadable-object (self stream :type T :identity T)
-    (format stream "~S" (segment-info-name self))))
+    (format stream "~S" (ignore-slot-unbound (segment-info-name self)))))
 
 (defgeneric segment-info= (segment-info other))
 
@@ -46,7 +46,7 @@
 
 (defmethod print-object ((self segment-infos) stream)
   (print-unreadable-object (self stream :type T :identity T)
-    (let ((elements (slot-value self 'elements)))
+    (let ((elements (ignore-slot-unbound (slot-value self 'elements))))
     (format stream "~S segment-infos: ~S" (length elements) elements))))
 
 (defgeneric clear (segment-infos))

src/index/segment-merge-info.lisp

@@ -14,7 +14,9 @@
 
 (defmethod print-object ((self segment-merge-info) stream)
   (print-unreadable-object (self stream :type T :identity T)
-    (format stream "term-buffer: ~S base: ~S" (term-buffer self) (base self))))
+    (format stream "term-buffer: ~S base: ~S"
+            (ignore-slot-unbound (term-buffer self))
+            (ignore-slot-unbound (base self)))))
 
 (defmethod positions ((self segment-merge-info))
   (with-slots (postings reader) self

src/index/segment-reader.lisp

@@ -19,7 +19,7 @@
 
 (defmethod print-object ((self segment-reader) stream)
   (print-unreadable-object (self stream :type T :identity T)
-    (with-slots (segment deleted-docs field-infos) self
+    (with-slots-ignoring-unbound (segment deleted-docs field-infos) self
       (format stream "~S (~S docs, ~S deleted docs, ~S field infos)"
 	      segment (num-docs self) (length deleted-docs) (size field-infos)))))
 

src/index/segment-term-vector.lisp

@@ -9,7 +9,7 @@
 
 (defmethod print-object ((self segment-term-vector) stream)
   (print-unreadable-object (self stream :identity T :type T)
-    (with-slots (field terms term-frequencies positions offsets) self
+    (with-slots-ignoring-unbound (field terms term-frequencies positions offsets) self
       (format stream "field:~S terms:~S term-freqs:~S positions:~S offsets:~S"
 	      field terms term-frequencies positions offsets))))
 

src/index/term-buffer.lisp

@@ -9,12 +9,11 @@
 
 (defmethod print-object ((self term-buffer) stream)
   (print-unreadable-object (self stream :type T :identity T)
-    (with-slots (field text-buf text-length) self
+    (with-slots-ignoring-unbound (field text-buf text-length) self
       (format stream "field:~S text:~S"
-	      field 
-	      (if (not (< text-length 0))
-		  (subseq text-buf 0 text-length)
-		  nil)))))
+	      field
+              (unless (< (or text-length -1) 0)
+                (subseq text-buf 0 text-length))))))
 
 (defmethod initialize-copy :after ((self term-buffer) other)
   (set-from-term-buffer self other))

src/index/term-info.lisp

@@ -13,7 +13,7 @@
 
 (defmethod print-object ((self term-info) stream)
   (print-unreadable-object (self stream :identity T :type T)
-    (with-slots (doc-freq freq-pointer prox-pointer skip-offset) self
+    (with-slots-ignoring-unbound (doc-freq freq-pointer prox-pointer skip-offset) self
       (format stream "df=~S:fp=~S:pp=~S:so=~S"
 	      doc-freq
 	      freq-pointer

src/index/term.lisp

@@ -52,7 +52,11 @@
 	(string> (term-text t1) (term-text t2))
 	(string> f1 f2))))
 
-(defgeneric to-string (term))
-
-(defmethod to-string ((self term))
-  (format nil "~A:~A" (term-field self) (term-text self)))
+(defgeneric to-string (term &optional stream)
+  (:method ((it null) &optional stream)
+    (format stream "NIL")))
+
+(defmethod to-string ((self term) &optional stream)
+  (format stream "~A:~A"
+          (ignore-slot-unbound (term-field self))
+          (ignore-slot-unbound (term-text self))))

src/util/utilities.lisp

@@ -18,3 +18,16 @@
 (defun parse-float (string)
   (with-standard-io-syntax
     (read-from-string string)))
+
+(defmacro ignore-slot-unbound (&body body)
+  "Returns nil instead of throwing slot unboundedness"
+  `(handler-case (progn ,@body) (unbound-slot ())))
+
+(defmacro with-slots-ignoring-unbound ( names obj &body body)
+  (let ((s-obj (gensym "OBJ")))
+    (flet ((make-binding (name)
+             `(,name (ignore-slot-unbound (slot-value ,s-obj ',name)))))
+      `(let ((,s-obj ,obj))
+        (symbol-macrolet
+            ,(mapcar #'make-binding names)
+          ,@body)))))