;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; module:    hook.el 
;;;; version:   1.3
;;;; author:    Ciaran A Byrne      ciaran@hrc63.co.uk
; comments/suggestions to ...!seismo!mcvax!ukc!gec-rl-hrc!ciaran
;;;; date:      20:Aug:87
;;;;
;;;;;;;;;;;;;;;;;;;; hook insertion fns;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;;    macros:
;;;;            some c[ad]+r fns
;;;;
;;;;    commands:
;;;;            add-hook                - appends s-exp to function
;;;;            make-hook-var           - adds hook variable to a function
;;;;
(provide 'add-hook)

(defun add-hook (target-function posthook &optional prehook) 
"Redefines FUNCTION so that POSTHOOK form is evaluated (apparently!) after the 
function has completed.  Also, an optional PREHOOK form is evaluated before
the function body, but after any interactive processing.

e.g. (add-hook 'next-line '(what-line))

The original return value is preserved.
Does not work with subr's.
"

;Even if it did attempt to put a wrapper around a subr,
;it would be only partially effective, 
;since subrs get called from other 'C'-coded fns.

    (interactive "aTarget function: 
xs-exp: ")

;       OLD FORM            ==>         NEW FORM
;
;  (defun foo (args) "bar"      (defun foo (args) "bar"
;       (interactive "s")            (interactive "s")
;       (s1)                         prehook
;       (s2))                        (prog1
;                                       (progn 
;                                           (s1)
;                                           (s2))  ; old result
;                                       posthook)   ; new action
;
  (if (subrp (symbol-function target-function))
         (error "No can do; %s is a subr" target-function)   ; message => error

    (let* (  (fval (symbol-function target-function))
              (args (cadr fval))
              (body (cddr fval))
              (doc  (car body))
              (newfn (list 'lambda args)) )
        
        (if (or (numberp doc) (stringp doc))    ; move body past doc 
            (setq newfn (append newfn (list doc))
                  body (cdr body)))

        (if (eq 'interactive (caar body)) ; move body past (interactive ..)
            (setq newfn (append newfn (list (car body)))
                  body (cdr body)))

        (fset target-function
              (append newfn
                      (list prehook
                       (list 'prog1
                             (append '(progn) body)
                             posthook))
                      )
              )
        ) ; let
    )
  )

