;; edebug-cl-read.el  - Edebug reader macros for use with cl-read.
;; If you use cl-read.el and want to use edebug with any code
;; in a file written with CL syntax, then you need to use this
;; package.

;; To install, add the following to your .emacs file:
;; (add-hook 
;;   'cl-load-hook
;;   (function 
;;    (lambda () 
;;     (add-hook 'edebug-setup-hook 
;;	       (function (lambda () (load-library "edebug-cl-read")))))))

;; To Do:
;; Handle shared structures, but this is not normally used in executable code.

;; Read-time evaluation shouldn't be used in a form argument since
;; there is no way to instrument the result of the evaluation.  
;; Need to mangle all local variable names that might be visible to
;; eval, e.g. stream, char

(require 'cl)  ;; dg version
(require 'cl-read)

(provide 'edebug-cl-read)

(defconst edebug-readtable (copy-readtable)
  "The modified readtable in use while reading and instrumenting code.")

;; We need to call offset routines before and after processing several
;; macro chars.  So the next two utilities do that given macro char args.
;; Only wrap those macro char handlers that dont need to be replaced.

(defun edebug-wrap-macro-handler (char)
  ;; Assumes char already handled by function.
  (let ((func (get-macro-character char)))
    (set-macro-character 
     char 
     (byte-compile
      (` (lambda (stream char)
	   (edebug-storing-offsets (1- (point))
	     (funcall (function (, func)) stream char)))))
     edebug-readtable)))

;; Not used, but it could be.
'(defun edebug-wrap-dispatch-macro-handler (disp-char sub-char)
  ;; Assumes chars already handled by function
  (let ((func (get-dispatch-macro-character disp-char sub-char)))
    (set-dispatch-macro-character 
     disp-char sub-char
     (byte-compile
      (` (lambda (stream char n)
	   (edebug-storing-offsets
	       ;; good up to 999
	       (- (point) 2 (if (> n 9) (if (> n 99) 2 1) 0))
	     (funcall (function (, func)) stream char n)))))
     edebug-readtable)))

;; Install the changes to the edebug-readtable now.
(progn
  (edebug-wrap-macro-handler ?\?)
  (edebug-wrap-macro-handler ?\")
  (edebug-wrap-macro-handler ?\[)
  )

;;To recopy from *readtable*
;;(set-syntax-from-character ?\' ?\' edebug-readtable *readtable*)

;;============================================================
;; The rest are replacements for the handlers in cl-read.

;; To read symbols and numbers (constituents), save the internal
;; constituent reader function, define a new one which will be used only
;; while reading for instrumenting.
(if (not (fboundp 'edebug-reader:read-constituent))
    (fset 'edebug-reader:read-constituent
	  (symbol-function 'reader:read-constituent)))

(defun edebug-read-constituent (stream)
  ;; Store point before and after reading constituent.
  (edebug-storing-offsets (point)
    (edebug-reader:read-constituent stream)))


(defvar edebug-read-context)
(defvar edebug-read-stack)

;; Lists and dotted pairs
;; For \(, we must replace the handler because the behavior is 
;; changed in the middle.

(set-macro-character ?\( 
  (function 
   (lambda (stream char)
     (let (edebug-read-dotted-list)
       (edebug-storing-offsets (1- (point))
	 (catch 'read-list
	   (let ((edebug-read-context 'list) 
		 edebug-read-stack)
	     ;; read list elements up to a `.'
	     (catch 'dotted-pair
	       (while t
		 (push (reader:read-from-buffer stream 't)
		       edebug-read-stack)))
	     ;; In dotted pair. Read one more element
	     (push (reader:read-from-buffer stream 't) edebug-read-stack)
	     ;; signal it to the closing paren
	     (setq edebug-read-context 'dotted-pair)
	     ;; If the dotted form is a list, signal to offset routines.
	     (setq edebug-read-dotted-list (listp (car edebug-read-stack)))
	     ;; Next char *must* be closing paren that throws read-list
	     (reader:read-from-buffer stream 't)
	     ;; otherwise an error is signalled
	     (error "CL read error: illegal dotted pair read syntax")))))))
  edebug-readtable)

;; ?\) and ?\. are almost identical but included for completeness.

(set-macro-character ?\) 
  (function 
   (lambda (stream char)
     (cond ((eq edebug-read-context 'list)
	    (throw 'read-list (nreverse edebug-read-stack)))
	   ((eq edebug-read-context 'dotted-pair)
	    (throw 'read-list (nconc (nreverse (cdr edebug-read-stack)) 
				     (car edebug-read-stack))))
	   (t 
	    (error "CL read error: `)' doesn't end a list")))))
  edebug-readtable)
	
(set-macro-character ?\.
  (function 
   (lambda (stream char)
     (and (eq edebug-read-context 'dotted-pair) 
	  (error "CL read error: no more than one `.' allowed in list"))
     (throw 'dotted-pair nil)))
  edebug-readtable)

;;-----------------------------
;; Quoting and backquoting

(set-macro-character ?\'
  (function
   (lambda (stream char)
     (edebug-storing-offsets (1- (point))
       (list 
	(edebug-storing-offsets (point) 'quote)
	(reader:read-from-buffer stream 't)))))
  edebug-readtable)

(set-macro-character ?\`
  (function
   (lambda (stream char)
     (if (= (following-char) ?\ )
	 (edebug-storing-offsets (point) '\`)
       (edebug-storing-offsets (1- (point))
	 (list
	  (edebug-storing-offsets (point) '\`)
	  (reader:read-from-buffer stream 't))))))
  edebug-readtable)

(set-macro-character ?\,
  (function
   (lambda (stream char)
     (cond ((eq (following-char) ?\ )
	    ;; old syntax
	    (edebug-storing-offsets (point) '\,))
	   ((eq (following-char) ?\@)
	    (forward-char 1)
	    (cond ((eq (following-char) ?\ )
		   (edebug-storing-offsets (point) '\,\@))
		  (t
		   (edebug-storing-offsets (- (point) 2)
		     (list
		      (edebug-storing-offsets (point) '\,\@)
		      (reader:read-from-buffer stream 't))))))
	   (t
	    (edebug-storing-offsets (1- (point))
	      (list 	    
	       (edebug-storing-offsets (point) '\,)
	       (reader:read-from-buffer stream 't)))))))
  edebug-readtable)


(defun edebug-ensure-n=0 (n)
  (or (= n 0) 
      (error "Cl reader error: numeric infix argument not allowed %d" n)))

(set-dispatch-macro-character ?\# ?\'
  (function
   (lambda (stream char n)
     (edebug-ensure-n=0 n)
     (edebug-storing-offsets (- (point) 2)
       (list 
	(edebug-storing-offsets (point) 
	  (if (featurep 'cl)  'function* 'function))
	(reader:read-from-buffer stream 't)))))
  edebug-readtable)

;; Read time evaluation:  #.<form>
;; See comments at top.

(set-dispatch-macro-character ?\# ?\.
  (function 
   (lambda (stream char n)
     (edebug-ensure-n=0 n)
     ;; If this handler is called, assume we are instrumenting,
     ;; so first instrument code to evaluate here.   ** check this out more
     (eval (let ((edebug-all-forms t))
	     (edebug-storing-offsets (point)
	       (edebug-read-and-maybe-wrap-form t))))))
  edebug-readtable)


(defun edebug-read-feature (stream char n flag)
  (edebug-ensure-n=0 n)
  (let ((feature (reader:original-read stream))  ;; assume there is space after
	;; This is not exactly correct without *read-suppress*.
	;; But read goes one too far in emacs 18.
	;; And we can't use edebug-read-sexp because it uses read,
	;; which is just replaced by reader:read.
	(object (reader:read-from-buffer stream 't)))
    (if (eq (featurep feature) flag)
	object
      ;; Ignore it.
      (edebug-ignore-offset)
      (throw 'reader-ignore nil))))

(set-dispatch-macro-character ?\# ?\+
  (function 
   (lambda (stream char n)
     (edebug-read-feature stream char n t)))
  edebug-readtable)

(set-dispatch-macro-character ?\# ?\-
  (function 
   (lambda (stream char n)
     (edebug-read-feature stream char n nil)))
  edebug-readtable)

;;=========================================================================
;; Redefine the edebug-read routine to check whether CL syntax is active.

(defun edebug-read (&optional stream)
  "Read a sexp from STREAM.
STREAM is limited to the current buffer.
Create a parallel offset structure as described in doc for edebug-offsets.

This version, from edebug-cl-read, uses cl-read."
  (unwind-protect
      (if (not cl-read-active)
	  ;; Use the reader for standard Emacs Lisp.
	  (edebug-read1 stream)
    
	;; Use cl-read with edebug-readtable.
	(unwind-protect
	    ;; If *readtable* is buffer-local, this wont work.
	    (let ((*readtable* edebug-readtable))
	      (fset 'reader:read-constituent 'edebug-read-constituent)
	      (read stream);; Uses reader:read.
	      )
	  (fset 'reader:read-constituent 'edebug-reader:read-constituent)
	  ))

    ;; Just make sure it is reset for the next time, even if there is an error.
    (setq edebug-current-offset nil)))