World's Slowest tnetstring parser

tnetparse.lisp

(asdf:load-system :parser-combinators)
(use-package :parser-combinators)
(defparameter *true* t)
(defparameter *false* nil)
(defparameter *null* nil)
(defparameter *empty-dict* nil)
(defparameter *empty-list* nil)
(declaim (optimize (speed 3)))

(defun <tnetstring> ()
  (mdo (<- length (nat*))
       ":"
       (<- val
           (if (= length 0) (result nil)
             (times? (item) length)))
       (<- tag (choices "," "#" "]" "}" "^" "!" "~"))
       (case tag
         (#\, (result (map 'string (lambda (x) x) val)))
         (#\# (result (parse-string* (int*) val :complete t)))
         (#\^ (result
                (when
                  (parse-string* (seq-list* (int*) "." (int*)) val :complete t)
                  (read-from-string (map 'string (lambda (x) x) val)))))
         (#\! (cond
                ((parse-string* "true" val :complete t) (result *true*))
                ((parse-string* "false" val :complete t) (result *false*))
                (t (zero))))
         (#\~ (if (= 0 (length val)) (result *null*) (zero)))
         (#\}
          (multiple-value-bind (stuff _ success __)
            (parse-string* (many? (seq-list* (<tnetstring>) (<tnetstring>))) val :complete :first)
            (declare (ignore _ __))
            (if success
              (if (null stuff) (result *empty-dict*)
                (result (loop 
                          for (key value) in stuff
                          collect (cons key value))))
              (zero))))
         (#\]
          (multiple-value-bind (stuff _ success __)
            (parse-string* (many? (<tnetstring>)) val :complete :first)
            (declare (ignore _ __))
            (if success
              (result
                (if (null stuff) *empty-list*
                  stuff))
              (zero)))))))