;; Title: Patch to make backquote forms print as such.

;;; Notes

;; The new pprint dispatch is expensive now. 
;;
;; `,x reads as (CCL::BACKQUOTE-EXPANDER #:|`,| #:|`,.| #:|`,@| (#:|`,| . X))
;;
;; If CCL::*BACKQUOTE-EXPAND* is off.
;;
;; The #:|`,| is new for each backquote. We have a *BQ-PRINT-CONTEXT* to
;; which we record the currently printed CCL::BACKQUOTE-EXPANDER.
;; Printing would be faster, if instead of (#:|`,| . X) sth like
;;
;;     (COMMA #:|`,| x)
;;
;; would be used, since pprint dispatch could EQ hash on the car of a
;; form to be printed. We cought fix CCL:LIB;BACKQUOTE.LISP
;;
;; --GB

(in-package :cl-user)

(setq ccl::*backquote-expand* nil)

(defvar *bq-print-context* nil)

(defun bq-comma-p (object)
  (and (consp object)
       (symbolp (car object))
       *bq-print-context*
       (eq (car object) (first (car *bq-print-context*)))))

(defun bq-comma-at-p (object)
  (and (consp object)
       (symbolp (car object))
       *bq-print-context*
       (eq (car object) (third (car *bq-print-context*)))))

(defun bq-comma-dot-p (object)
  (and (consp object)
       (symbolp (car object))
       *bq-print-context*
       (eq (car object) (second (car *bq-print-context*)))))

(defun pprint-backquote (stream object)
  (let ((*bq-print-context*
         (cons (list (second object) (third object) (fourth object))
               *bq-print-context*)))
    (write-string "`" stream)
    (prin1 (fifth object) stream)))

(defun pprint-bq-comma (stream object)
  (write-string "," stream)
  (let ((*bq-print-context* (cdr *bq-print-context*)))
    (prin1 (cdr object) stream)))

(defun pprint-bq-comma-at (stream object)
  (write-string ",@" stream)
  (let ((*bq-print-context* (cdr *bq-print-context*)))
    (prin1 (cdr object) stream)))

(defun pprint-bq-comma-dot (stream object)
  (write-string ",." stream)
  (let ((*bq-print-context* (cdr *bq-print-context*)))
  (prin1 (cdr object) stream)))

(progn
  (set-pprint-dispatch '(cons (eql ccl::backquote-expander) (cons symbol (cons symbol (cons symbol t))))
                       'pprint-backquote 0 ccl::*ipd*)
  (set-pprint-dispatch '(and (cons symbol t) (satisfies bq-comma-p)) 'pprint-bq-comma 0 ccl::*ipd*)
  (set-pprint-dispatch '(and (cons symbol t) (satisfies bq-comma-at-p)) 'pprint-bq-comma-at 0 ccl::*ipd*)
  (set-pprint-dispatch '(and (cons symbol t) (satisfies bq-comma-dot-p)) 'pprint-bq-comma-dot 0 ccl::*ipd*))

(in-package :ccl)

;; CCL:LIB;BACKQUOTE.LISP
(let ((ccl:*warn-if-redefine-kernel* nil))
  (defun backquote-aux (form)
    ;;Doesn't try to optimize multiple CONS's into LIST/LIST*'s, leaving it up
    ;;to the compiler.  The code here is mainly concerned with folding
    ;;constants, since the compiler is not allowed to do that in general.
    (cond
      ((simple-vector-p form)
       (let ((elts ()) (i (length form)))
         (until (%izerop i) (push (svref form (setq i (%i- i 1))) elts))
         (multiple-value-bind (elts quotedp) (backquote-aux elts)
           (if quotedp
               (values (list-to-vector elts) t)
               (list 'list-to-vector elts)))))
      ((self-evaluating-p form) (values form t))
      ((atom form) (values form t))
      ;; <-- patch
      ((and ccl::*backquote-expand*
            (eq (%car form) 'backquote-expander) (backquote-aux (macroexpand-1 form))))
      ;; -->
      ((eq (%car form) *|`,|*) (%cdr form))
      ((eq (%car form) *|`,@|*) (error "Misplaced ,@~S after backquote" (%cdr form)))
      ((eq (%car form) *|`,.|*) (error "Misplaced ,.~S after backquote" (%cdr form)))
      (t (let* ((car (%car form))
                (splice (and (consp car) (if (eq (%car car) *|`,@|*) 'append
                                             (if (eq (%car car) *|`,.|*) 'nconc)))))
           (multiple-value-bind (cdr qd) (backquote-aux (%cdr form))
             (if splice
                 (cond ((null (%cdr car)) (values cdr qd))
                       ((null cdr) (values (%cdr car) (self-evaluating-p (%cdr car))))
                       (t (list splice (%cdr car) (backq-form cdr qd))))
                 (multiple-value-bind (car qa) (backquote-aux car)
                   (cond ((and qa qd) (values (cons car cdr) t))
                         ((null cdr) (list 'list car))
                         (t (list 'list* ; was CONS
                                  (backq-form car qa) (backq-form cdr qd))))))))))))

(in-package :cl-user)