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 / uenvir.scm < prev    next >
Text File  |  1999-10-22  |  25KB  |  716 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: uenvir.scm,v 14.40 1999/10/23 03:08:00 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. ;;;; Microcode Environments
  23. ;;; package: (runtime environment)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (environment? object)
  28.   (or (system-global-environment? object)
  29.       (ic-environment? object)
  30.       (stack-ccenv? object)
  31.       (closure-ccenv? object)))
  32.  
  33. (define (environment-has-parent? environment)
  34.   (cond ((system-global-environment? environment)
  35.      #f)
  36.     ((ic-environment? environment)
  37.      (ic-environment/has-parent? environment))
  38.     ((stack-ccenv? environment)
  39.      (stack-ccenv/has-parent? environment))
  40.     ((closure-ccenv? environment)
  41.      (closure-ccenv/has-parent? environment))
  42.     (else
  43.      (illegal-environment environment 'ENVIRONMENT-HAS-PARENT?))))
  44.  
  45. (define (environment-parent environment)
  46.   (cond ((system-global-environment? environment)
  47.      (error "Global environment has no parent" environment))
  48.     ((ic-environment? environment)
  49.      (ic-environment/parent environment))
  50.     ((stack-ccenv? environment)
  51.      (stack-ccenv/parent environment))
  52.     ((closure-ccenv? environment)
  53.      (closure-ccenv/parent environment))
  54.     (else
  55.      (illegal-environment environment 'ENVIRONMENT-PARENT))))
  56.  
  57. (define (environment-bound-names environment)
  58.   (cond ((system-global-environment? environment)
  59.      (system-global-environment/bound-names environment))
  60.     ((ic-environment? environment)
  61.      (ic-environment/bound-names environment))
  62.     ((stack-ccenv? environment)
  63.      (stack-ccenv/bound-names environment))
  64.     ((closure-ccenv? environment)
  65.      (closure-ccenv/bound-names environment))
  66.     (else
  67.      (illegal-environment environment 'ENVIRONMENT-BOUND-NAMES))))
  68.  
  69. (define (environment-bindings environment)
  70.   (map (lambda (name)
  71.      (cons name
  72.            (let ((value (environment-lookup environment name)))
  73.          (if (unassigned-reference-trap? value)
  74.              '()
  75.              (list value)))))
  76.        (environment-bound-names environment)))
  77.  
  78. (define (environment-arguments environment)
  79.   (cond ((ic-environment? environment)
  80.      (ic-environment/arguments environment))
  81.     ((stack-ccenv? environment)
  82.      (stack-ccenv/arguments environment))
  83.     ((or (system-global-environment? environment)
  84.          (closure-ccenv? environment))
  85.      'UNKNOWN)
  86.     (else
  87.      (illegal-environment environment 'ENVIRONMENT-ARGUMENTS))))
  88.  
  89. (define (environment-procedure-name environment)
  90.   (let ((scode-lambda (environment-lambda environment)))
  91.     (and scode-lambda
  92.      (lambda-name scode-lambda))))
  93.  
  94. (define (environment-lambda environment)
  95.   (cond ((system-global-environment? environment)
  96.      #f)
  97.     ((ic-environment? environment)
  98.      (ic-environment/lambda environment))
  99.     ((stack-ccenv? environment)
  100.      (stack-ccenv/lambda environment))
  101.     ((closure-ccenv? environment)
  102.      (closure-ccenv/lambda environment))
  103.     (else
  104.      (illegal-environment environment 'ENVIRONMENT-LAMBDA))))
  105.  
  106. (define (environment-bound? environment name)
  107.   (cond ((interpreter-environment? environment)
  108.      (interpreter-environment/bound? environment name))
  109.     ((stack-ccenv? environment)
  110.      (stack-ccenv/bound? environment name))
  111.     ((closure-ccenv? environment)
  112.      (closure-ccenv/bound? environment name))
  113.     (else
  114.      (illegal-environment environment 'ENVIRONMENT-BOUND?))))
  115.  
  116. (define (environment-lookup environment name)
  117.   (cond ((interpreter-environment? environment)
  118.      (interpreter-environment/lookup environment name))
  119.     ((stack-ccenv? environment)
  120.      (stack-ccenv/lookup environment name))
  121.     ((closure-ccenv? environment)
  122.      (closure-ccenv/lookup environment name))
  123.     (else
  124.      (illegal-environment environment 'ENVIRONMENT-LOOKUP))))
  125.  
  126. (define (environment-assignable? environment name)
  127.   (cond ((interpreter-environment? environment)
  128.      #t)
  129.     ((stack-ccenv? environment)
  130.      (stack-ccenv/assignable? environment name))
  131.     ((closure-ccenv? environment)
  132.      (closure-ccenv/assignable? environment name))
  133.     (else
  134.      (illegal-environment environment 'ENVIRONMENT-ASSIGNABLE?))))
  135.  
  136. (define (environment-assign! environment name value)
  137.   (cond ((interpreter-environment? environment)
  138.      (interpreter-environment/assign! environment name value))
  139.     ((stack-ccenv? environment)
  140.      (stack-ccenv/assign! environment name value))
  141.     ((closure-ccenv? environment)
  142.      (closure-ccenv/assign! environment name value))
  143.     (else
  144.      (illegal-environment environment 'ENVIRONMENT-ASSIGN!))))
  145.  
  146. (define (illegal-environment object procedure)
  147.   (error:wrong-type-argument object "environment" procedure))
  148.  
  149. ;;;; Interpreter Environments
  150.  
  151. (define (interpreter-environment? object)
  152.   (or (system-global-environment? object)
  153.       (ic-environment? object)))
  154.  
  155. (define (guarantee-interpreter-environment object)
  156.   (if (not (interpreter-environment? object))
  157.       (error:wrong-type-datum object "interpreter environment"))
  158.   object)
  159.  
  160. (define-integrable (system-global-environment? object)
  161.   (eq? system-global-environment object))
  162.  
  163. (define (interpreter-environment/bound? environment name)
  164.   (not (lexical-unbound? environment name)))
  165.  
  166. (define (interpreter-environment/lookup environment name)
  167.   (if (lexical-unassigned? environment name)
  168.       (make-unassigned-reference-trap)
  169.       (lexical-reference environment name)))
  170.  
  171. (define (interpreter-environment/assign! environment name value)
  172.   (lexical-assignment environment name value)
  173.   unspecific)
  174.  
  175. (define (system-global-environment/bound-names environment)
  176.   (list-transform-negative (obarray->list (fixed-objects-item 'OBARRAY))
  177.     (lambda (symbol)
  178.       (unbound-name? environment symbol))))
  179.  
  180. (define-integrable (ic-environment? object)
  181.   (object-type? (ucode-type environment) object))
  182.  
  183. (define (ic-environment/has-parent? environment)
  184.   (not (eq? (ic-environment/parent environment) null-environment)))
  185.  
  186. (define (ic-environment/parent environment)
  187.   (select-parent (ic-environment->external environment)))
  188.  
  189. (define (ic-environment/lambda environment)
  190.   (select-lambda (ic-environment->external environment)))
  191.  
  192. (define (ic-environment/procedure environment)
  193.   (select-procedure (ic-environment->external environment)))
  194.  
  195. (define (ic-environment/bound-names environment)
  196.   (list-transform-negative
  197.       (let ((external (ic-environment->external environment))
  198.         (parameters (lambda-bound (ic-environment/lambda environment)))
  199.         (extension-names
  200.          (lambda (environment tail)
  201.            (let ((extension (select-extension environment)))
  202.          (if (environment-extension? extension)
  203.              (map* tail car (environment-extension-aux-list extension))
  204.              tail)))))
  205.     (extension-names environment
  206.              (if (eq? environment external)
  207.                  parameters
  208.                  (extension-names external parameters))))
  209.     (lambda (name)
  210.       (unbound-name? environment name))))
  211.  
  212. (define (unbound-name? environment name)
  213.   (if (eq? name package-name-tag)
  214.       #t
  215.       (lexical-unbound? environment name)))
  216.  
  217. (define (ic-environment/arguments environment)
  218.   (lambda-components* (ic-environment/lambda environment)
  219.     (lambda (name required optional rest body)
  220.       name body
  221.       (let ((lookup
  222.          (lambda (name)
  223.            (interpreter-environment/lookup environment name))))
  224.     (map* (map* (if rest (lookup rest) '())
  225.             lookup
  226.             optional)
  227.           lookup
  228.           required)))))
  229.  
  230. (define (ic-environment/set-parent! environment parent)
  231.   (let ((extension (select-extension (ic-environment->external environment))))
  232.     (if (environment-extension? extension)
  233.     (begin
  234.       (set-environment-extension-parent! extension parent)
  235.       (system-pair-set-cdr! (environment-extension-procedure extension)
  236.                 parent))
  237.     (system-pair-set-cdr! extension parent))))
  238.  
  239. (define (ic-environment/remove-parent! environment)
  240.   (ic-environment/set-parent! environment null-environment))
  241.  
  242. ;;  This corresponds to the #defines in sdata.h
  243.  
  244. (define null-environment
  245.   (object-new-type (object-type #F)
  246.            (fix:xor (object-datum #F) 1)))
  247.  
  248. ;;(define null-environment
  249. ;;  (object-new-type (ucode-type null) 1))
  250.  
  251. (define (make-null-interpreter-environment)
  252.   (let ((environment (let () (the-environment))))
  253.     (ic-environment/remove-parent! environment)
  254.     environment))
  255.  
  256. (define (ic-environment->external environment)
  257.   (let ((procedure (select-procedure environment)))
  258.     (if (internal-lambda? (procedure-lambda procedure))
  259.     (procedure-environment procedure)
  260.     environment)))
  261.  
  262. (define-integrable (select-extension environment)
  263.   (system-vector-ref environment 0))
  264.  
  265. (define (select-procedure environment)
  266.   (let ((object (select-extension environment)))
  267.     (if (environment-extension? object)
  268.     (environment-extension-procedure object)
  269.     object)))
  270.  
  271. (define (select-parent environment)
  272.   (procedure-environment (select-procedure environment)))
  273.  
  274. (define (select-lambda environment)
  275.   (procedure-lambda (select-procedure environment)))
  276.  
  277. (define (extend-ic-environment environment)
  278.   (if (not (or (system-global-environment? environment)
  279.            (ic-environment? environment)))
  280.       (illegal-environment environment 'EXTEND-IC-ENVIRONMENT))
  281.   (let ((environment (eval '(let () (the-environment)) environment)))
  282.     (set-environment-syntax-table!
  283.      environment
  284.      (make-syntax-table (environment-syntax-table environment)))
  285.     environment))
  286.  
  287. ;;;; Compiled Code Environments
  288.  
  289. (define-structure (stack-ccenv (type vector)
  290.                    (named
  291.                 ((ucode-primitive string->symbol)
  292.                  "#[(runtime environment)stack-ccenv]"))
  293.                    (conc-name stack-ccenv/))
  294.   (block #f read-only #t)
  295.   (frame #f read-only #t)
  296.   (start-index #f read-only #t))
  297.  
  298. (define (stack-frame/environment frame default)
  299.   (let* ((ret-add (stack-frame/return-address frame))
  300.      (object (compiled-entry/dbg-object ret-add)))
  301.     (cond ((not object)
  302.        default)
  303.       ((dbg-continuation? object)
  304.        (let ((block (dbg-continuation/block object)))
  305.          (let ((parent (dbg-block/parent block)))
  306.            (case (dbg-block/type parent)
  307.          ((STACK)
  308.           (make-stack-ccenv parent
  309.                     frame
  310.                     (+ (dbg-continuation/offset object)
  311.                        (dbg-block/length block))))
  312.          ((IC)
  313.           (let ((index (dbg-block/ic-parent-index block)))
  314.             (if index
  315.             (guarantee-interpreter-environment
  316.              (stack-frame/ref frame index))
  317.             default)))
  318.          (else
  319.           (error "Illegal continuation parent block" parent))))))
  320.       ((dbg-procedure? object)
  321.        (let ((block (dbg-procedure/block object)))
  322.          (case (dbg-block/type block)
  323.            ((STACK)
  324.         (make-stack-ccenv block
  325.                   frame
  326.                   (if (compiled-closure? ret-add) 0 1)))
  327.            (else
  328.         (error "Illegal procedure block" block)))))
  329.       #|
  330.       ((dbg-expression? object)
  331.        ;; for now
  332.        default)
  333.       |#
  334.       (else
  335.        default))))
  336.  
  337. (define (compiled-procedure/environment entry)
  338.   (if (not (compiled-procedure? entry))
  339.       (error "Not a compiled procedure" entry 'COMPILED-PROCEDURE/ENVIRONMENT))
  340.   (let ((procedure (compiled-entry/dbg-object entry)))
  341.     (if (not procedure)
  342.     (error "Unable to obtain closing environment" entry))
  343.     (let ((block (dbg-procedure/block procedure)))
  344.       (if (not block)
  345.       (error "Unable to obtain closing environment (missing block info)"
  346.          entry))
  347.       (let ((parent (dbg-block/parent block)))
  348.     (define (use-compile-code-block-environment)
  349.       (guarantee-interpreter-environment
  350.        (compiled-code-block/environment
  351.         (compiled-code-address->block entry))))
  352.     (if parent
  353.         (case (dbg-block/type parent)
  354.           ((CLOSURE)
  355.            (make-closure-ccenv (dbg-block/original-parent block)
  356.                    parent
  357.                    entry))
  358.           ((IC)
  359.            (use-compile-code-block-environment))
  360.           (else
  361.            (error "Illegal procedure parent block" parent)))
  362.         ;; This happens when the procedure has no free variables:
  363.         (use-compile-code-block-environment))))))
  364.  
  365. (define (stack-ccenv/has-parent? environment)
  366.   (if (dbg-block/parent (stack-ccenv/block environment))
  367.       #t
  368.       'SIMULATED))
  369.  
  370. (define (stack-ccenv/parent environment)
  371.   (let ((block (stack-ccenv/block environment)))
  372.     (let ((parent (dbg-block/parent block)))
  373.       (if parent
  374.       (case (dbg-block/type parent)
  375.         ((STACK)
  376.          (let loop
  377.          ((block block)
  378.           (frame (stack-ccenv/frame environment))
  379.           (index
  380.            (+ (stack-ccenv/start-index environment)
  381.               (dbg-block/length block))))
  382.            (let ((stack-link (dbg-block/stack-link block)))
  383.          (cond ((not stack-link)
  384.             (with-values
  385.                 (lambda ()
  386.                   (stack-frame/resolve-stack-address
  387.                    frame
  388.                    (stack-ccenv/static-link environment)))
  389.               (lambda (frame index)
  390.                 (let ((block (dbg-block/parent block)))
  391.                   (if (eq? block parent)
  392.                   (make-stack-ccenv parent frame index)
  393.                   (loop block frame index))))))
  394.                ((eq? stack-link parent)
  395.             (make-stack-ccenv parent frame index))
  396.                (else
  397.             (loop stack-link
  398.                   frame
  399.                   (+ (vector-length
  400.                   (dbg-block/layout-vector stack-link))
  401.                  (case (dbg-block/type stack-link)
  402.                    ((STACK)
  403.                     0)
  404.                    ((CONTINUATION)
  405.                     (dbg-continuation/offset
  406.                      (dbg-block/procedure stack-link)))
  407.                    (else
  408.                     (error "illegal stack-link type"
  409.                        stack-link)))
  410.                  index)))))))
  411.         ((CLOSURE)
  412.          (make-closure-ccenv (dbg-block/original-parent block)
  413.                  parent
  414.                  (stack-ccenv/normal-closure environment)))
  415.         ((IC)
  416.          (guarantee-interpreter-environment
  417.           (if (dbg-block/static-link-index block)
  418.           (stack-ccenv/static-link environment)
  419.           (compiled-code-block/environment
  420.            (compiled-code-address->block
  421.             (stack-frame/return-address
  422.              (stack-ccenv/frame environment)))))))
  423.         (else
  424.          (error "illegal parent block" parent)))
  425.       (let ((environment
  426.          (compiled-code-block/environment
  427.            (compiled-code-address->block
  428.             (stack-frame/return-address
  429.              (stack-ccenv/frame environment))))))
  430.         (if (ic-environment? environment)
  431.         environment
  432.         system-global-environment))))))
  433.  
  434. (define (stack-ccenv/lambda environment)
  435.   (dbg-block/source-code (stack-ccenv/block environment)))
  436.  
  437. (define (stack-ccenv/arguments environment)
  438.   (let ((procedure (dbg-block/procedure (stack-ccenv/block environment))))
  439.     (if procedure
  440.     (letrec ((lookup
  441.           (lambda (variable)
  442.             (case (dbg-variable/type variable)
  443.               ((INTEGRATED)
  444.                (dbg-variable/value variable))
  445.               ((INDIRECTED)
  446.                (lookup (dbg-variable/value variable)))
  447.               (else
  448.                (stack-ccenv/lookup environment
  449.                        (dbg-variable/name variable)))))))
  450.       (map* (map* (let ((rest (dbg-procedure/rest procedure)))
  451.             (if rest (lookup rest) '()))
  452.               lookup
  453.               (dbg-procedure/optional procedure))
  454.         lookup
  455.         (dbg-procedure/required procedure)))
  456.     'UNKNOWN)))
  457.  
  458. (define (stack-ccenv/bound-names environment)
  459.   (map dbg-variable/name
  460.        (list-transform-positive
  461.        (vector->list
  462.         (dbg-block/layout-vector (stack-ccenv/block environment)))
  463.      dbg-variable?)))
  464.  
  465. (define (stack-ccenv/bound? environment name)
  466.   (dbg-block/find-name (stack-ccenv/block environment) name))
  467.  
  468. (define (stack-ccenv/lookup environment name)
  469.   (lookup-dbg-variable (stack-ccenv/block environment)
  470.                name
  471.                (stack-ccenv/get-value environment)
  472.                (lambda (name)
  473.              (environment-lookup (stack-ccenv/parent environment)
  474.                          name))))
  475.  
  476. (define (stack-ccenv/assignable? environment name)
  477.   (assignable-dbg-variable? (stack-ccenv/block environment) name
  478.     (lambda (name)
  479.       (environment-assignable? (stack-ccenv/parent environment) name))))
  480.  
  481. (define (stack-ccenv/assign! environment name value)
  482.   (assign-dbg-variable! (stack-ccenv/block environment)
  483.             name
  484.             (stack-ccenv/get-value environment)
  485.             value
  486.     (lambda (name)
  487.       (environment-assign! (stack-ccenv/parent environment) name value))))
  488.  
  489. (define (stack-ccenv/get-value environment)
  490.   (lambda (index)
  491.     (stack-frame/ref (stack-ccenv/frame environment)
  492.              (+ (stack-ccenv/start-index environment) index))))
  493.  
  494. (define (stack-ccenv/static-link environment)
  495.   (let ((static-link
  496.      (find-stack-element environment
  497.                  dbg-block/static-link-index
  498.                  "static link")))
  499.     (if (not (or (stack-address? static-link)
  500.          (interpreter-environment? static-link)))
  501.     (error "Illegal static link in frame" static-link environment))
  502.     static-link))
  503.  
  504. (define (stack-ccenv/normal-closure environment)
  505.   (let ((closure
  506.      (find-stack-element environment
  507.                  dbg-block/normal-closure-index
  508.                  "closure")))
  509.     (if (not (or (compiled-closure? closure) (vector? closure)))
  510.     (error "Frame missing closure" closure environment))
  511. #|
  512.     ;; Temporarily disable this consistency check until the compiler
  513.     ;; is modified to provide the correct information for
  514.     ;; multi-closed procedures.
  515.     (if (not (eq? (compiled-entry/dbg-object closure)
  516.           (dbg-block/procedure (stack-ccenv/block environment))))
  517.     (error "Wrong closure in frame" closure environment))
  518. |#
  519.     closure))
  520.  
  521. (define (find-stack-element environment procedure name)
  522.   (let ((frame (stack-ccenv/frame environment)))
  523.     (stack-frame/ref
  524.      frame
  525.      (let ((index
  526.         (find-stack-index (stack-ccenv/block environment)
  527.                   (stack-ccenv/start-index environment)
  528.                   (stack-frame/length frame)
  529.                   procedure)))
  530.        (if (not index)
  531.        (error (string-append "Unable to find " name) environment))
  532.        index))))
  533.  
  534. (define (find-stack-index block start end procedure)
  535.   (let loop ((block block) (start start))
  536.     (let ((index (procedure block)))
  537.       (if index
  538.       (+ start index)
  539.       (let ((start (+ start (dbg-block/length block)))
  540.         (link (dbg-block/stack-link block)))
  541.         (and link
  542.          (< start end)
  543.          (loop link start)))))))
  544.  
  545. (define-integrable (dbg-block/length block)
  546.   (vector-length (dbg-block/layout-vector block)))
  547.  
  548. (define-structure (closure-ccenv
  549.            (type vector)
  550.            (named
  551.             ((ucode-primitive string->symbol)
  552.              "#[(runtime environment)closure-ccenv]"))
  553.            (conc-name closure-ccenv/))
  554.   (stack-block #f read-only #t)
  555.   (closure-block #f read-only #t)
  556.   (closure #f read-only #t))
  557.  
  558. (define (closure-ccenv/bound-names environment)
  559.   (map dbg-variable/name
  560.        (list-transform-positive
  561.        (vector->list
  562.         (dbg-block/layout-vector (closure-ccenv/stack-block environment)))
  563.      (lambda (variable)
  564.        (and (dbg-variable? variable)
  565.         (closure-ccenv/variable-bound? environment variable))))))
  566.  
  567. (define (closure-ccenv/bound? environment name)
  568.   (let ((block (closure-ccenv/stack-block environment)))
  569.     (let ((index (dbg-block/find-name block name)))
  570.       (and index
  571.        (closure-ccenv/variable-bound?
  572.         environment
  573.         (vector-ref (dbg-block/layout-vector block) index))))))
  574.  
  575. (define (closure-ccenv/variable-bound? environment variable)
  576.   (or (eq? (dbg-variable/type variable) 'INTEGRATED)
  577.       (vector-find-next-element
  578.        (dbg-block/layout-vector (closure-ccenv/closure-block environment))
  579.        variable)))
  580.  
  581. (define (closure-ccenv/lookup environment name)
  582.   (lookup-dbg-variable (closure-ccenv/closure-block environment)
  583.                name
  584.                (closure-ccenv/get-value environment)
  585.                (lambda (name)
  586.              (environment-lookup (closure-ccenv/parent environment)
  587.                          name))))
  588.  
  589. (define (closure-ccenv/assignable? environment name)
  590.   (assignable-dbg-variable? (closure-ccenv/closure-block environment) name
  591.     (lambda (name)
  592.       (environment-assignable? (closure-ccenv/parent environment) name))))
  593.  
  594. (define (closure-ccenv/assign! environment name value)
  595.   (assign-dbg-variable! (closure-ccenv/closure-block environment)
  596.             name
  597.             (closure-ccenv/get-value environment)
  598.             value
  599.     (lambda (name)
  600.       (environment-assign! (closure-ccenv/parent environment) name value))))
  601.  
  602. (define-integrable (closure/get-value closure closure-block index)
  603.   (compiled-closure/ref closure
  604.             index
  605.             (dbg-block/layout-first-offset closure-block)))
  606.  
  607. (define (closure-ccenv/get-value environment)
  608.   (lambda (index)
  609.     (closure/get-value (closure-ccenv/closure environment)
  610.                (closure-ccenv/closure-block environment)
  611.                index)))
  612.  
  613. (define (closure-ccenv/has-parent? environment)
  614.   (or (let ((stack-block (closure-ccenv/stack-block environment)))
  615.     (let ((parent (dbg-block/parent stack-block)))
  616.       (and parent
  617.            (case (dbg-block/type parent)
  618.          ((CLOSURE) (and (dbg-block/original-parent stack-block) #t))
  619.          ((STACK IC) #t)
  620.          (else (error "Illegal parent block" parent))))))
  621.       'SIMULATED))
  622.  
  623. (define (closure-ccenv/parent environment)
  624.   (let ((stack-block (closure-ccenv/stack-block environment))
  625.     (closure-block (closure-ccenv/closure-block environment))
  626.     (closure (closure-ccenv/closure environment)))
  627.     (let ((parent (dbg-block/parent stack-block))
  628.       (use-simulation
  629.        (lambda ()
  630.          (if (compiled-closure? closure)
  631.          (let ((environment
  632.             (compiled-code-block/environment
  633.              (compiled-entry/block closure))))
  634.            (if (ic-environment? environment)
  635.                environment
  636.                system-global-environment))
  637.          system-global-environment))))
  638.       (if parent
  639.       (case (dbg-block/type parent)
  640.         ((STACK)
  641.          (make-closure-ccenv parent closure-block closure))
  642.         ((CLOSURE)
  643.          (let ((parent (dbg-block/original-parent stack-block)))
  644.            (if parent
  645.            (make-closure-ccenv parent closure-block closure)
  646.            (use-simulation))))
  647.         ((IC)
  648.          (guarantee-interpreter-environment
  649.           (let ((index (dbg-block/ic-parent-index closure-block)))
  650.         (if index
  651.             (closure/get-value closure closure-block index)
  652.             (use-simulation)))))
  653.         (else
  654.          (error "Illegal parent block" parent)))
  655.       (use-simulation)))))
  656.  
  657. (define (closure-ccenv/lambda environment)
  658.   (dbg-block/source-code (closure-ccenv/stack-block environment)))
  659.  
  660. (define (lookup-dbg-variable block name get-value not-found)
  661.   (let loop ((name name))
  662.     (let ((index (dbg-block/find-name block name)))
  663.       (if index
  664.       (let ((variable (vector-ref (dbg-block/layout-vector block) index)))
  665.         (case (dbg-variable/type variable)
  666.           ((NORMAL)
  667.            (get-value index))
  668.           ((CELL)
  669.            (let ((value (get-value index)))
  670.          (if (not (cell? value))
  671.              (error "Value of variable should be in cell"
  672.                 variable value))
  673.          (cell-contents value)))
  674.           ((INTEGRATED)
  675.            (dbg-variable/value variable))
  676.           ((INDIRECTED)
  677.            (loop (dbg-variable/name (dbg-variable/value variable))))
  678.           (else
  679.            (error "Unknown variable type" variable))))
  680.       (not-found name)))))
  681.  
  682. (define (assignable-dbg-variable? block name not-found)
  683.   (let ((index (dbg-block/find-name block name)))
  684.     (if index
  685.     (eq? 'CELL
  686.          (dbg-variable/type
  687.           (vector-ref (dbg-block/layout-vector block)
  688.               index)))
  689.     (not-found name))))
  690.  
  691. (define (assign-dbg-variable! block name get-value value not-found)
  692.   (let ((index (dbg-block/find-name block name)))
  693.     (if index
  694.     (let ((variable (vector-ref (dbg-block/layout-vector block) index)))
  695.       (case (dbg-variable/type variable)
  696.         ((CELL)
  697.          (let ((cell (get-value index)))
  698.            (if (not (cell? cell))
  699.            (error "Value of variable should be in cell" name cell))
  700.            (set-cell-contents! cell value)
  701.            unspecific))
  702.         ((NORMAL INTEGRATED INDIRECTED)
  703.          (error "Variable cannot be side-effected" variable))
  704.         (else
  705.          (error "Unknown variable type" variable))))
  706.     (not-found name))))
  707.  
  708. (define (dbg-block/name block)
  709.   (let ((procedure (dbg-block/procedure block)))
  710.     (and procedure
  711.      (dbg-procedure/name procedure))))
  712.  
  713. (define (dbg-block/source-code block)
  714.   (let ((procedure (dbg-block/procedure block)))
  715.     (and procedure
  716.      (dbg-procedure/source-code procedure))))