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 / histry.scm < prev    next >
Text File  |  1999-01-02  |  8KB  |  230 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: histry.scm,v 14.6 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1988, 1989, 1990, 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. ;;;; History Manipulation
  23. ;;; package: (runtime history)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;; Vertebrae
  28.  
  29. (define-integrable (make-vertebra rib deeper shallower)
  30.   (history:unmark (hunk3-cons rib deeper shallower)))
  31.  
  32. (define-integrable vertebra-rib system-hunk3-cxr0)
  33. (define-integrable deeper-vertebra system-hunk3-cxr1)
  34. (define-integrable shallower-vertebra system-hunk3-cxr2)
  35. (define-integrable set-vertebra-rib! system-hunk3-set-cxr0!)
  36. (define-integrable set-deeper-vertebra! system-hunk3-set-cxr1!)
  37. (define-integrable set-shallower-vertebra! system-hunk3-set-cxr2!)
  38.  
  39. (define-integrable (marked-vertebra? vertebra)
  40.   (history:marked? (system-hunk3-cxr1 vertebra)))
  41.  
  42. (define (mark-vertebra! vertebra)
  43.   (system-hunk3-set-cxr1! vertebra
  44.               (history:mark (system-hunk3-cxr1 vertebra))))
  45.  
  46. (define (unmark-vertebra! vertebra)
  47.   (system-hunk3-set-cxr1! vertebra
  48.               (history:unmark (system-hunk3-cxr1 vertebra))))
  49.  
  50. (define-integrable (same-vertebra? x y)
  51.   (= (object-datum x) (object-datum y)))
  52.  
  53. (define (link-vertebrae previous next)
  54.   (set-deeper-vertebra! previous next)
  55.   (set-shallower-vertebra! next previous))
  56.  
  57. ;;; Reductions
  58.  
  59. (define-integrable (make-reduction expression environment next)
  60.   (history:unmark (hunk3-cons expression environment next)))
  61.  
  62. (define-integrable reduction-expression system-hunk3-cxr0)
  63. (define-integrable reduction-environment system-hunk3-cxr1)
  64. (define-integrable next-reduction system-hunk3-cxr2)
  65. (define-integrable set-reduction-expression! system-hunk3-set-cxr0!)
  66. (define-integrable set-reduction-environment! system-hunk3-set-cxr1!)
  67. (define-integrable set-next-reduction! system-hunk3-set-cxr2!)
  68.  
  69. (define-integrable (marked-reduction? reduction)
  70.   (history:marked? (system-hunk3-cxr2 reduction)))
  71.  
  72. (define (mark-reduction! reduction)
  73.   (system-hunk3-set-cxr2! reduction
  74.               (history:mark (system-hunk3-cxr2 reduction))))
  75.  
  76. (define (unmark-reduction! reduction)
  77.   (system-hunk3-set-cxr2! reduction
  78.               (history:unmark (system-hunk3-cxr2 reduction))))
  79.  
  80. (define-integrable (same-reduction? x y)
  81.   (= (object-datum x) (object-datum y)))
  82.  
  83. ;;; Marks
  84.  
  85. (define-integrable (history:unmark object)
  86.   (object-new-type (ucode-type unmarked-history) object))
  87.  
  88. (define-integrable (history:mark object)
  89.   (object-new-type (ucode-type marked-history) object))
  90.  
  91. (define-integrable (history:marked? object)
  92.   (object-type? (ucode-type marked-history) object))
  93.  
  94. ;;;; History Initialization
  95.  
  96. (define (create-history depth width)
  97.   (let ((new-vertebra
  98.      (lambda ()
  99.        (let ((head (make-reduction false false '())))
  100.          (set-next-reduction!
  101.           head
  102.           (let reduction-loop ((n (-1+ width)))
  103.         (if (zero? n)
  104.             head
  105.             (make-reduction false false (reduction-loop (-1+ n))))))
  106.          (make-vertebra head '() '())))))
  107.     (if (not (and (exact-integer? depth) (positive? depth)))
  108.     (error "CREATE-HISTORY: invalid depth" depth))
  109.     (if (not (and (exact-integer? width) (positive? width)))
  110.     (error "CREATE-HISTORY: invalid width" width))
  111.     (let ((head (new-vertebra)))
  112.       (let subproblem-loop ((n (-1+ depth)) (previous head))
  113.     (if (zero? n)
  114.         (link-vertebrae previous head)
  115.         (let ((next (new-vertebra)))
  116.           (link-vertebrae previous next)
  117.           (subproblem-loop (-1+ n) next))))
  118.       head)))
  119.  
  120. ;;; The PUSH-HISTORY! accounts for the pop which happens after
  121. ;;; SET-CURRENT-HISTORY! is run.
  122.  
  123. (define (with-new-history thunk)
  124.   ((ucode-primitive with-history-disabled)
  125.     (lambda ()
  126.       ((ucode-primitive set-current-history!)
  127.        (let ((history
  128.           (push-history! (create-history max-subproblems
  129.                          max-reductions))))
  130.      (if (zero? max-subproblems)
  131.  
  132.          ;; In this case, we want the history to appear empty,
  133.          ;; so when it pops up, there is nothing in it.
  134.          history
  135.  
  136.          ;; Otherwise, record a dummy reduction, which will appear
  137.          ;; in the history.
  138.          (begin (record-dummy-reduction-in-history! history)
  139.             (push-history! history)))))
  140.       (thunk))))
  141.  
  142. (define max-subproblems 10)
  143. (define max-reductions 5)
  144.  
  145. ;;;; Primitive History Operations
  146. ;;;  These operations mimic the actions of the microcode.
  147. ;;;  The history motion operations all return the new history.
  148.  
  149. (define (record-evaluation-in-history! history expression environment)
  150.   (let ((current-reduction (vertebra-rib history)))
  151.     (set-reduction-expression! current-reduction expression)
  152.     (set-reduction-environment! current-reduction environment)))
  153.  
  154. (define (set-history-to-next-reduction! history)
  155.   (let ((next-reduction (next-reduction (vertebra-rib history))))
  156.     (set-vertebra-rib! history next-reduction)
  157.     (unmark-reduction! next-reduction)
  158.     history))
  159.  
  160. (define (push-history! history)
  161.   (let ((deeper-vertebra (deeper-vertebra history)))
  162.     (mark-vertebra! deeper-vertebra)
  163.     (mark-reduction! (vertebra-rib deeper-vertebra))
  164.     deeper-vertebra))
  165.  
  166. (define (pop-history! history)
  167.   (unmark-vertebra! history)
  168.   (shallower-vertebra history))
  169.  
  170. ;;;; Side-Effectless Examiners
  171.  
  172. (define (history-transform history)
  173.   (let loop ((current history))
  174.     (cons current
  175.       (if (marked-vertebra? current)
  176.           (cons (delay (unfold-and-reverse-rib (vertebra-rib current)))
  177.             (delay (let ((next (shallower-vertebra current)))
  178.                  (if (same-vertebra? next history)
  179.                  the-empty-history
  180.                  (loop next)))))
  181.           '()))))
  182.  
  183. (define the-empty-history)
  184.  
  185. (define (unfold-and-reverse-rib rib)
  186.   (let loop ((current (next-reduction rib)) (output 'WRAP-AROUND))
  187.     (let ((step
  188.        (let ((tail
  189.           (if (marked-reduction? current)
  190.               '()
  191.               output)))
  192.          (if (dummy-reduction? current)
  193.          tail
  194.          (cons (list (reduction-expression current)
  195.                  (reduction-environment current))
  196.                tail)))))
  197.       (if (same-reduction? current rib)
  198.       step
  199.       (loop (next-reduction current) step)))))
  200.  
  201. (define (dummy-reduction? reduction)
  202.   (and (false? (reduction-expression reduction))
  203.        (eq? (ucode-return-address pop-from-compiled-code)
  204.         (reduction-environment reduction))))                 
  205.  
  206. (define (record-dummy-reduction-in-history! history)
  207.   (record-evaluation-in-history!
  208.    history
  209.    false
  210.    (ucode-return-address pop-from-compiled-code)))
  211.  
  212. (define (history-superproblem history)
  213.   (if (null? (cdr history))
  214.       history
  215.       (force (cddr history))))
  216.  
  217. (define (history-reductions history)
  218.   (if (null? (cdr history))
  219.       '()
  220.       (force (cadr history))))
  221.  
  222. (define-integrable (history-untransform history)
  223.   (car history))
  224.  
  225. (define (initialize-package!)
  226.   (set! the-empty-history
  227.     (cons (vector-ref (get-fixed-objects-vector)
  228.               (fixed-objects-vector-slot 'DUMMY-HISTORY))
  229.           '()))
  230.   unspecific)