ciaran@hrc63.co.uk (Ciaran Byrne) (10/23/87)
It occurs to me that a general way of adding hook functions/variables etc
may be a useful extension to GNU lisp.
I vote for keeping such modifiers on the function's property list,
since the precedent has (sort of) been set by the 'disabled property
for commands.
Here is something to help elisp authors go on living when they are being
pestered by people who arrogantly think he should have included a whole
bunch of features that nobody has thought of yet. :-)
I haven't had the time to test this properly, so I would appreciate
some feedback (especially if it works at all !)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; module: velcro.el
;;;; version: 0.1 (preliminary)
;;;; author: Ciaran A Byrne
;;;; date: 23/Oct/87
;;;;
;;;; comments/suggestions to ...!seismo!mcvax!ukc!gec-rl-hrc!ciaran
;;;;
;;;;;;;;;;;;;;;;;;;; multi-hook insertion ;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; functions:
;;;; make-velcro - makes a fn multi-hooked
;;;; unhook - undoes make-velcro
;;;; hookedp - predicate for hooked fn.
;;;;
;;;; auxillaries:
;;;; subst - a la cl
;;;; dtp - predicate for dotted pair
(provide 'velcro)
(defun dtp (p) "true iff arg is a dotted pair"
(and (consp p) (atom (cdr p))))
(defun subst (old new tree)
"substitutes occurrences of OLD with NEW in TREE"
(cond ((null tree) nil)
((equal tree old) new)
((atom tree) tree)
((dtp tree) (cons (subst old new (car tree))
(subst old new (cdr tree))))
(t (mapcar (function (lambda (c) (subst old new c))) tree))))
(defun velcro-form (fn) "(internal) returns multi-hook form for FUNCTION"
(subst 'target fn ; I know this looks monstrous - I wrote it !!
(function
(lambda (&rest function-args) "doc"
(funcall (get 'target 'pre-hook))
(eval
(subst ; wrap function body
'function-body
'(put 'target 'saved-retval
(apply (get 'target 'original-fval)
(funcall (get 'target 'arg-hook) function-args)))
(get 'target 'body-form)))
(funcall (get 'target 'post-hook))
(run-hooks (get 'target 'run-hooks))
(funcall (get 'target 'retval-hook)(get 'target 'saved-retval))
)
)
)
)
(defconst Hook-tag "*Hooked Function*" "Prefixes doc string of hooked fn")
(defun null-arg-hook (args) args)
(defun null-pre-hook ())
(defun null-retval-hook (retval) retval)
(defun null-post-hook ())
(defun make-velcro (fn) "Rewrites the FUNCTION so that various dynamic 'hook' modifiers are available.
Modifiers are stored on the target function's property list (see put,get):
pre-hook - function, no args, called before the target
arg-hook - function, applied to original list of ARGS,
should return a new argument list.
body-form - replaces original body, any embedded occurence of the
symbol 'function-body is replaced with the original body,
the variable function-args is the original arg list.
retval-hook - function, called with original RETURN value,
should return a new result.
post-hook - function, no args, called after target.
run-hooks - symbol, the name of a hook variable, actioned after
the post-hook (provided for backwards compatibility).
Suitable null values are installed by make-velcro.
The user must provide his modifier(s) as required.
"
;;;;;;;; try this (fairly futile) example
;
; (defun double (x) (+ x x))
; (make-velcro 'x)
;
; (put 'double 'pre-hook
; (function (lambda () (message "Cogitas ergo sum!") (sit-for 1))))
;
; (put 'double 'arg-hook
; (function (lambda (a) (list (+ (car a) 1)))))
; ; add one to arg before doubling
;
; (put 'double 'body-form
; '(save-excursion
; (let ((old-stdout standard-output)
; (standard-output (get-buffer-create "mylog")))
; (princ "function double processing arg ")
; (print function-args) ; NB before arg-hook gets them
; function-body ; this gets substituted
; (setq standard-output old-stdout))))
;
; (put 'double 'retval-hook
; (function (lambda (r) (* 3 r))))
; ; triple result
; ;
; ; overall result is now: (double n) ==> (* 3 (* (+ n 1) 2))
;
; (put 'double 'post-hook
; (function (lambda () (message "Sumas ergo cogit!") (sit-for1))))
;
; (put 'double 'run-hooks 'double-hook)
; ; for conventional hook variable use, if you still need it
(interactive "aHook which function ? ")
(put fn 'pre-hook 'null-pre-hook)
(put fn 'arg-hook 'null-arg-hook)
(put fn 'body-form 'function-body)
(put fn 'retval-hook 'null-retval-hook)
(put fn 'post-hook 'null-post-hook)
(put fn 'run-hooks nil)
(put fn 'original-fval (symbol-function fn))
(let* ((hooked-form (velcro-form fn))
(docstr (concat Hook-tag "\n" (documentation fn))))
(rplaca (cdr (cdr hooked-form)) docstr)
(fset fn hooked-form))
)
(defun unhook (fn) "Undoes the effect of make-velcro (qv)"
(fset fn (get fn 'original-fval)))
(defun hookedp (fn) "returns t if FUNCTION is a hooked fn"
(equal (string-match Hook-tag (documentation fn)) 0))
;;;;;;;;;;;;;;;;;;;;;;;;;; end of velcro.el ;;;;;;;;;;;;;;;;;;;;;;;;;
I'm young.. I'm HEALTHY.. I can HIKE THRU CAPT GROGAN'S LUMBAR REGIONS!
bye now,
ciaran