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 / ystep.scm < prev   
Text File  |  1999-01-02  |  14KB  |  469 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: ystep.scm,v 1.3 1999/01/02 06:19:10 cph Exp $
  4.  
  5. Copyright (c) 1994, 1999 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. ;;;; YStep - a step away from ZStep
  23. ;;; package: (runtime stepper)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define-structure (stepper (constructor make-stepper (stack)))
  28.   (stack '())
  29.   (run? #f)                ;#t => run; #f => step
  30.   (step-over #f)            ;#f or top node of step-over
  31.   (step-until? #f)            ;the step-over is really a step-until
  32.   next                    ;continuation of stepped program
  33.   continuation
  34.   last-event                ;last thing that happened
  35.   (finished #f)                ;when completed, stack is
  36.                     ;empty and this points to top node
  37.   hooks                    ;low-level stepper hooks
  38.   (trace '())                ;low-level trace recording
  39.   )
  40.  
  41. (define (stack-push! state node)
  42.   (set-stepper-stack! state (cons node (stepper-stack state))))
  43.  
  44. (define (stack-pop! state)
  45.   (set-stepper-stack! state (cdr (stepper-stack state))))
  46.  
  47. (define (stack-top state)
  48.   (car (stepper-stack state)))
  49.  
  50. (define (stack-bottom state)
  51.   (car (last-pair (stepper-stack state))))
  52.  
  53. (define (stack-empty? state)
  54.   (null? (stepper-stack state)))
  55.  
  56. (define (stepper-root-node state)
  57.   (if (stack-empty? state)
  58.       (stepper-finished state)
  59.       (stack-bottom state)))
  60.  
  61. ;;; The magic numbers here represent the number of eval and return
  62. ;;; events that occur during the startup process.  They will very
  63. ;;; likely have to change when the system changes.
  64.  
  65. (define (step-form expression environment)
  66.   ;; start a new evaluation
  67.   (step-start (make-ynode #f 'TOP ynode-exp:top-level)
  68.           (lambda () (eval expression environment))
  69.           (if (stepper-compiled?) 0 6)
  70.           (if (stepper-compiled?) 1 5)))
  71.  
  72. (define (step-proceed)
  73.   ;; proceed from breakpoint
  74.   (step-start (make-ynode #f 'PROCEED ynode-exp:proceed)
  75.           (lambda () (continue))
  76.           (if (stepper-compiled?) 0 4)
  77.           (if (stepper-compiled?) 5 7)))
  78.  
  79. (define (stepper-compiled?)
  80.   (compiled-procedure? (lambda () unspecific)))
  81.  
  82. (define (step-start top-node thunk skip-evals skip-returns)
  83.   (if (not (step-hooks-present?))
  84.       (error "Sorry, this copy of Scheme does not support stepping."))
  85.   (let ((state (make-stepper (list top-node))))
  86.     (set-stepper-hooks! state (make-stepper-hooks state))
  87.     (set-stepper-next! state
  88.                (lambda ()
  89.              (dummy-eval-step
  90.               (make-starting-hooks state skip-evals skip-returns))
  91.              (thunk)))
  92.     (step-output-initialize state)
  93.     (step state)))
  94.  
  95. (define (step state)
  96.   (set-stepper-run?! state #f)
  97.   (raw-step state))
  98.  
  99. (define (step-run state)
  100.   (set-stepper-run?! state #t)
  101.   (raw-step state))
  102.  
  103. (define (step-quit state)
  104.   ;; [entry] not working yet
  105.   (dummy-eval-step no-step-hooks)
  106.   ((stepper-next state)))
  107.  
  108. (define (step-n state n)
  109.   (do ((n n (- n 1))
  110.        (value unspecific (step state)))
  111.       ((<= n 0) value)))
  112.  
  113. (define (step-over state)
  114.   (set-stepper-step-until?! state #f)
  115.   (step-over-1 state))
  116.  
  117. (define (step-until state)
  118.   (set-stepper-step-until?! state #t)
  119.   (step-over-1 state))
  120.  
  121. (define (step-until-visibly state)
  122.   (set-stepper-step-until?! state 'ANIMATE)
  123.   (step-over-1 state))
  124.  
  125. (define (step-over-1 state)
  126.   (if (not (eq? (car (stepper-last-event state)) 'CALL))
  127.       (error "Last event was not a call:" (stepper-last-event state)))
  128.   (set-stepper-step-over! state (stack-top state))
  129.   (new-ynode-type! (stack-top state)
  130.            (if (stepper-step-until? state) 'EVAL 'STEP-OVER))
  131.   (raw-step state))
  132.  
  133. (define (raw-step state)
  134.   ;; the workhorse
  135.   (if (stepper-finished state)
  136.       (step-output-final-result state (ynode-result (stepper-finished state)))
  137.       (begin
  138.     (set-stepper-next! state
  139.                (call-with-current-continuation
  140.                 (lambda (kk)
  141.                   (set-stepper-continuation! state kk)
  142.                   ((stepper-next state)))))
  143.     (if (stepper-run? state)
  144.         (raw-step state)
  145.         (step-output state #f)))))
  146.  
  147. ;;; Output Stubs:
  148.  
  149. (define (step-output-initialize state)
  150.   state
  151.   unspecific)
  152.  
  153. (define (step-output state redisplay?)
  154.   state redisplay?
  155.   unspecific)
  156.  
  157. (define (step-output-final-result state value)
  158.   state
  159.   value)
  160.  
  161. ;;;; Low-level Hooks
  162.  
  163. (define (make-stepper-hooks state)
  164.   (letrec
  165.       ((hooks
  166.     (hunk3-cons
  167.      (lambda (expr env)
  168.        (hook-record state
  169.             (list 'EVAL (map-reference-trap (lambda () expr)) env))
  170.        (process-eval state (map-reference-trap (lambda () expr)))
  171.        (primitive-eval-step expr env hooks))
  172.      (lambda (proc . args)
  173.        (hook-record state
  174.             (list 'APPLY
  175.                   proc
  176.                   (map (lambda (arg)
  177.                      (map-reference-trap (lambda () arg)))
  178.                    args)))
  179.        (process-apply state proc)
  180.        (primitive-apply-step proc args hooks))
  181.      (lambda (value)
  182.        (hook-record state
  183.             (list 'RETURN (map-reference-trap (lambda () value))))
  184.        (process-return state (map-reference-trap (lambda () value)))
  185.        (primitive-return-step value hooks)))))
  186.     hooks))
  187.  
  188. (define (make-starting-hooks state skip-evals skip-returns)
  189.   (letrec
  190.       ((hooks
  191.     (hunk3-cons
  192.      (lambda (expr env)
  193.        (if (and (<= skip-evals 0) (<= skip-returns 0))
  194.            ((system-hunk3-cxr0 (stepper-hooks state)) expr env)
  195.            (begin
  196.          (set! skip-evals (- skip-evals 1))
  197.          (hook-record state (list 'EVAL expr env))
  198.          (primitive-eval-step expr env hooks))))
  199.      #f
  200.      (lambda (result)
  201.        (if (and (<= skip-evals 0) (<= skip-returns 0))
  202.            ((system-hunk3-cxr2 (stepper-hooks state)) result)
  203.            (begin
  204.          (set! skip-returns (- skip-returns 1))
  205.          (hook-record state (list 'RESULT result))
  206.          (primitive-return-step result hooks)))))))
  207.     hooks))
  208.  
  209. (define no-step-hooks
  210.   (hunk3-cons #f #f #f))
  211.  
  212. (define-integrable primitive-eval-step
  213.   (ucode-primitive primitive-eval-step))
  214.  
  215. (define-integrable primitive-apply-step
  216.   (ucode-primitive primitive-apply-step))
  217.  
  218. (define-integrable primitive-return-step
  219.   (ucode-primitive primitive-return-step))
  220.  
  221. ;;;; Worker Bees
  222.  
  223. (define (process-eval state exp)
  224.   (if (reduction? exp (ynode-exp (stack-top state)))
  225.       (process-reduction state))
  226.   (let ((node
  227.      (make-ynode (and (not (stack-empty? state))
  228.               (stack-top state))
  229.              (if (and (stepper-step-over state)
  230.                   (not (stepper-step-until? state)))
  231.              'STEPPED-OVER
  232.              'EVAL)
  233.              exp)))
  234.     (stack-push! state node)
  235.     (set-stepper-last-event! state `(CALL ,node))
  236.     (maybe-redisplay state)))
  237.  
  238. (define (process-apply state proc)
  239.   (if (compound-procedure? proc)
  240.       (process-reduction state)))
  241.  
  242. (define (process-return state result)
  243.   (if (stepper-step-over state)
  244.       (maybe-end-step-over state))
  245.   (let ((node
  246.      (let ((node (stack-top state)))
  247.        (if (eq? (ynode-type node) 'PROCEED)
  248.            (ynode-splice-under node)
  249.            (begin
  250.          (stack-pop! state)
  251.          node)))))
  252.     (new-ynode-result! node result)
  253.     (if (stack-empty? state)
  254.     (set-stepper-finished! state node))
  255.     (set-stepper-last-event! state `(RETURN ,node))
  256.     (maybe-redisplay state)))
  257.  
  258. (define (maybe-redisplay state)
  259.   (if (stepper-step-over state)
  260.       (if (eq? (stepper-step-until? state) 'ANIMATE)
  261.       (step-output state #t))
  262.       (call-with-current-continuation
  263.        (lambda (k)
  264.      ((stepper-continuation state) (lambda () (k unspecific)))))))
  265.  
  266. (define (maybe-end-step-over state)
  267.   (if (ynode-reduces-to? (stack-top state) (stepper-step-over state))
  268.       (begin
  269.     (set-stepper-step-over! state #f)
  270.     (set-stepper-step-until?! state #f))))
  271.  
  272. (define (process-reduction state)
  273.   (new-ynode-result! (stack-top state) ynode-result:reduced)
  274.   (stack-pop! state))
  275.  
  276. (define (reduction? f1 f2)
  277.   ;; Args are SCode expressions.  True if F2 is a reduction of F1.
  278.   (cond ((conditional? f2)
  279.      (or (eq? f1 (conditional-consequent f2))
  280.          (eq? f1 (conditional-alternative f2))))
  281.     ((sequence? f2)
  282.      (eq? f1 (car (last-pair (sequence-actions f2)))))
  283.     (else #f)))
  284.  
  285. ;;;; Stepper nodes
  286.  
  287. (define-structure (ynode (constructor make-ynode-1 (parent type exp)))
  288.   ;; Could easily store environment as well.
  289.   parent
  290.   type
  291.   (exp #f read-only #t)
  292.   (children '())
  293.   (result #f)
  294.   (redisplay-flags (cons #t (if parent (ynode-redisplay-flags parent) '()))
  295.            read-only #t))
  296.  
  297. (define ynode-exp:top-level (list 'STEPPER-TOP-LEVEL))
  298. (define ynode-exp:proceed   (list 'STEPPER-PROCEED))
  299.  
  300. (define (ynode-exp-special node)
  301.   (let ((exp (ynode-exp node)))
  302.     (and (or (eq? ynode-exp:top-level exp)
  303.          (eq? ynode-exp:proceed exp))
  304.      (car exp))))
  305.  
  306. (define ynode-result:waiting (list 'WAITING))
  307. (define ynode-result:reduced (list 'REDUCED))
  308. (define ynode-result:unknown (list 'UNKNOWN))
  309.  
  310. (define (ynode-result-special node)
  311.   (let ((result (ynode-result node)))
  312.     (and (or (eq? ynode-result:waiting result)
  313.          (eq? ynode-result:reduced result)
  314.          (eq? ynode-result:unknown result))
  315.      (car result))))
  316.  
  317. (define (ynode-reduced? node)
  318.   (eq? (ynode-result node) ynode-result:reduced))
  319.  
  320. (define (make-ynode parent type exp)
  321.   (let ((node (make-ynode-1 parent type exp)))
  322.     (set-ynode-result! node ynode-result:waiting)
  323.     (if parent
  324.     (set-ynode-children! parent (cons node (ynode-children parent))))
  325.     (ynode-needs-redisplay! node)
  326.     node))
  327.  
  328. (define (ynode-previous node)
  329.   (let loop ((sibs (ynode-children (ynode-parent node))))
  330.     (cond ((null? sibs)
  331.        #f)
  332.       ((eq? (car sibs) node)
  333.        (and (not (null? (cdr sibs)))
  334.         (cadr sibs)))
  335.       (else
  336.        (loop (cdr sibs))))))
  337.  
  338. (define (ynode-next node)
  339.   (let loop ((sibs (ynode-children (ynode-parent node))))
  340.     (cond ((or (null? sibs) (null? (cdr sibs)))
  341.        #f)
  342.       ((eq? (cadr sibs) node)
  343.        (car sibs))
  344.       (else
  345.        (loop (cdr sibs))))))
  346.  
  347. (define (ynode-value-node node)
  348.   (if (ynode-reduced? node)
  349.       (let ((next (ynode-next node)))
  350.     (and next
  351.          (ynode-value-node next)))
  352.       node))
  353.  
  354. (define (ynode-reduces-to? node reduces-to)
  355.   (and node
  356.        (or (eq? node reduces-to)
  357.        (let ((previous (ynode-previous node)))
  358.          (and previous
  359.           (ynode-reduced? previous)
  360.           (ynode-reduces-to? previous reduces-to))))))
  361.  
  362. (define (ynode-splice-under node)
  363.   (let ((children (ynode-children node)))
  364.     (set-ynode-children! node '())
  365.     (let ((new-node (make-ynode node 'EVAL ynode-result:unknown)))
  366.       (set-ynode-children! new-node children)
  367.       (for-each (lambda (c) (set-ynode-parent! c new-node)) children)
  368.       (let loop ((node new-node))
  369.     (ynode-needs-redisplay! ynode)
  370.     (for-each loop (ynode-children node)))
  371.       new-node)))
  372.  
  373. (define (ynode-reductions node)
  374.   (if (ynode-reduced? node)
  375.       (let ((next (ynode-next node)))
  376.     (cons next (ynode-reductions next)))
  377.       '()))
  378.  
  379. (define (ynode-dependents node)
  380.   ;; A dependent (misnomer) roughly means nodes that are directly
  381.   ;; called by another node (which is not the same as children,
  382.   ;; because reductions muck things up).
  383.   (if (ynode-reduced? node)
  384.       (cons (ynode-next node)
  385.         (ynode-direct-children node))
  386.       (ynode-direct-children node)))
  387.  
  388. (define (ynode-direct-children node)
  389.   ;; A "direct" child is one that is not a reduction of another child...
  390.   (let loop ((children (ynode-children node)) (dependents '()))
  391.     (if (null? children)
  392.     dependents
  393.     (loop (cdr children)
  394.           (if (and (not (null? (cdr children)))
  395.                (ynode-reduced? (cadr children)))
  396.           dependents
  397.           (cons (car children) dependents))))))
  398.  
  399. (define (ynode-hidden-children? node)
  400.   ;; used to control drawing of arrow
  401.   (and (eq? (ynode-type node) 'STEP-OVER)
  402.        (not (null? (ynode-children node)))))
  403.  
  404. (define (ynode-needs-redisplay! ynode)
  405.   (if (not (car (ynode-redisplay-flags ynode)))
  406.       (begin
  407.     (set-car! (ynode-redisplay-flags ynode) #t)
  408.     (if (ynode-parent ynode)
  409.         (ynode-needs-redisplay! (ynode-parent ynode))))))
  410.  
  411. (define (ynode-needs-redisplay? ynode)
  412.   (car (ynode-redisplay-flags ynode)))
  413.  
  414. (define (ynode-doesnt-need-redisplay! ynode)
  415.   (set-car! (ynode-redisplay-flags ynode) #f))
  416.  
  417. (define (new-ynode-type! ynode type)
  418.   (set-ynode-type! ynode type)
  419.   (ynode-needs-redisplay! ynode))
  420.  
  421. (define (new-ynode-result! ynode result)
  422.   (set-ynode-result! ynode result)
  423.   (ynode-needs-redisplay! ynode))
  424.  
  425. (define (ynode-expand! node)
  426.   (new-ynode-type! node 'EVAL)
  427.   (for-each (lambda (dependent)
  428.           (if (eq? (ynode-type dependent) 'STEPPED-OVER)
  429.           (new-ynode-type! dependent 'STEP-OVER)))
  430.         (ynode-dependents node)))
  431.  
  432. (define (ynode-contract! node)
  433.   (new-ynode-type! node 'STEP-OVER)
  434.   (for-each (lambda (dependent)
  435.           (new-ynode-type! dependent 'STEPPED-OVER))
  436.         (ynode-reductions node)))
  437.  
  438. ;;;; Miscellaneous
  439.  
  440. (define (dummy-eval-step hooks)
  441.   (primitive-eval-step #f system-global-environment hooks))
  442.  
  443. (define (step-hooks-present?)
  444.   (let ((flag #f))
  445.     (dummy-eval-step
  446.      (hunk3-cons #f
  447.          #f
  448.          (lambda (value)
  449.            (set! flag #t)
  450.            (primitive-return-step value no-step-hooks))))
  451.     flag))
  452.  
  453. ;;; Debugging trace:
  454.  
  455. ;;; disabled, see next definition
  456. ;;; (define (hook-record state item)
  457. ;;;   (set-stepper-trace! state (cons item (stepper-trace state))))
  458.  
  459. (define-integrable (hook-record state item)
  460.   ;; DEFINE-INTEGRABLE guarantees that argument in ITEM position is
  461.   ;; not evaluated.
  462.   state item
  463.   unspecific)
  464.  
  465. (define (print-hook-trace state)
  466.   (pp (let loop ((thing (stepper-trace state)))
  467.     (cond ((list? thing) (map loop thing))
  468.           ((symbol? thing) thing)
  469.           (else (unsyntax thing))))))