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 / framex.scm < prev    next >
Text File  |  1999-01-02  |  14KB  |  387 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: framex.scm,v 14.19 1999/01/02 06:06:43 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. ;;;; Debugging Info
  23. ;;; package: (runtime debugging-info)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (stack-frame/debugging-info frame)
  28.   (let ((method
  29.      (stack-frame-type/debugging-info-method (stack-frame/type frame))))
  30.     (if (not method)
  31.     ;; (error "STACK-FRAME/DEBUGGING-INFO: missing method" frame)
  32.     (stack-frame/debugging-info/default frame)
  33.     (method frame))))
  34.  
  35. (define (stack-frame/debugging-info/default frame)
  36.   (values (make-debugging-info/noise
  37.        (lambda (long?)
  38.          (with-output-to-string
  39.            (lambda ()
  40.          (display "Unknown (methodless) ")
  41.          (if long?
  42.              (pp frame)
  43.              (write frame))))))
  44.       undefined-environment
  45.       undefined-expression))
  46.  
  47. (define (debugging-info/undefined-expression? expression)
  48.   (or (eq? expression undefined-expression)
  49.       (debugging-info/noise? expression)))
  50.  
  51. (define (debugging-info/noise? expression)
  52.   (and (pair? expression)
  53.        (eq? (car expression) undefined-expression)))
  54.  
  55. (define-integrable (debugging-info/noise expression)
  56.   (cdr expression))
  57.  
  58. (define-integrable (make-debugging-info/noise noise)
  59.   (cons undefined-expression noise))
  60.  
  61. (define-integrable (debugging-info/undefined-environment? environment)
  62.   (eq? environment undefined-environment))
  63.  
  64. (define-integrable (debugging-info/unknown-expression? expression)
  65.   (eq? expression unknown-expression))
  66.  
  67. (define-integrable (debugging-info/compiled-code? expression)
  68.   (eq? expression compiled-code))
  69.  
  70. (define (make-evaluated-object object)
  71.   (if (scode-constant? object)
  72.       object
  73.       (cons evaluated-object-tag object)))
  74.  
  75. (define (debugging-info/evaluated-object? expression)
  76.   (and (pair? expression)
  77.        (eq? (car expression) evaluated-object-tag)))
  78.  
  79. (define-integrable (debugging-info/evaluated-object-value expression)
  80.   (cdr expression))
  81.  
  82. (define (validate-subexpression frame subexpression)
  83.   (if (eq? (stack-frame/previous-type frame) stack-frame-type/pop-return-error)
  84.       undefined-expression
  85.       subexpression))
  86.  
  87. (define undefined-expression "undefined expression")
  88. (define undefined-environment "undefined environment")
  89. (define unknown-expression "unknown expression")
  90. (define compiled-code "compiled code")
  91. (define evaluated-object-tag "evaluated")
  92. (define stack-frame-type/pop-return-error)
  93.  
  94. (define (method/null frame)
  95.   frame
  96.   (values undefined-expression undefined-environment undefined-expression))
  97.  
  98. (define (method/environment-only frame)
  99.   (values undefined-expression (stack-frame/ref frame 2) undefined-expression))
  100.  
  101. (define ((method/standard select-subexpression) frame)
  102.   (let ((expression (stack-frame/ref frame 1)))
  103.     (values expression
  104.         (stack-frame/ref frame 2)
  105.         (validate-subexpression frame (select-subexpression expression)))))
  106.  
  107. (define ((method/expression-only select-subexpression) frame)
  108.   (let ((expression (stack-frame/ref frame 1)))
  109.     (values expression
  110.         undefined-environment
  111.         (validate-subexpression frame (select-subexpression expression)))))
  112.  
  113. (define (method/primitive-combination-3-first-operand frame)
  114.   (let ((expression (stack-frame/ref frame 1)))
  115.     (values expression
  116.         (stack-frame/ref frame 3)
  117.         (validate-subexpression frame (&vector-ref expression 2)))))
  118.  
  119. (define (method/combination-save-value frame)
  120.   (let ((expression (stack-frame/ref frame 1)))
  121.     (values expression
  122.         (stack-frame/ref frame 2)
  123.         (validate-subexpression
  124.          frame
  125.          (&vector-ref expression (stack-frame/ref frame 3))))))
  126.  
  127. (define (method/eval-error frame)
  128.   (values (stack-frame/ref frame 1)
  129.       (stack-frame/ref frame 2)
  130.       undefined-expression))
  131.  
  132. (define (method/force-snap-thunk frame)
  133.   (let ((promise (stack-frame/ref frame 1)))
  134.     (values (%make-combination
  135.          (ucode-primitive force 1)
  136.          (list (make-evaluated-object promise)))
  137.         undefined-environment
  138.         (cond ((promise-forced? promise) undefined-expression)
  139.           ((promise-non-expression? promise) unknown-expression)
  140.           (else
  141.            (validate-subexpression frame
  142.                        (promise-expression promise)))))))
  143.  
  144. (define ((method/application-frame index) frame)
  145.   (values (%make-combination
  146.        (make-evaluated-object (stack-frame/ref frame index))
  147.        (stack-frame-list frame (1+ index)))
  148.       undefined-environment
  149.       undefined-expression))
  150.  
  151. (define ((method/compiler-reference scode-maker) frame)
  152.   (values (scode-maker (stack-frame/ref frame 3))
  153.       (stack-frame/ref frame 2)
  154.       undefined-expression))
  155.  
  156. (define ((method/compiler-assignment scode-maker) frame)
  157.   (values (scode-maker (stack-frame/ref frame 3)
  158.                (make-evaluated-object (stack-frame/ref frame 4)))
  159.       (stack-frame/ref frame 2)
  160.       undefined-expression))
  161.  
  162. (define ((method/compiler-reference-trap scode-maker) frame)
  163.   (values (scode-maker (stack-frame/ref frame 2))
  164.       (stack-frame/ref frame 3)
  165.       undefined-expression))
  166.  
  167. (define ((method/compiler-assignment-trap scode-maker) frame)
  168.   (values (scode-maker (stack-frame/ref frame 2)
  169.                (make-evaluated-object (stack-frame/ref frame 4)))
  170.       (stack-frame/ref frame 3)
  171.       undefined-expression))
  172.  
  173. (define (method/compiler-lookup-apply-restart frame)
  174.   (values (%make-combination (stack-frame/ref frame 3)
  175.                  (stack-frame-list frame 5))
  176.       undefined-environment
  177.       undefined-expression))
  178.  
  179. (define (method/compiler-lookup-apply-trap-restart frame)
  180.   (values (%make-combination (make-variable (stack-frame/ref frame 2))
  181.                  (stack-frame-list frame 6))
  182.       (stack-frame/ref frame 3)
  183.       undefined-expression))
  184.  
  185. (define (method/compiler-error-restart frame)
  186.   (let ((primitive (stack-frame/ref frame 2)))
  187.     (if (primitive-procedure? primitive)
  188.     (values (%make-combination (make-variable 'apply)
  189.                    (list primitive
  190.                      unknown-expression))
  191.         undefined-environment
  192.         undefined-expression)
  193.     (stack-frame/debugging-info/default frame))))
  194.  
  195. (define (stack-frame-list frame start)
  196.   (let ((end (stack-frame/length frame)))
  197.     (let loop ((index start))
  198.       (if (< index end)
  199.       (cons (make-evaluated-object (stack-frame/ref frame index))
  200.         (loop (1+ index)))
  201.       '()))))
  202.  
  203. (define (method/hardware-trap frame)
  204.   (values (make-debugging-info/noise (hardware-trap-noise frame))
  205.       undefined-environment
  206.       undefined-expression))
  207.  
  208. (define ((hardware-trap-noise frame) long?)
  209.   (with-output-to-string
  210.     (lambda ()
  211.       (hardware-trap-frame/describe frame long?))))
  212.  
  213. (define (method/compiled-code frame)
  214.   (let ((get-environment
  215.      (lambda ()
  216.        (stack-frame/environment frame undefined-environment))))
  217.     (let ((object
  218.        (compiled-entry/dbg-object (stack-frame/return-address frame)))
  219.       (lose
  220.        (lambda ()
  221.          (values compiled-code (get-environment) undefined-expression))))
  222.       (cond ((not object)
  223.          (lose))
  224.         ((dbg-continuation? object)
  225.          (let ((source-code (dbg-continuation/source-code object)))
  226.            (if (and (vector? source-code)
  227.             (not (zero? (vector-length source-code))))
  228.            (let* ((expression (vector-ref source-code 1))
  229.               (win2
  230.                (lambda (environment subexp)
  231.                  (values expression environment subexp)))
  232.               (win
  233.                (lambda (select-subexp)
  234.                  (win2
  235.                   (get-environment)
  236.                   (validate-subexpression
  237.                    frame
  238.                    (select-subexp expression))))))
  239.              (case (vector-ref source-code 0)
  240.                ((SEQUENCE-2-SECOND)
  241.             (win &pair-car))
  242.                ((ASSIGNMENT-CONTINUE
  243.              DEFINITION-CONTINUE)
  244.             (win &pair-cdr))
  245.                ((SEQUENCE-3-SECOND
  246.              CONDITIONAL-DECIDE)
  247.             (win &triple-first))
  248.                ((SEQUENCE-3-THIRD)
  249.             (win &triple-second))
  250.                ((COMBINATION-OPERAND)
  251.             (values
  252.              expression
  253.              (get-environment)
  254.              (validate-subexpression
  255.               frame
  256.               (if (zero? (vector-ref source-code 2))
  257.                   (combination-operator expression)
  258.                   (list-ref (combination-operands expression)
  259.                     (-1+ (vector-ref source-code 2)))))))
  260.                ((COMBINATION-ELEMENT)
  261.             (win2 undefined-environment
  262.                   (vector-ref source-code 2)))
  263.                ((SEQUENCE-ELEMENT)
  264.             (win2 undefined-environment
  265.                   (vector-ref source-code 2)))
  266.                ((CONDITIONAL-PREDICATE)
  267.             (win2 undefined-environment
  268.                   (vector-ref source-code 2)))
  269.                (else
  270.             (lose))))
  271.            (lose))))
  272.         ((dbg-procedure? object)
  273.          (values (lambda-body (dbg-procedure/source-code object))
  274.              (and (dbg-procedure/block object)
  275.               (get-environment))
  276.              undefined-expression))
  277.         #|
  278.         ((dbg-expression? object)
  279.          ;; no expression!
  280.          (lose))
  281.         |#
  282.         (else
  283.          (lose))))))
  284.  
  285. (define (initialize-package!)
  286.   (set! stack-frame-type/pop-return-error
  287.     (microcode-return/name->type 'POP-RETURN-ERROR))
  288.   (record-method 'COMBINATION-APPLY method/null)
  289.   (record-method 'GC-CHECK method/null)
  290.   (record-method 'MOVE-TO-ADJACENT-POINT method/null)
  291.   (record-method 'REENTER-COMPILED-CODE method/null)
  292.   (record-method 'REPEAT-DISPATCH method/environment-only)
  293.   (let ((method (method/standard &pair-car)))
  294.     (record-method 'DISJUNCTION-DECIDE method)
  295.     (record-method 'SEQUENCE-2-SECOND method))
  296.   (let ((method (method/standard &pair-cdr)))
  297.     (record-method 'ASSIGNMENT-CONTINUE method)
  298.     (record-method 'COMBINATION-1-PROCEDURE method)
  299.     (record-method 'DEFINITION-CONTINUE method))
  300.   (let ((method (method/standard &triple-first)))
  301.     (record-method 'CONDITIONAL-DECIDE method)
  302.     (record-method 'SEQUENCE-3-SECOND method))
  303.   (let ((method (method/standard &triple-second)))
  304.     (record-method 'COMBINATION-2-PROCEDURE method)
  305.     (record-method 'SEQUENCE-3-THIRD method))
  306.   (let ((method (method/standard &triple-third)))
  307.     (record-method 'COMBINATION-2-FIRST-OPERAND method)
  308.     (record-method 'PRIMITIVE-COMBINATION-2-FIRST-OPERAND method))
  309.   (record-method 'PRIMITIVE-COMBINATION-3-SECOND-OPERAND
  310.          (method/standard &vector-fourth))
  311.   (let ((method (method/expression-only &pair-car)))
  312.     (record-method 'ACCESS-CONTINUE method)
  313.     (record-method 'IN-PACKAGE-CONTINUE method))
  314.   (record-method 'PRIMITIVE-COMBINATION-1-APPLY
  315.          (method/expression-only &pair-cdr))
  316.   (record-method 'PRIMITIVE-COMBINATION-2-APPLY
  317.          (method/expression-only &triple-second))
  318.   (record-method 'PRIMITIVE-COMBINATION-3-APPLY
  319.          (method/expression-only &vector-second))
  320.   (record-method 'COMBINATION-SAVE-VALUE method/combination-save-value)
  321.   (record-method 'PRIMITIVE-COMBINATION-3-FIRST-OPERAND
  322.          method/primitive-combination-3-first-operand)
  323.   (record-method 'EVAL-ERROR method/eval-error)
  324.   (record-method 'FORCE-SNAP-THUNK method/force-snap-thunk)
  325.   (let ((method (method/application-frame 3)))
  326.     (record-method 'INTERNAL-APPLY method)
  327.     (record-method 'INTERNAL-APPLY-VAL method))
  328.   (let ((method (method/compiler-reference identity-procedure)))
  329.     (record-method 'COMPILER-REFERENCE-RESTART method)
  330.     (record-method 'COMPILER-SAFE-REFERENCE-RESTART method))
  331.   (record-method 'COMPILER-ACCESS-RESTART
  332.          (method/compiler-reference make-variable))
  333.   (record-method 'COMPILER-UNASSIGNED?-RESTART
  334.          (method/compiler-reference make-unassigned?))
  335.   (record-method 'COMPILER-UNBOUND?-RESTART
  336.          (method/compiler-reference
  337.           (lambda (name)
  338.             (%make-combination (ucode-primitive lexical-unbound?)
  339.                        (list (make-the-environment) name)))))
  340.   (record-method 'COMPILER-ASSIGNMENT-RESTART
  341.          (method/compiler-assignment make-assignment-from-variable))
  342.   (record-method 'COMPILER-DEFINITION-RESTART
  343.          (method/compiler-assignment make-definition))
  344.   (let ((method (method/compiler-reference-trap make-variable)))
  345.     (record-method 'COMPILER-REFERENCE-TRAP-RESTART method)
  346.     (record-method 'COMPILER-SAFE-REFERENCE-TRAP-RESTART method))
  347.   (record-method 'COMPILER-UNASSIGNED?-TRAP-RESTART
  348.          (method/compiler-reference-trap make-unassigned?))
  349.   (record-method 'COMPILER-ASSIGNMENT-TRAP-RESTART
  350.          (method/compiler-assignment-trap make-assignment))
  351.   (record-method 'COMPILER-LOOKUP-APPLY-RESTART
  352.          method/compiler-lookup-apply-restart)
  353.   (record-method 'COMPILER-LOOKUP-APPLY-TRAP-RESTART
  354.          method/compiler-lookup-apply-trap-restart)
  355.   (record-method 'COMPILER-OPERATOR-LOOKUP-TRAP-RESTART
  356.          method/compiler-lookup-apply-trap-restart)
  357.   (record-method 'COMPILER-ERROR-RESTART
  358.          method/compiler-error-restart)
  359.   (record-method 'HARDWARE-TRAP method/hardware-trap)
  360.   (set-stack-frame-type/debugging-info-method!
  361.    stack-frame-type/compiled-return-address
  362.    method/compiled-code)
  363.   (set-stack-frame-type/debugging-info-method!
  364.    stack-frame-type/interrupt-compiled-procedure
  365.    method/compiled-code)
  366.   (set-stack-frame-type/debugging-info-method!
  367.    stack-frame-type/interrupt-compiled-expression
  368.    method/compiled-code))
  369.  
  370. (define (&vector-second vector)
  371.   (&vector-ref vector 1))
  372.  
  373. (define (&vector-fourth vector)
  374.   (&vector-ref vector 3))
  375.  
  376. (define (record-method name method)
  377.   (set-stack-frame-type/debugging-info-method!
  378.    (microcode-return/name->type name)
  379.    method))
  380.  
  381. (define-integrable (stack-frame-type/debugging-info-method type)
  382.   (1d-table/get (stack-frame-type/properties type) method-tag false))
  383.  
  384. (define-integrable (set-stack-frame-type/debugging-info-method! type method)
  385.   (1d-table/put! (stack-frame-type/properties type) method-tag method))
  386.  
  387. (define method-tag "stack-frame-type/debugging-info-method")