serialize-raw

(defun ser-encode-magic
  (stream)
  (ser-write-byte 172 stream)
  (ser-write-byte 18 stream)
  (ser-write-byte 11 stream)
  (ser-write-byte 201 stream))

(defun ser-decode-magic
  (stream)
  (let* ((magic-1 (ser-read-byte stream)) (magic-2 (ser-read-byte stream))
      (magic-3 (ser-read-byte stream))
      (magic-4 (ser-read-byte stream)))
    (declare (type (unsigned-byte 8) magic-1 magic-2 magic-3 magic-4))
    (let ((version (and (= magic-1 172)
           (= magic-2 18)
           (= magic-3 11)
           (cond ((= magic-4 199) :v1)
             ((= magic-4 200) :v2)
             ((= magic-4 201) :v3)
             (t nil)))))
      (unless version
        (error "Invalid serialized object, magic number incorrect: ~X ~X ~X ~X"
          magic-1
          magic-2
          magic-3
          magic-4))
      version)))

(defun ser-encode-nat-fixnum
  (n stream)
  (declare (type fixnum n))
  (loop while
    (>= n 128)
    do
    (ser-write-byte (logior (the fixnum (logand n 127)) 128)
      stream)
    (setq n (the fixnum (ash n -7))))
  (ser-write-byte n stream))

(defun ser-encode-nat-large
  (n stream)
  (declare (type (integer 0 *) n))
  (loop until
    (typep n 'fixnum)
    do
    (ser-write-byte (logior (the fixnum (logand (the integer n) 127)) 128)
      stream)
    (setq n (the integer (ash n -7))))
  (ser-encode-nat-fixnum n stream))

(defun ser-decode-nat-large
  (shift value stream)
  (declare (type integer value shift))
  (let ((x1 (ser-read-byte stream)))
    (declare (type fixnum x1))
    (loop while
      (>= x1 128)
      do
      (incf value (ash (- x1 128) shift))
      (incf shift 7)
      (setf x1 (ser-read-byte stream)))
    (incf value (ash x1 shift))
    value))

(defun ser-decode-nat
  (stream)
  (let ((x1 (ser-read-byte stream)))
    (declare (type fixnum x1))
    (when (< (the fixnum x1) 128)
      (return-from ser-decode-nat x1))
    (setq x1 (the fixnum (- x1 128)))
    (let ((value x1))
      (declare (type fixnum value))
      (ser-decode-nat-body 7))))

(defun ser-encode-rat
  (x stream)
  (declare (type rational x))
  (ser-encode-nat (if (< x 0)
      1
      0)
    stream)
  (ser-encode-nat (abs (numerator x)) stream)
  (ser-encode-nat (denominator x) stream))

(defun ser-decode-rat
  (stream)
  (let* ((sign (ser-decode-nat stream)) (numerator (ser-decode-nat stream))
      (denominator (ser-decode-nat stream)))
    (declare (type integer sign numerator denominator))
    (cond ((= sign 1) (setq numerator (- numerator)))
      ((= sign 0) nil)
      (t (error "Trying to decode rational, but the sign is invalid.")))
    (when (= denominator 0)
      (error "Trying to decode rational, but the denominator is zero."))
    (the rational (/ numerator denominator))))

(defun ser-encode-complex
  (x stream)
  (declare (type complex x))
  (ser-encode-rat (realpart x) stream)
  (ser-encode-rat (imagpart x) stream))

(defun ser-decode-complex
  (stream)
  (let* ((realpart (ser-decode-rat stream)) (imagpart (ser-decode-rat stream)))
    (declare (type rational realpart imagpart))
    (when (= imagpart 0)
      (error "Trying to decode complex, but the imagpart is zero."))
    (complex realpart imagpart)))

(defun ser-encode-str
  (x stream)
  (declare (type string x))
  (let* ((len (length x)) (normedp (hl-hspace-normedp-wrapper x))
      (header (logior (ash len 1)
          (if normedp
            1
            0))))
    (ser-encode-nat header stream)
    (loop for
      n
      fixnum
      from
      0
      below
      (the fixnum len)
      do
      (ser-write-char (char x n) stream))))

(defun ser-decode-str
  (version hons-mode stream)
  (let* ((header (ser-decode-nat stream)) (len (if (eq version :v3)
          (ash header -1)
          header))
      (normp (and (eq version :v3)
          (= (the bit (logand header 1)) 1)
          (not (eq hons-mode :never)))))
    (unless (and (typep len 'fixnum)
        (< (the fixnum len) array-dimension-limit))
      (error "Trying to decode a string, but the length is too long."))
    (let ((str (make-string (the fixnum len))))
      (declare (type vector str))
      (loop for
        i
        fixnum
        from
        0
        below
        (the fixnum len)
        do
        (setf (schar str i) (ser-read-char stream)))
      (if normp
        (hons-copy str)
        str))))

(defun ser-encode-nats
  (x stream)
  (let ((len (length x)))
    (ser-print? "; Encoding ~a naturals.~%" len)
    (ser-encode-nat len stream)
    (dolist (elem x) (ser-encode-nat elem stream))))

(defun ser-decode-and-load-nats
  (decoder stream)
  (declare (type ser-decoder decoder))
  (let* ((len (ser-decode-nat stream)) (arr (ser-decoder-array decoder))
      (free (ser-decoder-free decoder))
      (stop (+ free len)))
    (declare (type fixnum free))
    (ser-print? "; Decoding ~a naturals.~%" len)
    (unless (<= stop (length arr))
      (error "Invalid serialized object, too many naturals."))
    (loop until
      (= (the fixnum stop) free)
      do
      (setf (svref arr free) (ser-decode-nat stream))
      (incf free))
    (setf (ser-decoder-free decoder) stop)))

(defun ser-encode-rats
  (x stream)
  (let ((len (length x)))
    (ser-print? "; Encoding ~a rationals.~%" len)
    (ser-encode-nat len stream)
    (dolist (elem x) (ser-encode-rat elem stream))))

(defun ser-decode-and-load-rats
  (decoder stream)
  (declare (type ser-decoder decoder))
  (let* ((len (ser-decode-nat stream)) (arr (ser-decoder-array decoder))
      (free (ser-decoder-free decoder))
      (stop (+ free len)))
    (declare (type fixnum free))
    (ser-print? "; Decoding ~a rationals.~%" len)
    (unless (<= stop (length arr))
      (error "Invalid serialized object, too many rationals."))
    (loop until
      (= (the fixnum stop) free)
      do
      (setf (svref arr free) (ser-decode-rat stream))
      (incf free))
    (setf (ser-decoder-free decoder) stop)))

(defun ser-encode-complexes
  (x stream)
  (let ((len (length x)))
    (ser-print? "; Encoding ~a complexes.~%" len)
    (ser-encode-nat len stream)
    (dolist (elem x) (ser-encode-complex elem stream))))

(defun ser-decode-and-load-complexes
  (decoder stream)
  (declare (type ser-decoder decoder))
  (let* ((len (ser-decode-nat stream)) (arr (ser-decoder-array decoder))
      (free (ser-decoder-free decoder))
      (stop (+ free len)))
    (declare (type fixnum free))
    (ser-print? "; Decoding ~a complexes.~%" len)
    (unless (<= stop (length arr))
      (error "Invalid serialized object, too many complexes."))
    (loop until
      (= (the fixnum stop) free)
      do
      (setf (svref arr free) (ser-decode-complex stream))
      (incf free))
    (setf (ser-decoder-free decoder) stop)))

(defun ser-encode-chars
  (x stream)
  (let ((len (length x)))
    (ser-print? "; Encoding ~a characters.~%" len)
    (ser-encode-nat len stream)
    (dolist (elem x) (ser-write-char elem stream))))

(defun ser-decode-and-load-chars
  (decoder stream)
  (declare (type ser-decoder decoder))
  (let* ((len (ser-decode-nat stream)) (arr (ser-decoder-array decoder))
      (free (ser-decoder-free decoder))
      (stop (+ free len)))
    (declare (type fixnum free))
    (ser-print? "; Decoding ~a characters.~%" len)
    (unless (<= stop (length arr))
      (error "Invalid serialized object, too many characters."))
    (loop until
      (= (the fixnum stop) free)
      do
      (setf (svref arr free) (ser-read-char stream))
      (incf free))
    (setf (ser-decoder-free decoder) stop)))

(defun ser-encode-strs
  (x stream)
  (let ((len (length x)))
    (ser-print? "; Encoding ~a strings.~%" len)
    (ser-encode-nat len stream)
    (dolist (elem x) (ser-encode-str elem stream))))

(defun ser-decode-and-load-strs
  (hons-mode decoder stream)
  (declare (type ser-decoder decoder))
  (let* ((len (ser-decode-nat stream)) (arr (ser-decoder-array decoder))
      (free (ser-decoder-free decoder))
      (version (ser-decoder-version decoder))
      (stop (+ free len)))
    (declare (type fixnum free))
    (ser-print? "; Decoding ~a strings.~%" len)
    (unless (<= stop (length arr))
      (error "Invalid serialized object, too many strings."))
    (loop until
      (= (the fixnum stop) free)
      do
      (setf (svref arr free)
        (ser-decode-str version hons-mode stream))
      (incf free))
    (setf (ser-decoder-free decoder) stop)))

(defun ser-encode-package
  (pkg x stream)
  (declare (type string pkg))
  (let ((len (length x)))
    (ser-print? "; Encoding ~a symbols for ~a package.~%"
      len
      pkg)
    (ser-encode-str pkg stream)
    (ser-encode-nat (length x) stream)
    (dolist (elem x) (ser-encode-str (symbol-name elem) stream))))

(defun ser-decode-and-load-package
  (check-packagesp decoder stream)
  (declare (type ser-decoder decoder))
  (let* ((version (ser-decoder-version decoder)) (arr (ser-decoder-array decoder))
      (free (ser-decoder-free decoder))
      (pkg-name (ser-decode-str version :never stream))
      (len (ser-decode-nat stream))
      (stop (+ free len)))
    (declare (type fixnum free))
    (ser-print? "; Decoding ~a symbols for ~a package.~%"
      len
      pkg-name)
    (unless (<= stop (length arr))
      (error "Invalid serialized object, too many symbols."))
    (when check-packagesp (pkg-witness pkg-name))
    (loop until
      (= (the fixnum stop) free)
      do
      (setf (svref arr free)
        (let ((temp (ser-decode-str version :never stream)))
          (if *read-suppress*
            nil
            (intern temp pkg-name))))
      (incf free))
    (setf (ser-decoder-free decoder) stop)))

(defun ser-encode-packages
  (alist stream)
  (let ((len (length alist)))
    (ser-print? "; Encoding symbols for ~a packages.~%" len)
    (ser-encode-nat len stream)
    (dolist (entry alist)
      (ser-encode-package (car entry) (cdr entry) stream))))

(defun ser-decode-and-load-packages
  (check-packagesp decoder stream)
  (declare (type ser-decoder decoder))
  (let ((len (ser-decode-nat stream)))
    (ser-print? "; Decoding symbols for ~a packages.~%" len)
    (loop for
      i
      from
      1
      to
      len
      do
      (ser-decode-and-load-package check-packagesp decoder stream))))

(defun ser-hashtable-init
  (size test)
  (make-hash-table :size size :test test :rehash-size 2.2))

(defun ser-gather-atoms
  (x encoder)
  (declare (type ser-encoder encoder))
  (cond ((consp x) (unless (ser-see-obj x (ser-encoder-seen-cons encoder))
        (ser-gather-atoms (car x) encoder)
        (ser-gather-atoms (cdr x) encoder)))
    ((symbolp x) (unless (or (eq x t)
          (eq x nil)
          (ser-see-obj x (ser-encoder-seen-sym encoder)))
        (push x
          (gethash (symbol-package x) (ser-encoder-symbol-ht encoder)))))
    ((typep x 'fixnum) (unless (ser-see-obj x (ser-encoder-seen-eql encoder))
        (if (< (the fixnum x) 0)
          (push x (ser-encoder-rationals encoder))
          (push x (ser-encoder-naturals encoder)))))
    ((typep x 'array) (unless (ser-see-obj x (ser-encoder-seen-str encoder))
        (push x (ser-encoder-strings encoder))))
    (t (unless (ser-see-obj x (ser-encoder-seen-eql encoder))
        (cond ((typep x 'character) (push x (ser-encoder-chars encoder)))
          ((typep x 'integer) (if (< x 0)
              (push x (ser-encoder-rationals encoder))
              (push x (ser-encoder-naturals encoder))))
          ((rationalp x) (push x (ser-encoder-rationals encoder)))
          ((complex-rationalp x) (push x (ser-encoder-complexes encoder)))
          (t (error "ser-gather-atoms-types given non-ACL2 object.")))))))

(defun ser-make-atom-map
  (encoder)
  (let ((free-index 2) (seen-sym (ser-encoder-seen-sym encoder))
      (seen-eql (ser-encoder-seen-eql encoder))
      (seen-str (ser-encoder-seen-str encoder)))
    (declare (type fixnum free-index)
      (type hash-table seen-sym seen-eql seen-str))
    (dolist (elem (ser-encoder-naturals encoder))
      (setf (gethash elem seen-eql) free-index)
      (incf free-index))
    (dolist (elem (ser-encoder-rationals encoder))
      (setf (gethash elem seen-eql) free-index)
      (incf free-index))
    (dolist (elem (ser-encoder-complexes encoder))
      (setf (gethash elem seen-eql) free-index)
      (incf free-index))
    (dolist (elem (ser-encoder-chars encoder))
      (setf (gethash elem seen-eql) free-index)
      (incf free-index))
    (dolist (elem (ser-encoder-strings encoder))
      (setf (gethash elem seen-str) free-index)
      (incf free-index))
    (let ((al nil))
      (maphash (lambda (key val) (push (cons (package-name key) val) al))
        (ser-encoder-symbol-ht encoder))
      (setf (ser-encoder-symbol-al encoder) al))
    (dolist (elem (ser-encoder-symbol-al encoder))
      (dolist (sym (cdr elem))
        (setf (gethash sym seen-sym) free-index)
        (incf free-index)))
    (setf (gethash nil seen-sym) 0)
    (setf (gethash t seen-sym) 1)
    (setf (ser-encoder-free-index encoder) free-index)))

(defun ser-encode-conses
  (x encoder)
  "Returns X-INDEX"
  (declare (type ser-encoder encoder))
  (if (atom x)
    (cond ((symbolp x) (gethash x (ser-encoder-seen-sym encoder)))
      ((stringp x) (gethash x (ser-encoder-seen-str encoder)))
      (t (gethash x (ser-encoder-seen-eql encoder))))
    (let* ((seen-cons (ser-encoder-seen-cons encoder)) (idx (gethash x seen-cons)))
      (if (typep idx 'fixnum)
        idx
        (let* ((car-index (ser-encode-conses (car x) encoder)) (cdr-index (ser-encode-conses (cdr x) encoder))
            (free-index (ser-encoder-free-index encoder))
            (stream (ser-encoder-stream encoder))
            (v2-car-index (if (hl-hspace-honsp-wrapper x)
                (the fixnum (logior (the fixnum (ash car-index 1)) 1))
                (the fixnum (ash car-index 1)))))
          (declare (type fixnum car-index cdr-index v2-car-index free-index))
          (setf (gethash x seen-cons) free-index)
          (ser-encode-nat v2-car-index stream)
          (ser-encode-nat cdr-index stream)
          (setf (ser-encoder-free-index encoder)
            (the fixnum (+ 1 free-index)))
          free-index)))))

(defun ser-decode-and-load-conses
  (hons-mode decoder stream)
  (declare (type ser-decoder decoder))
  (let* ((len (ser-decode-nat stream)) (arr (ser-decoder-array decoder))
      (free (ser-decoder-free decoder))
      (version (ser-decoder-version decoder))
      (stop (+ free len)))
    (declare (type fixnum free))
    (ser-print? "; Decoding ~a consing instructions.~%" len)
    (unless (<= stop (length arr))
      (error "Invalid serialized object, too many conses."))
    (if (eq version :v1)
      (if (eq hons-mode :always)
        (ser-decode-loop :v1 :always)
        (ser-decode-loop :v1 :never))
      (cond ((eq hons-mode :always) (ser-decode-loop :v2 :always))
        ((eq hons-mode :never) (ser-decode-loop :v2 :never))
        (t (ser-decode-loop :v2 :smart))))
    (setf (ser-decoder-free decoder) stop)))

(defun ser-encode-fals
  (encoder)
  (declare (type ser-encoder encoder))
  (let* ((stream (ser-encoder-stream encoder)) (seen-cons (ser-encoder-seen-cons encoder))
      (fn (lambda (alist backing-hash-table)
          (let ((idx (gethash alist seen-cons)))
            (when idx
              (ser-encode-nat idx stream)
              (ser-encode-nat (hash-table-count backing-hash-table)
                stream))))))
    (hl-faltable-maphash fn (hl-hspace-faltable-wrapper))
    (ser-encode-nat 0 stream)))

(defun ser-decode-and-restore-fals
  (decoder hons-mode stream)
  (declare (type ser-decoder decoder))
  (let* ((array (ser-decoder-array decoder)) (max (length array))
      (index (ser-decode-nat stream)))
    (loop until
      (= index 0)
      do
      (unless (< index max)
        (error "FAL index to restore is too large!"))
      (unless (eq hons-mode :never)
        (let ((alist (svref array index)) (count (ser-decode-nat stream)))
          (hl-restore-fal-for-serialize alist count)))
      (setq index (ser-decode-nat stream)))))

(defun ser-encode-atoms
  (encoder)
  (declare (type ser-encoder encoder))
  (let ((stream (ser-encoder-stream encoder)))
    (ser-encode-nats (ser-encoder-naturals encoder) stream)
    (ser-encode-rats (ser-encoder-rationals encoder) stream)
    (ser-encode-complexes (ser-encoder-complexes encoder)
      stream)
    (ser-encode-chars (ser-encoder-chars encoder) stream)
    (ser-encode-strs (ser-encoder-strings encoder) stream)
    (ser-encode-packages (ser-encoder-symbol-al encoder) stream)))

(defun ser-encode-to-stream
  (obj stream)
  (let ((encoder (make-ser-encoder :stream stream)) starting-free-index-for-conses
      total-number-of-objects
      max-index
      nconses)
    (declare (dynamic-extent encoder))
    (hl-maybe-initialize-default-hs-wrapper)
    (ser-time? (ser-gather-atoms obj encoder))
    (setq nconses
      (hash-table-count (ser-encoder-seen-cons encoder)))
    (unless (typep (ash (+ 2
            (hash-table-count (ser-encoder-seen-sym encoder))
            (hash-table-count (ser-encoder-seen-eql encoder))
            (hash-table-count (ser-encoder-seen-str encoder))
            nconses)
          1)
        'fixnum)
      (error "Maximum index exceeded."))
    (ser-time? (ser-make-atom-map encoder))
    (setq starting-free-index-for-conses
      (ser-encoder-free-index encoder))
    (ser-encode-magic stream)
    (setq total-number-of-objects
      (the fixnum (+ starting-free-index-for-conses nconses)))
    (ser-encode-nat (cond ((eq obj nil) 0) (t (- total-number-of-objects 1)))
      stream)
    (ser-time? (ser-encode-atoms encoder))
    (ser-encode-nat nconses stream)
    (setq max-index (ser-time? (ser-encode-conses obj encoder)))
    (ser-time? (ser-encode-fals encoder))
    (unless (and (equal (ser-encoder-free-index encoder)
          total-number-of-objects)
        (or (equal max-index (- (ser-encoder-free-index encoder) 1))
          (equal max-index 0)))
      (error "Sanity check failed in ser-encode-to-stream!~% ~
                - final-free-index is ~a~% ~
                - total-number-of-objects is ~a~% ~
                - max-index is ~a~%"
        (ser-encoder-free-index encoder)
        total-number-of-objects
        max-index))
    (ser-encode-magic stream)))

(defun ser-decode-and-load-atoms
  (check-packagesp hons-mode decoder stream)
  (declare (type ser-decoder decoder))
  (ser-decode-and-load-nats decoder stream)
  (ser-decode-and-load-rats decoder stream)
  (ser-decode-and-load-complexes decoder stream)
  (ser-decode-and-load-chars decoder stream)
  (ser-decode-and-load-strs hons-mode decoder stream)
  (ser-decode-and-load-packages check-packagesp
    decoder
    stream))

(defun ser-make-array-wrapper
  (size)
  (declare (optimize (safety 3)))
  (make-array size))

(defun ser-decode-from-stream
  (check-packagesp hons-mode stream)
  (let* ((version (ser-decode-magic stream)) (size/idx (ser-decode-nat stream))
      (arr-size (if (or (eq version :v2) (eq version :v3))
          (cond ((eq size/idx 0) 2) (t (+ size/idx 1)))
          size/idx))
      (final-obj (if (or (eq version :v2) (eq version :v3))
          size/idx
          (- arr-size 1))))
    (unless (typep arr-size 'fixnum)
      (error "Serialized object is too large."))
    (let* ((arr (ser-make-array-wrapper arr-size)) (decoder (make-ser-decoder :array arr :free 0 :version version)))
      (declare (dynamic-extent arr decoder)
        (type ser-decoder decoder))
      (when (or (eq version :v2) (eq version :v3))
        (setf (aref arr 0) nil)
        (setf (aref arr 1) t)
        (setf (ser-decoder-free decoder) 2))
      (ser-print? "; Decoding serialized object of size ~a.~%"
        arr-size)
      (ser-time? (ser-decode-and-load-atoms check-packagesp
          hons-mode
          decoder
          stream))
      (ser-time? (ser-decode-and-load-conses hons-mode decoder stream))
      (when (eq version :v3)
        (ser-decode-and-restore-fals decoder hons-mode stream))
      (unless (eq (ser-decode-magic stream) version)
        (error "Invalid serialized object, magic number mismatch."))
      (unless (= (ser-decoder-free decoder) arr-size)
        (error "Invalid serialized object.~% ~
                 - Decode-free is ~a~%
                 - Arr-size is ~a."
          (ser-decoder-free decoder)
          arr-size))
      (svref arr final-obj))))