Mercurial > demo / examples/db/xdb/disk.lisp
changeset 41: |
81b7333f27f8 |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Sun, 16 Jun 2024 22:15:04 -0400 |
permissions: |
-rw-r--r-- |
description: |
more examples |
3 (defclass collection () 10 (packages :initform (make-s-packages) 12 (classes :initform (make-class-cache) 16 (object-cache :initarg :object-cache 17 :initform (make-hash-table :size 1000 19 :accessor object-cache) 20 (id-cache :initarg :id-cache 21 :initform (make-hash-table :size 1000) 24 (eval-when (:compile-toplevel :load-toplevel :execute) 43 intern-package-and-symbol 52 (defvar *statistics* ()) 53 (defun collect-stats (code) 54 (let* ((type (aref *codes* code)) 55 (cons (assoc type *statistics*))) 58 (push (cons type 1) *statistics*)) 61 (defvar *collection* nil) 65 (declaim (vector *classes* *packages*)) 68 (declaim (hash-table *indexes*)) 70 (defvar *written-objects*) 71 (declaim (hash-table *indexes*)) 73 (eval-when (:compile-toplevel :load-toplevel :execute) 74 (defun type-code (type) 75 (position type *codes*))) 77 (defparameter *readers* (make-array (length *codes*))) 78 (declaim (type (simple-array function (*)) *readers*)) 80 (defmacro defreader (type (stream) &body body) 81 (let ((name (intern (format nil "~a-~a" type '#:reader)))) 83 (defun ,name (,stream) 85 (setf (aref *readers* ,(type-code type)) 88 (declaim (inline call-reader)) 89 (defun call-reader (code stream) 90 ;; (collect-stats code) 91 (funcall (aref *readers* code) stream)) 93 (defconstant +sequence-length+ 2) 94 (eval-when (:compile-toplevel :load-toplevel :execute) 95 (defconstant +fixnum-length+ 4)) 96 (defconstant +char-length+ 2) 97 (defconstant +id-length+ 4) 98 (defconstant +class-id-length+ 2) 99 (defconstant +hash-table-length+ 3) 101 (defconstant +unbound-slot+ 254) 102 (defconstant +end+ 255) 104 (defconstant +ascii-char-limit+ (code-char 128)) 106 (deftype ascii-string () 108 #+sb-unicode simple-base-string ; on #-sb-unicode the limit is 255 109 (satisfies ascii-string-p))) 111 (defun ascii-string-p (string) 112 (declare (simple-string string)) 113 (loop for char across string 114 always (char< char +ascii-char-limit+))) 116 (deftype storage-fixnum () 117 `(signed-byte ,(* +fixnum-length+ 8))) 119 (defun make-class-cache () 120 (make-array 10 :adjustable t :fill-pointer 0)) 122 (defmacro with-collection (collection &body body) 123 (let ((collection-sym (gensym))) 124 `(let* ((,collection-sym ,collection) 125 (*collection* ,collection-sym) 126 (*packages* (packages ,collection-sym)) 127 (*classes* (classes ,collection-sym)) 128 (*indexes* (id-cache ,collection-sym))) 132 (defun slot-effective-definition (class slot-name) 133 (find slot-name (class-slots class) :key #'slot-definition-name)) 135 (defun dump-data (stream) 139 (write-top-level-object document stream)) 142 (defun write-top-level-object (object stream) 143 (if (typep object 'id) 144 (write-storable-object object stream) 145 (write-object object stream))) 147 (declaim (inline read-next-object)) 148 (defun read-next-object (stream) 149 (call-reader (read-n-bytes 1 stream) stream)) 153 (defmethod write-object ((object null) stream) 154 (write-n-bytes #.(type-code 'null) 1 stream)) 156 (defreader null (stream) 157 (declare (ignore stream)) 162 (defun make-s-packages () 163 (make-array 10 :adjustable t :fill-pointer 0)) 165 (defun make-s-package (package) 166 (let ((symbols (make-array 100 :adjustable t :fill-pointer 0))) 167 (values (vector-push-extend (cons package symbols) *packages*) 171 (defun find-s-package (package) 172 (loop for i below (length *packages*) 173 for (stored-package . symbols) = (aref *packages* i) 174 when (eq package stored-package) 175 return (values i symbols) 176 finally (return (make-s-package package)))) 178 (defun s-intern (symbol) 179 (multiple-value-bind (package-id symbols new-package) 180 (find-s-package (symbol-package symbol)) 181 (let* ((existing (and (not new-package) 182 (position symbol symbols))) 183 (symbol-id (or existing 184 (vector-push-extend symbol symbols)))) 185 (values package-id symbol-id new-package (not existing))))) 187 (defun s-intern-existing (symbol symbols) 188 (vector-push-extend symbol symbols)) 190 (defmethod write-object ((symbol symbol) stream) 191 (multiple-value-bind (package-id symbol-id 192 new-package new-symbol) 194 (cond ((and new-package new-symbol) 195 (write-n-bytes #.(type-code 'intern-package-and-symbol) 1 stream) 196 (write-object (package-name (symbol-package symbol)) stream) 197 (write-object (symbol-name symbol) stream)) 199 (write-n-bytes #.(type-code 'intern-symbol) 1 stream) 200 (write-n-bytes package-id +sequence-length+ stream) 201 (write-object (symbol-name symbol) stream)) 203 (write-n-bytes #.(type-code 'symbol) 1 stream) 204 (write-n-bytes package-id +sequence-length+ stream) 205 (write-n-bytes symbol-id +sequence-length+ stream))))) 207 (defreader symbol (stream) 208 (let* ((package-id (read-n-bytes +sequence-length+ stream)) 209 (symbol-id (read-n-bytes +sequence-length+ stream)) 210 (package (or (aref *packages* package-id) 211 (error "Package with id ~a not found" package-id))) 212 (symbol (aref (cdr package) symbol-id))) 214 (error "Symbol with id ~a in package ~a not found" 215 symbol-id (car package))))) 217 (defreader intern-package-and-symbol (stream) 218 (let* ((package-name (read-next-object stream)) 219 (symbol-name (read-next-object stream)) 220 (package (or (find-package package-name) 221 (error "Package ~a not found" package-name))) 222 (symbol (intern symbol-name package)) 223 (s-package (nth-value 1 (make-s-package package)))) 224 (s-intern-existing symbol s-package) 227 (defreader intern-symbol (stream) 228 (let* ((package-id (read-n-bytes +sequence-length+ stream)) 229 (symbol-name (read-next-object stream)) 230 (package (or (aref *packages* package-id) 231 (error "Package with id ~a for symbol ~a not found" 232 package-id symbol-name))) 233 (symbol (intern symbol-name (car package)))) 234 (s-intern-existing symbol (cdr package)) 239 (declaim (inline sign)) 245 (defun write-fixnum (n stream) 246 (declare (storage-fixnum n)) 247 (write-n-bytes #.(type-code 'fixnum) 1 stream) 248 (write-n-signed-bytes n +fixnum-length+ stream)) 250 (defun write-bignum (n stream) 251 (declare ((and integer (not storage-fixnum)) n)) 252 (write-n-bytes #.(type-code 'bignum) 1 stream) 253 (write-n-bytes (sign n) 1 stream) 254 (let* ((fixnum-bits (* +fixnum-length+ 8)) 256 (size (ceiling (integer-length n) fixnum-bits))) 257 (write-n-bytes size 1 stream) 258 (loop for position by fixnum-bits below (* size fixnum-bits) 260 (write-n-bytes (ldb (byte fixnum-bits position) n) 261 +fixnum-length+ stream)))) 263 (defmethod write-object ((object integer) stream) 266 (write-fixnum object stream)) 267 (t (write-bignum object stream)))) 269 (declaim (inline read-sign)) 270 (defun read-sign (stream) 271 (if (plusp (read-n-bytes 1 stream)) 275 (defreader bignum (stream) 276 (let ((fixnum-bits (* +fixnum-length+ 8)) 277 (sign (read-sign stream)) 278 (size (read-n-bytes 1 stream)) 280 (loop for position by fixnum-bits below (* size fixnum-bits) 282 (setf (ldb (byte fixnum-bits position) integer) 283 (read-n-bytes +fixnum-length+ stream))) 286 (defreader fixnum (stream) 287 (read-n-signed-bytes +fixnum-length+ stream)) 291 (defmethod write-object ((object ratio) stream) 292 (write-n-bytes #.(type-code 'ratio) 1 stream) 293 (write-object (numerator object) stream) 294 (write-object (denominator object) stream)) 296 (defreader ratio (stream) 297 (/ (read-next-object stream) 298 (read-next-object stream))) 302 (defun write-8-bytes (n stream) 303 (write-n-bytes (ldb (byte 32 0) n) 4 stream) 304 (write-n-bytes (ldb (byte 64 32) n) 4 stream)) 306 (defun read-8-bytes (stream) 307 (logior (read-n-bytes 4 stream) 308 (ash (read-n-bytes 4 stream) 32))) 310 (defmethod write-object ((float float) stream) 313 (write-n-bytes #.(type-code 'single-float) 1 stream) 314 (write-n-bytes (encode-float32 float) 4 stream)) 316 (write-n-bytes #.(type-code 'double-float) 1 stream) 317 (write-8-bytes (encode-float64 float) stream)))) 319 (defreader single-float (stream) 320 (decode-float32 (read-n-bytes 4 stream))) 322 (defreader double-float (stream) 323 (decode-float64 (read-8-bytes stream))) 327 (defmethod write-object ((complex complex) stream) 328 (write-n-bytes #.(type-code 'complex) 1 stream) 329 (write-object (realpart complex) stream) 330 (write-object (imagpart complex) stream)) 332 (defreader complex (stream) 333 (complex (read-next-object stream) 334 (read-next-object stream))) 338 (defmethod write-object ((character character) stream) 339 (write-n-bytes #.(type-code 'character) 1 stream) 340 (write-n-bytes (char-code character) +char-length+ stream)) 342 (defreader character (stream) 343 (code-char (read-n-bytes +char-length+ stream))) 347 (defun write-ascii-string (string stream) 348 (declare (simple-string string)) 349 (loop for char across string 350 do (write-n-bytes (char-code char) 1 stream))) 352 (defun write-multibyte-string (string stream) 353 (declare (simple-string string)) 354 (loop for char across string 355 do (write-n-bytes (char-code char) +char-length+ stream))) 357 (defmethod write-object ((string string) stream) 363 (write-n-bytes #.(type-code 'ascii-string) 1 stream) 364 (write-n-bytes (length string) +sequence-length+ stream) 365 (write-ascii-string string stream)) 367 (write-n-bytes #.(type-code 'ascii-string) 1 stream) 368 (write-n-bytes (length string) +sequence-length+ stream) 369 (write-ascii-string string stream)) 371 (write-n-bytes #.(type-code 'string) 1 stream) 372 (write-n-bytes (length string) +sequence-length+ stream) 373 (write-multibyte-string string stream)))) 375 (declaim (inline read-ascii-string)) 376 (defun read-ascii-string (length stream) 377 (let ((string (make-string length :element-type 'base-char))) 379 (loop for i below length 380 do (setf (schar string i) 381 (code-char (read-n-bytes 1 stream)))) 382 #+(and nil sbcl (or x86 x86-64)) 383 (read-ascii-string-optimized length string stream) 386 (defreader ascii-string (stream) 387 (read-ascii-string (read-n-bytes +sequence-length+ stream) stream)) 389 (defreader string (stream) 390 (let* ((length (read-n-bytes +sequence-length+ stream)) 391 (string (make-string length :element-type 'character))) 392 (loop for i below length 393 do (setf (schar string i) 394 (code-char (read-n-bytes +char-length+ stream)))) 399 (defmethod write-object ((pathname pathname) stream) 400 (write-n-bytes #.(type-code 'pathname) 1 stream) 401 (write-object (pathname-name pathname) stream) 402 (write-object (pathname-directory pathname) stream) 403 (write-object (pathname-device pathname) stream) 404 (write-object (pathname-type pathname) stream) 405 (write-object (pathname-version pathname) stream)) 407 (defreader pathname (stream) 409 :name (read-next-object stream) 410 :directory (read-next-object stream) 411 :device (read-next-object stream) 412 :type (read-next-object stream) 413 :version (read-next-object stream))) 417 (defmethod write-object ((list cons) stream) 418 (cond ((circular-list-p list) 419 (error "Can't store circular lists")) 421 (write-n-bytes #.(type-code 'cons) 1 stream) 422 (loop for cdr = list then (cdr cdr) 425 (write-object (car cdr) stream)) 427 (write-n-bytes +end+ 1 stream) 428 (write-object cdr stream) 431 (defreader cons (stream) 432 (let ((first-cons (list (read-next-object stream)))) 433 (loop for previous-cons = first-cons then new-cons 434 for car = (let ((id (read-n-bytes 1 stream))) 436 (setf (cdr previous-cons) (read-next-object stream)) 438 ((call-reader id stream)))) 439 for new-cons = (list car) 440 do (setf (cdr previous-cons) new-cons)) 445 (defmethod write-object ((vector vector) stream) 448 (write-simple-vector vector stream)) 450 (call-next-method)))) 452 (defun write-simple-vector (vector stream) 453 (declare (simple-vector vector)) 454 (write-n-bytes #.(type-code 'simple-vector) 1 stream) 455 (write-n-bytes (length vector) +sequence-length+ stream) 456 (loop for elt across vector 457 do (write-object elt stream))) 459 (defreader simple-vector (stream) 460 (let ((vector (make-array (read-n-bytes +sequence-length+ stream)))) 461 (loop for i below (length vector) 462 do (setf (svref vector i) (read-next-object stream))) 472 (defmethod write-object ((array array) stream) 473 (write-n-bytes #.(type-code 'array) 1 stream) 474 (write-object (array-dimensions array) stream) 475 (cond ((array-has-fill-pointer-p array) 476 (write-n-bytes 1 1 stream) 477 (write-n-bytes (fill-pointer array) +sequence-length+ stream)) 479 (write-n-bytes 0 2 stream))) 480 (write-object (array-element-type array) stream) 481 (write-n-bytes (boolify (adjustable-array-p array)) 1 stream) 482 (loop for i below (array-total-size array) 483 do (write-object (row-major-aref array i) stream))) 485 (defun read-array-fill-pointer (stream) 486 (if (plusp (read-n-bytes 1 stream)) 487 (read-n-bytes +sequence-length+ stream) 488 (not (read-n-bytes 1 stream)))) 490 (defreader array (stream) 491 (let ((array (make-array (read-next-object stream) 492 :fill-pointer (read-array-fill-pointer stream) 493 :element-type (read-next-object stream) 494 :adjustable (plusp (read-n-bytes 1 stream))))) 495 (loop for i below (array-total-size array) 496 do (setf (row-major-aref array i) (read-next-object stream))) 501 (defvar *hash-table-tests* #(eql equal equalp eq)) 502 (declaim (simple-vector *hash-table-tests*)) 504 (defun check-hash-table-test (hash-table) 505 (let* ((test (hash-table-test hash-table)) 506 (test-id (position test *hash-table-tests*))) 508 (error "Only standard hashtable tests are supported, ~a has ~a" 512 (defmethod write-object ((hash-table hash-table) stream) 513 (write-n-bytes #.(type-code 'hash-table) 1 stream) 514 (write-n-bytes (check-hash-table-test hash-table) 1 stream) 515 (write-n-bytes (hash-table-size hash-table) +hash-table-length+ stream) 516 (loop for key being the hash-keys of hash-table 517 using (hash-value value) 519 (write-object key stream) 520 (write-object value stream)) 521 (write-n-bytes +end+ 1 stream)) 523 (defreader hash-table (stream) 524 (let* ((test (svref *hash-table-tests* (read-n-bytes 1 stream))) 525 (size (read-n-bytes +hash-table-length+ stream)) 526 (table (make-hash-table :test test :size size))) 527 (loop for id = (read-n-bytes 1 stream) 529 do (setf (gethash (call-reader id stream) table) 530 (read-next-object stream))) 535 (defun cache-class (class id) 536 (when (< (length *classes*) id) 537 (adjust-array *classes* (1+ id))) 538 (when (> (1+ id) (fill-pointer *classes*)) 539 (setf (fill-pointer *classes*) (1+ id))) 540 (setf (aref *classes* id) class)) 542 (defmethod write-object ((class storable-class) stream) 543 (cond ((position class *classes* :test #'eq)) 545 (unless (class-finalized-p class) 546 (finalize-inheritance class)) 547 (let ((id (vector-push-extend class *classes*)) 548 (slots (slots-to-store class))) 549 (write-n-bytes #.(type-code 'storable-class) 1 stream) 550 (write-object (class-name class) stream) 551 (write-n-bytes id +class-id-length+ stream) 552 (write-n-bytes (length slots) +sequence-length+ stream) 553 (loop for slot across slots 554 do (write-object (slot-definition-name slot) 558 (defreader storable-class (stream) 559 (let ((class (find-class (read-next-object stream)))) 561 (read-n-bytes +class-id-length+ stream)) 562 (unless (class-finalized-p class) 563 (finalize-inheritance class)) 564 (let* ((length (read-n-bytes +sequence-length+ stream)) 565 (vector (make-array length))) 566 (loop for i below length 568 (slot-effective-definition class (read-next-object stream)) 570 do (setf (aref vector i) 571 (cons (slot-definition-location slot-d) 572 (slot-definition-initform slot-d)))) 573 (setf (slot-locations-and-initforms class) vector)) 574 (read-next-object stream))) 578 (defmethod write-object ((object id) stream) 579 (cond ((written object) 580 (let* ((class (class-of object)) 581 (class-id (write-object class stream))) 582 (write-n-bytes #.(type-code 'id) 1 stream) 583 (write-n-bytes class-id +class-id-length+ stream) 584 (write-n-bytes (id object) +id-length+ stream))) 586 (write-storable-object object stream)))) 588 (defun get-class (id) 591 (declaim (inline get-instance)) 592 (defun get-instance (class-id id) 593 (let* ((class (get-class class-id)) 594 (index (if (typep class 'storable-class) 597 (or (gethash id index) 598 (setf (gethash id index) 599 (fast-allocate-instance class))))) 601 (defreader id (stream) 602 (get-instance (read-n-bytes +class-id-length+ stream) 603 (read-n-bytes +id-length+ stream))) 606 ;; Can't use write-object method, because it would conflict with 607 ;; writing a pointer to a standard object 608 (defun write-storable-object (object stream) 609 (let* ((class (class-of object)) 610 (slots (slot-locations-and-initforms class)) 611 (class-id (write-object class stream))) 612 (declare (simple-vector slots)) 613 (write-n-bytes #.(type-code 'storable-object) 1 stream) 614 (write-n-bytes class-id +class-id-length+ stream) 616 (setf (id object) (last-id *collection*)) 617 (incf (last-id *collection*))) 618 (write-n-bytes (id object) +id-length+ stream) 619 (setf (written object) t) 620 (loop for id below (length slots) 621 for (location . initform) = (aref slots id) 622 for value = (standard-instance-access object location) 623 unless (eql value initform) 625 (write-n-bytes id 1 stream) 626 (if (eq value '+slot-unbound+) 627 (write-n-bytes +unbound-slot+ 1 stream) 628 (write-object value stream))) 629 (write-n-bytes +end+ 1 stream))) 631 (defreader storable-object (stream) 632 (let* ((class-id (read-n-bytes +class-id-length+ stream)) 633 (id (read-n-bytes +id-length+ stream)) 634 (instance (get-instance class-id id)) 635 (class (class-of instance)) 636 (slots (slot-locations-and-initforms class))) 637 (declare (simple-vector slots)) 638 (setf (id instance) id) 639 (if (>= id (last-id *collection*)) 640 (setf (last-id *collection*) (1+ id))) 641 (loop for slot-id = (read-n-bytes 1 stream) 642 until (= slot-id +end+) 644 (setf (standard-instance-access instance 645 (car (aref slots slot-id))) 646 (let ((code (read-n-bytes 1 stream))) 647 (if (= code +unbound-slot+) 649 (call-reader code stream))))) 654 (defmethod write-object ((class standard-class) stream) 655 (cond ((position class *classes* :test #'eq)) 657 (unless (class-finalized-p class) 658 (finalize-inheritance class)) 659 (let ((id (vector-push-extend class *classes*)) 660 (slots (class-slots class))) 661 (write-n-bytes #.(type-code 'standard-class) 1 stream) 662 (write-object (class-name class) stream) 663 (write-n-bytes id +class-id-length+ stream) 664 (write-n-bytes (length slots) +sequence-length+ stream) 665 (loop for slot in slots 666 do (write-object (slot-definition-name slot) 670 (defreader standard-class (stream) 671 (let ((class (find-class (read-next-object stream)))) 673 (read-n-bytes +class-id-length+ stream)) 674 (unless (class-finalized-p class) 675 (finalize-inheritance class)) 676 (let ((length (read-n-bytes +sequence-length+ stream))) 677 (loop for i below length 678 do (slot-effective-definition class (read-next-object stream)) 679 ;;do (setf (aref vector i) 680 ;; (cons (slot-definition-location slot-d) 681 ;; (slot-definition-initform slot-d))) 683 (read-next-object stream))) 687 (defun write-standard-link (object stream) 688 (let* ((class (class-of object)) 689 (class-id (write-object class stream))) 690 (write-n-bytes #.(type-code 'standard-link) 1 stream) 691 (write-n-bytes class-id +class-id-length+ stream) 692 (write-n-bytes (get-object-id object) +id-length+ stream))) 694 (defreader standard-link (stream) 695 (get-instance (read-n-bytes +class-id-length+ stream) 696 (read-n-bytes +id-length+ stream))) 700 (defun get-object-id (object) 701 (let ((cache (object-cache *collection*))) 702 (or (gethash object cache) 704 (setf (gethash object cache) 705 (last-id *collection*)) 706 (incf (last-id *collection*)))))) 708 (defmethod write-object ((object standard-object) stream) 709 (if (gethash object *written-objects*) 710 (write-standard-link object stream) 711 (let* ((class (class-of object)) 712 (slots (class-slots class)) 713 (class-id (write-object class stream))) 714 (write-n-bytes #.(type-code 'standard-object) 1 stream) 715 (write-n-bytes class-id +class-id-length+ stream) 716 (write-n-bytes (get-object-id object) +id-length+ stream) 717 (setf (gethash object *written-objects*) t) 720 for location = (slot-definition-location slot) 721 for initform = (slot-definition-initform slot) 722 for value = (standard-instance-access object location) 724 (write-n-bytes id 1 stream) 725 (if (eq value '+slot-unbound+) 726 (write-n-bytes +unbound-slot+ 1 stream) 727 (write-object value stream))) 728 (write-n-bytes +end+ 1 stream)))) 730 (defreader standard-object (stream) 731 (let* ((class-id (read-n-bytes +class-id-length+ stream)) 732 (id (read-n-bytes +id-length+ stream)) 733 (instance (get-instance class-id id)) 734 (class (class-of instance)) 735 (slots (class-slots class))) 737 (let ((code (read-n-bytes 1 stream))) 738 (if (= code +unbound-slot+) 740 (call-reader code stream))))) 741 (loop for slot-id = (read-n-bytes 1 stream) 742 until (= slot-id +end+) 744 (let ((slot (nth slot-id slots))) 746 (setf (standard-instance-access instance 747 (slot-definition-location slot)) 754 (defmethod write-object ((collection collection) stream) 755 (write-n-bytes #.(type-code 'collection) 1 stream)) 757 (defreader collection (stream) 758 (declare (ignore stream)) 762 #+sbcl (declaim (inline %fast-allocate-instance)) 765 (defun %fast-allocate-instance (wrapper initforms) 766 (declare (simple-vector initforms)) 767 (let ((instance (sb-pcl::make-instance->constructor-call 768 (copy-seq initforms) (sb-pcl::safe-code-p)))) 769 (setf (sb-pcl::std-instance-slots instance) 774 (defun fast-allocate-instance (class) 775 (declare (optimize speed)) 776 (if (typep class 'storable-class) 777 (let ((initforms (class-initforms class)) 778 (wrapper (sb-pcl::class-wrapper class))) 779 (%fast-allocate-instance wrapper initforms)) 780 (allocate-instance class))) 782 (defun clear-cache (collection) 783 (setf (classes collection) (make-class-cache) 784 (packages collection) (make-s-packages))) 786 (defun read-file (function file) 787 (with-io-file (stream file) 788 (loop until (stream-end-of-file-p stream) 789 do (let ((object (read-next-object stream))) 790 (when (and (not (typep object 'class)) 791 (typep object 'standard-object)) 792 (funcall function object)))))) 794 (defun load-data (collection file function) 795 (with-collection collection 796 (read-file function file))) 798 (defun save-data (collection &optional file) 799 (let ((*written-objects* (make-hash-table :test 'eq))) 800 (clear-cache collection) 801 (with-collection collection 802 (with-io-file (stream file 805 (clear-cache collection) 808 (defun save-doc (collection document &optional file) 809 (let ((*written-objects* (make-hash-table :test 'eq))) 810 (with-collection collection 811 (with-io-file (stream file 814 (write-top-level-object document stream))))) 818 (defmethod sum ((collection collection) &key function element) 820 (function (or function 822 (incf sum (get-val doc element)))))) 828 (defmethod max-val ((collection collection) &key function element) 830 (function (or function 832 (if (get-val doc element) 833 (if (> (get-val doc element) max) 834 (setf max (get-val doc element))))))))