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 / cpoint.scm < prev    next >
Text File  |  1999-01-02  |  5KB  |  140 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: cpoint.scm,v 14.5 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1988-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. ;;;; Control Points
  23. ;;; package: (runtime control-point)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define-integrable (control-point? object)
  28.   (object-type? (ucode-type control-point) object))
  29.  
  30. (define-integrable (control-point/reusable? control-point)
  31.   (system-vector-ref control-point 0))
  32.  
  33. (define-integrable (control-point/unused-length control-point)
  34.   (object-datum (system-vector-ref control-point 1)))
  35.  
  36. (define-integrable (control-point/interrupt-mask control-point)
  37.   (control-point-ref control-point 1))
  38.  
  39. (define-integrable (control-point/history control-point)
  40.   (control-point-ref control-point 3))
  41.  
  42. (define-integrable (control-point/previous-history-offset control-point)
  43.   (control-point-ref control-point 4))
  44.  
  45. (define-integrable (control-point/previous-history-control-point control-point)
  46.   (control-point-ref control-point 5))
  47.  
  48. (define-integrable (control-point-ref control-point index)
  49.   (system-vector-ref control-point (control-point-index control-point index)))
  50.  
  51. (define-integrable (control-point-index control-point index)
  52.   (+ (control-point/unused-length control-point) (+ 2 index)))
  53.  
  54. (define-integrable (control-point/first-element-index control-point)
  55.   (control-point-index control-point 6))
  56.  
  57. #|
  58.  
  59. ;; Disabled because some procedures in conpar.scm and uenvir.scm
  60. ;; depend on the actual length for finding compiled code variables,
  61. ;; etc.
  62.  
  63. (define (control-point/n-elements control-point)
  64.   (let ((real-length (- (system-vector-length control-point)
  65.             (control-point/first-element-index control-point))))
  66.     (if (control-point/next-control-point? control-point)
  67.     (- real-length 2)
  68.     real-length)))
  69. |#
  70.  
  71. (define (control-point/n-elements control-point)
  72.   (- (system-vector-length control-point)
  73.      (control-point/first-element-index control-point)))
  74.  
  75. (define (control-point/element-stream control-point)
  76.   (let ((end (let ((end (system-vector-length control-point)))
  77.            (if (control-point/next-control-point? control-point)
  78.            (- end 2)
  79.            end))))
  80.     (let loop ((index (control-point/first-element-index control-point)))
  81.       (cond ((= index end) '())
  82.         (((ucode-primitive primitive-object-type? 2)
  83.           (ucode-type manifest-nm-vector)
  84.           (system-vector-ref control-point index))
  85.          (let ((n-skips
  86.             (object-datum (system-vector-ref control-point index))))
  87.            (cons-stream
  88.         (make-non-pointer-object n-skips)
  89.         (let skip-loop ((n n-skips) (index (1+ index)))
  90.           (if (zero? n)
  91.               (loop index)
  92.               (cons-stream false (skip-loop (-1+ n) (1+ index))))))))
  93.         (else
  94.          (cons-stream (system-vector-ref control-point index)
  95.               (loop (1+ index))))))))
  96.  
  97. (define (control-point/next-control-point control-point)
  98.   (and (control-point/next-control-point? control-point)
  99.        (system-vector-ref control-point
  100.               (-1+ (system-vector-length control-point)))))
  101.  
  102. (define (make-control-point reusable?
  103.                 unused-length
  104.                 interrupt-mask
  105.                 history
  106.                 previous-history-offset
  107.                 previous-history-control-point
  108.                 element-stream
  109.                 next-control-point)
  110.   (let ((unused-length
  111.      (if (eq? microcode-id/stack-type 'STACKLETS)
  112.          (max unused-length 7)
  113.          unused-length)))
  114.     (let ((result (make-vector (+ 8
  115.                   unused-length
  116.                   (stream-length element-stream)
  117.                   (if next-control-point 2 0)))))
  118.       (vector-set! result 0 reusable?)
  119.       (vector-set! result 1 (make-non-pointer-object unused-length))
  120.       (vector-set! result (+ 2 unused-length)
  121.            (ucode-return-address restore-interrupt-mask))
  122.       (vector-set! result (+ 3 unused-length) interrupt-mask)
  123.       (vector-set! result (+ 4 unused-length)
  124.            (ucode-return-address restore-history))
  125.       (vector-set! result (+ 5 unused-length) history)
  126.       (vector-set! result (+ 6 unused-length) previous-history-offset)
  127.       (vector-set! result (+ 7 unused-length) previous-history-control-point)
  128.       (let loop ((stream element-stream) (index (+ 8 unused-length)))
  129.     (cond ((stream-pair? stream)
  130.            (vector-set! result index (stream-car stream))
  131.            (loop (stream-cdr stream) (1+ index)))
  132.           (next-control-point
  133.            (vector-set! result index (ucode-return-address join-stacklets))
  134.            (vector-set! result (1+ index) next-control-point))))
  135.       (object-new-type (ucode-type control-point) result))))
  136.  
  137. (define (control-point/next-control-point? control-point)
  138.   ((ucode-primitive primitive-object-eq? 2)
  139.    (system-vector-ref control-point (- (system-vector-length control-point) 2))
  140.    (ucode-return-address join-stacklets)))