home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / advice.scm < prev    next >
Text File  |  2000-06-07  |  16KB  |  469 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: advice.scm,v 14.17 2000/06/07 04:56:23 cph Exp $
  4.  
  5. Copyright (c) 1988-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Advice package
  23. ;;; package: (runtime advice)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define entry-advice-population)
  28. (define exit-advice-population)
  29.  
  30. (define particular-entry-advisor)
  31. (define particular-exit-advisor)
  32. (define particular-both-advisor)
  33. (define particular-entry-unadvisor)
  34. (define particular-exit-unadvisor)
  35. (define particular-both-unadvisor)
  36.  
  37. (define primitive-trace-entry)
  38. (define primitive-trace-exit)
  39. (define primitive-trace-both)
  40.  
  41. (define primitive-untrace)
  42. (define primitive-untrace-entry)
  43. (define primitive-untrace-exit)
  44.  
  45. (define primitive-break-entry)
  46. (define primitive-break-exit)
  47. (define primitive-break-both)
  48.  
  49. (define primitive-unbreak)
  50. (define primitive-unbreak-entry)
  51. (define primitive-unbreak-exit)
  52.  
  53. (define advice)
  54. (define entry-advice)
  55. (define exit-advice)
  56.  
  57. (define advise-entry)
  58. (define advise-exit)
  59.  
  60. (define wrap-entry-unadvisor)
  61. (define wrap-exit-unadvisor)
  62. (define wrap-both-unadvisor)
  63.  
  64. (define unadvise)
  65. (define unadvise-entry)
  66. (define unadvise-exit)
  67.  
  68. (define untrace)
  69. (define untrace-entry)
  70. (define untrace-exit)
  71.  
  72. (define unbreak)
  73. (define unbreak-entry)
  74. (define unbreak-exit)
  75.  
  76. (define trace-entry)
  77. (define trace-exit)
  78. (define trace-both)
  79. (define trace)
  80.  
  81. (define break-entry)
  82. (define break-exit)
  83. (define break-both)
  84. (define break)
  85.  
  86. (define (initialize-package!)
  87.   (set! entry-advice-population (make-population))
  88.   (set! exit-advice-population (make-population))
  89.   (set! particular-entry-advisor (particular-advisor primitive-advise-entry))
  90.   (set! particular-exit-advisor (particular-advisor primitive-advise-exit))
  91.   (set! particular-both-advisor primitive-advise-both)
  92.   (set! particular-entry-unadvisor primitive-unadvise-entry)
  93.   (set! particular-exit-unadvisor primitive-unadvise-exit)
  94.   (set! particular-both-unadvisor primitive-unadvise-both)
  95.   (set! primitive-trace-entry (particular-entry-advisor trace-entry-advice))
  96.   (set! primitive-trace-exit (particular-exit-advisor trace-exit-advice))
  97.   (set! primitive-trace-both
  98.     (particular-both-advisor trace-entry-advice trace-exit-advice))
  99.   (set! primitive-untrace
  100.     (particular-both-unadvisor trace-entry-advice trace-exit-advice))
  101.   (set! primitive-untrace-entry
  102.     (particular-entry-unadvisor trace-entry-advice))
  103.   (set! primitive-untrace-exit (particular-exit-unadvisor trace-exit-advice))
  104.   (set! primitive-break-entry (particular-entry-advisor break-entry-advice))
  105.   (set! primitive-break-exit (particular-exit-advisor break-exit-advice))
  106.   (set! primitive-break-both
  107.     (particular-both-advisor break-entry-advice break-exit-advice))
  108.   (set! primitive-unbreak
  109.     (particular-both-unadvisor break-entry-advice break-exit-advice))
  110.   (set! primitive-unbreak-entry
  111.     (particular-entry-unadvisor break-entry-advice))
  112.   (set! primitive-unbreak-exit (particular-exit-unadvisor break-exit-advice))
  113.   (set! advice (wrap-advice-extractor primitive-advice))
  114.   (set! entry-advice (wrap-advice-extractor primitive-entry-advice))
  115.   (set! exit-advice (wrap-advice-extractor primitive-exit-advice))
  116.   (set! advise-entry (wrap-general-advisor primitive-advise-entry))
  117.   (set! advise-exit (wrap-general-advisor primitive-advise-exit))
  118.   (set! wrap-entry-unadvisor
  119.     (wrap-unadvisor
  120.      (lambda (operation)
  121.        (map-over-population entry-advice-population operation))))
  122.   (set! wrap-exit-unadvisor
  123.     (wrap-unadvisor
  124.      (lambda (operation)
  125.        (map-over-population exit-advice-population operation))))
  126.   (set! wrap-both-unadvisor
  127.     (wrap-unadvisor
  128.      (lambda (operation)
  129.        (map-over-population entry-advice-population operation)
  130.        (map-over-population exit-advice-population operation))))
  131.   (set! unadvise (wrap-both-unadvisor primitive-unadvise-entire-lambda))
  132.   (set! unadvise-entry (wrap-entry-unadvisor primitive-unadvise-entire-entry))
  133.   (set! unadvise-exit (wrap-exit-unadvisor primitive-unadvise-entire-exit))
  134.   (set! untrace (wrap-both-unadvisor primitive-untrace))
  135.   (set! untrace-entry (wrap-entry-unadvisor primitive-untrace-entry))
  136.   (set! untrace-exit (wrap-exit-unadvisor primitive-untrace-exit))
  137.   (set! unbreak (wrap-both-unadvisor primitive-unbreak))
  138.   (set! unbreak-entry (wrap-entry-unadvisor primitive-unbreak-entry))
  139.   (set! unbreak-exit (wrap-exit-unadvisor primitive-unbreak-exit))
  140.   (set! trace-entry (wrap-advisor primitive-trace-entry))
  141.   (set! trace-exit (wrap-advisor primitive-trace-exit))
  142.   (set! trace-both (wrap-advisor primitive-trace-both))
  143.   (set! trace trace-both)
  144.   (set! break-entry (wrap-advisor primitive-break-entry))
  145.   (set! break-exit (wrap-advisor primitive-break-exit))
  146.   (set! break-both (wrap-advisor primitive-break-both))
  147.   (set! break break-both)
  148.   unspecific)
  149.  
  150. ;;;; Advice Wrappers
  151.  
  152. (define the-arguments)
  153. (define the-procedure)
  154. (define the-result)
  155.  
  156. (define (*args*)
  157.   (list-copy the-arguments))
  158.  
  159. (define (*proc*)
  160.   the-procedure)
  161.  
  162. (define (*result*)
  163.   the-result)
  164.  
  165. (define (add-lambda-advice! *lambda advice-transformation)
  166.   (lambda-wrap-body! *lambda
  167.     (lambda (body state receiver)
  168.       (if (null? state)
  169.       (receiver (make-advice-hook)
  170.             (advice-transformation '() '() cons))
  171.       (receiver body
  172.             (advice-transformation (car state) (cdr state) cons))))))
  173.  
  174. (define (remove-lambda-advice! *lambda advice-transformation)
  175.   (lambda-advice *lambda
  176.     (lambda (entry-advice exit-advice)
  177.       (advice-transformation entry-advice exit-advice
  178.     (lambda (new-entry-advice new-exit-advice)
  179.       (if (and (null? new-entry-advice) (null? new-exit-advice))
  180.           (lambda-unwrap-body! *lambda)
  181.           (lambda-wrap-body! *lambda
  182.         (lambda (body state receiver)
  183.           state
  184.           (receiver body
  185.                 (cons new-entry-advice new-exit-advice))))))))))
  186.  
  187. (define (lambda-advice *lambda receiver)
  188.   (lambda-wrapper-components *lambda
  189.     (lambda (original-body state)
  190.       original-body
  191.       (if (null? state)
  192.       (error "Procedure has no advice -- LAMBDA-ADVICE" *lambda))
  193.       (receiver (car state) (cdr state)))))
  194.  
  195. (define (make-advice-hook)
  196.   ;; This inserts the actual procedure in a constant list
  197.   (make-combination
  198.    (make-combination car
  199.              (list (list hook/advised-procedure-wrapper)))
  200.    (list (make-the-environment))))
  201.  
  202. (define (hook/advised-procedure-wrapper environment)
  203.   (advised-procedure-wrapper environment))
  204.  
  205. ;;;; The Advice Hook
  206.  
  207. ;;; This procedure is called with the newly-created environment as its
  208. ;;; argument.
  209.  
  210. (define (advised-procedure-wrapper environment)
  211.   (let ((procedure (ic-environment/procedure environment))
  212.     (arguments (ic-environment/arguments environment)))
  213.     (lambda-wrapper-components (procedure-lambda procedure)
  214.       (lambda (original-body state)
  215.     (call-with-current-continuation
  216.      (lambda (continuation)
  217.        (fluid-let ((advice-continuation continuation))
  218.          (with-restart 'USE-VALUE
  219.          "Return a value from the advised procedure."
  220.          continuation
  221.          (lambda ()
  222.            (prompt-for-evaluated-expression "Procedure value"))
  223.            (lambda ()
  224.          (for-each (lambda (advice)
  225.                  (with-simple-restart 'CONTINUE
  226.                  "Continue with advised procedure."
  227.                    (lambda ()
  228.                  (advice procedure arguments environment))))
  229.                (car state))
  230.          (let ((value (scode-eval original-body environment)))
  231.            (for-each (lambda (advice)
  232.                    (with-simple-restart 'CONTINUE
  233.                    "Return from advised procedure."
  234.                  (lambda ()
  235.                    (advice procedure
  236.                        arguments
  237.                        value
  238.                        environment))))
  239.                  (cdr state))
  240.            value))))))))))
  241.  
  242. (define advice-continuation #f)
  243.  
  244. ;;;; Primitive Advisors
  245.  
  246. (define (primitive-advice *lambda)
  247.   (lambda-advice *lambda list))
  248.  
  249. (define (primitive-entry-advice *lambda)
  250.   (lambda-advice *lambda
  251.     (lambda (entry-advice exit-advice)
  252.       exit-advice
  253.       entry-advice)))
  254.  
  255. (define (primitive-exit-advice *lambda)
  256.   (lambda-advice *lambda
  257.     (lambda (entry-advice exit-advice)
  258.       entry-advice
  259.       exit-advice)))
  260.  
  261. (define (primitive-advise-entry *lambda advice)
  262.   (add-lambda-advice! *lambda
  263.     (lambda (entry-advice exit-advice receiver)
  264.       (receiver (if (memq advice entry-advice)
  265.             entry-advice
  266.             (begin (add-to-population! entry-advice-population *lambda)
  267.                (cons advice entry-advice)))
  268.         exit-advice))))
  269.  
  270. (define (primitive-advise-exit *lambda advice)
  271.   (add-lambda-advice! *lambda
  272.     (lambda (entry-advice exit-advice receiver)
  273.       (receiver entry-advice
  274.         (if (memq advice exit-advice)
  275.             exit-advice
  276.             (begin (add-to-population! exit-advice-population *lambda)
  277.                (append! exit-advice (list advice))))))))
  278.  
  279. (define ((primitive-advise-both new-entry-advice new-exit-advice) *lambda)
  280.   (add-lambda-advice! *lambda
  281.     (lambda (entry-advice exit-advice receiver)
  282.       (receiver (if (memq new-entry-advice entry-advice)
  283.             entry-advice
  284.             (begin (add-to-population! entry-advice-population *lambda)
  285.                (cons new-entry-advice entry-advice)))
  286.         (if (memq new-exit-advice exit-advice)
  287.             exit-advice
  288.             (begin (add-to-population! exit-advice-population *lambda)
  289.                (append! exit-advice (list new-exit-advice))))))))
  290.  
  291. (define (eq?-adjoin object list)
  292.   (if (memq object list)
  293.       list
  294.       (cons object list)))
  295.  
  296. (define (primitive-unadvise-entire-entry *lambda)
  297.   (remove-lambda-advice! *lambda
  298.     (lambda (entry-advice exit-advice receiver)
  299.       entry-advice
  300.       (receiver '() exit-advice)))
  301.   (remove-from-population! entry-advice-population *lambda))
  302.  
  303. (define (primitive-unadvise-entire-exit *lambda)
  304.   (remove-lambda-advice! *lambda
  305.     (lambda (entry-advice exit-advice receiver)
  306.       exit-advice
  307.       (receiver entry-advice '())))
  308.   (remove-from-population! exit-advice-population *lambda))
  309.  
  310. (define (primitive-unadvise-entire-lambda *lambda)
  311.   (lambda-unwrap-body! *lambda)
  312.   (remove-from-population! entry-advice-population *lambda)
  313.   (remove-from-population! exit-advice-population *lambda))
  314.  
  315. (define ((primitive-unadvise-entry advice) *lambda)
  316.   (remove-lambda-advice! *lambda
  317.     (lambda (entry-advice exit-advice receiver)
  318.       (let ((new-entry-advice (delq! advice entry-advice)))
  319.     (if (null? new-entry-advice)
  320.         (remove-from-population! entry-advice-population *lambda))
  321.     (receiver new-entry-advice exit-advice)))))
  322.  
  323. (define ((primitive-unadvise-exit advice) *lambda)
  324.   (remove-lambda-advice! *lambda
  325.     (lambda (entry-advice exit-advice receiver)
  326.       (let ((new-exit-advice (delq! advice exit-advice)))
  327.     (if (null? new-exit-advice)
  328.         (remove-from-population! exit-advice-population *lambda))
  329.     (receiver entry-advice new-exit-advice)))))
  330.  
  331. (define ((primitive-unadvise-both old-entry-advice old-exit-advice) *lambda)
  332.   (remove-lambda-advice! *lambda
  333.     (lambda (entry-advice exit-advice receiver)
  334.       (let ((new-entry-advice (delq! old-entry-advice entry-advice))
  335.         (new-exit-advice (delq! old-exit-advice exit-advice)))
  336.     (if (null? new-entry-advice)
  337.         (remove-from-population! entry-advice-population *lambda))
  338.     (if (null? new-exit-advice)
  339.         (remove-from-population! exit-advice-population *lambda))
  340.     (receiver new-entry-advice new-exit-advice)))))
  341.  
  342. (define (((particular-advisor advisor) advice) *lambda)
  343.   (advisor *lambda advice))
  344.  
  345. ;;;; Trace and Break
  346.  
  347. (define (trace-entry-advice procedure arguments environment)
  348.   environment
  349.   (trace-display (trace-output-port) procedure arguments))
  350.  
  351. (define (trace-exit-advice procedure arguments result environment)
  352.   environment
  353.   (trace-display (trace-output-port) procedure arguments result)
  354.   result)
  355.  
  356. (define (trace-display port procedure arguments #!optional result)
  357.   (fresh-line port)
  358.   (let ((width (- (max 40 (output-port/x-size port)) 1))
  359.     (write-truncated
  360.      (lambda (object width)
  361.        (let ((output (write-to-string object width)))
  362.          (if (car output)
  363.          (substring-fill! (cdr output) (- width 3) width #\.))
  364.          (write-string (cdr output) port)))))
  365.     (if (default-object? result)
  366.     (write-string "[Entering " port)
  367.     (begin
  368.       (write-string "[" port)
  369.       (write-truncated result (- width 2))
  370.       (newline port)
  371.       (write-string "      <== " port)))
  372.     (write-truncated procedure (- width 11))
  373.     (if (null? arguments)
  374.     (write-string "]" port)
  375.     (begin
  376.       (newline port)
  377.       (let ((write-args
  378.          (lambda (arguments)
  379.            (let loop ((prefix "    Args: ") (arguments arguments))
  380.              (write-string prefix port)
  381.              (write-truncated (car arguments) (- width 11))
  382.              (if (not (null? (cdr arguments)))
  383.              (begin
  384.                (newline port)
  385.                (loop "          " (cdr arguments))))))))
  386.         (if (<= (length arguments) 10)
  387.         (begin
  388.           (write-args arguments)
  389.           (write-string "]" port))
  390.         (begin
  391.           (write-args (list-head arguments 10))
  392.           (newline port)
  393.           (write-string "          ...]" port))))))
  394.     (newline port)))
  395.  
  396. (define (break-entry-advice procedure arguments environment)
  397.   (fluid-let ((the-procedure procedure)
  398.           (the-arguments arguments))
  399.     (break-rep environment "Breakpoint on entry" procedure arguments)))
  400.  
  401. (define (break-exit-advice procedure arguments result environment)
  402.   (fluid-let ((the-procedure procedure)
  403.           (the-arguments arguments)
  404.           (the-result result))
  405.     (break-rep environment "Breakpoint on exit" procedure arguments result))
  406.   result)
  407.  
  408. (define (break-rep environment message . info)
  409.   (breakpoint (cmdl-message/append (cmdl-message/active
  410.                     (lambda (port)
  411.                       (apply trace-display port info)))
  412.                    message)
  413.           environment
  414.           advice-continuation))
  415.  
  416. ;;;; Top Level Wrappers
  417.  
  418. (define (find-internal-lambda procedure path)
  419.   (if (not (compound-procedure? procedure))
  420.       (error "only compound procedures may be advised" procedure))
  421.   (if (null? path)
  422.       (procedure-lambda procedure)
  423.       (let find-lambda
  424.       ((*lambda (procedure-lambda procedure))
  425.        (path (car path)))
  426.     (if (null? path)
  427.         *lambda
  428.         (let loop
  429.         ((elements
  430.           (lambda-components *lambda
  431.             (lambda (name required optional rest auxiliary declarations
  432.                   body)
  433.               name required optional rest declarations
  434.               (if (not (memq (car path) auxiliary))
  435.               (error "no internal definition by this name"
  436.                  (car path)))
  437.               (sequence-actions body)))))
  438.           (if (null? elements)
  439.           (error "Couldn't find internal definition" path))
  440.           (if (assignment? (car elements))
  441.           (assignment-components (car elements)
  442.             (lambda (name value)
  443.               (if (eq? name (car path))
  444.               (begin
  445.                 (if (not (lambda? value))
  446.                 (error "internal definition not a procedure"
  447.                        path))
  448.                 (find-lambda value (cdr path)))
  449.               (loop (cdr elements)))))
  450.           (loop (cdr elements))))))))
  451.  
  452. ;; The LIST-COPY will prevent any mutation problems.
  453. (define ((wrap-advice-extractor extractor) procedure . path)
  454.   (list-copy (extractor (find-internal-lambda procedure path))))
  455.  
  456. (define ((wrap-general-advisor advisor) procedure advice . path)
  457.   (advisor (find-internal-lambda procedure path) advice)
  458.   unspecific)
  459.  
  460. (define (((wrap-unadvisor map-over-population) unadvisor) . procedure&path)
  461.   (if (null? procedure&path)
  462.       (map-over-population unadvisor)
  463.       (unadvisor (find-internal-lambda (car procedure&path)
  464.                        (cdr procedure&path))))
  465.   unspecific)
  466.  
  467. (define ((wrap-advisor advisor) procedure . path)
  468.   (advisor (find-internal-lambda procedure path))
  469.   unspecific)