literal-hash.lisp

;;;; design

;;; (enable-literal-hash) => T ; implementation dependent.
;;; (gethash :a #H((:a . :b))) => :B ; T
;;; (princ #H((:a . :b)))
;;; #H((:a . :b)) ; side effect.
;;; => #<HASHTABLE 12345678>

(in-package :cl-user)
(defpackage :literal-hash(:use :cl)
  (:export
    #:enable-literal-hash
    ))    
(in-package :literal-hash)

(defun |#H-reader|(stream c n)
  (declare(ignore c))
  (let((ht(make-hash-table :test (hash-test n))))
    (loop :for (k . v) :in (read stream t t t)
          :do (setf(gethash k ht)v))
    ht))

(defun hash-test(number)
  (check-type number (or null (mod 4)))
  (if number
    (svref #(#'eq #'eql #'equal #'equalp) number)
    #'eql))

(defun enable-literal-hash()
  (set-dispatch-macro-character #\# #\h #'|#H-reader|))

;;;; Implementation dependent.
;;; ecl is not effected below method. (bug?)
;;; clisp already print hash literaly
#-clisp
(defmethod print-object((ht hash-table)*standard-output*)
  (if *print-readably*
    (call-next-method) ; may error implementation dependent.
    (if *print-escape*
      (print-unreadable-object(ht *standard-output* :identity t :type t))
      (if *print-pretty*
        (pprint-ht ht)
        (print-ht ht)))))

(defun pprint-ht(ht &optional(*standard-output* *standard-output*))
  (pprint-logical-block(nil nil :prefix "#H(" :suffix ")")
    (loop :for k :being :each :hash-key :in ht :using (:hash-value v) :do
          (pprint-pop)
          (format t "(~S . ~S)"k v)
          (pprint-newline :fill))))

(defun print-ht(ht &optional (*standard-output* *standard-output*))
  (loop :initially (write-string "#H(")
        :for k :being :each :hash-key :in ht :using (:hash-value v)
        :do (format t "(~S . ~S)" k v)
        :finally (write-string ")")))