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 / infstr.scm < prev    next >
Text File  |  2001-03-21  |  9KB  |  242 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: infstr.scm,v 1.10 2001/03/21 19:15:10 cph Exp $
  4.  
  5. Copyright (c) 1988-2001 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., 59 Temple Place - Suite 330, Boston, MA
  20. 02111-1307, USA.
  21. |#
  22.  
  23. ;;;; Compiled Code Information: Structures
  24. ;;; package: (runtime compiler-info)
  25.  
  26. (declare (usual-integrations))
  27.  
  28. (define-integrable (make-dbg-info-vector info-vector)
  29.   (cons dbg-info-vector-tag info-vector))
  30.  
  31. (define (dbg-info-vector? object)
  32.   (and (pair? object) (eq? (car object) dbg-info-vector-tag)))
  33.  
  34. (define-integrable (dbg-info-vector/items info-vector)
  35.   (cdr info-vector))
  36.  
  37. (define-integrable dbg-info-vector-tag
  38.   ((ucode-primitive string->symbol)
  39.    "#[(runtime compiler-info)dbg-info-vector-tag]"))
  40.  
  41. (define-structure (dbg-info
  42.            (type vector)
  43.            (named
  44.             ((ucode-primitive string->symbol)
  45.              "#[(runtime compiler-info)dbg-info]"))
  46.            (conc-name dbg-info/))
  47.   (expression false read-only true)    ;dbg-expression
  48.   (procedures false read-only true)    ;vector of dbg-procedure
  49.   (continuations false read-only true)    ;vector of dbg-continuation
  50.   (labels/desc false read-only false)    ;vector of dbg-label, sorted by offset
  51.   )
  52.  
  53. (define (dbg-info/labels dbg-info)
  54.   (let ((labels/desc (dbg-info/labels/desc dbg-info)))
  55.     (if (vector? labels/desc)
  56.     labels/desc
  57.     (let ((labels (read-labels labels/desc)))
  58.       (and labels
  59.            (begin
  60.          (set-dbg-info/labels/desc! dbg-info labels)
  61.          labels))))))
  62.  
  63. (define-structure (dbg-expression
  64.            (type vector)
  65.            (named
  66.             ((ucode-primitive string->symbol)
  67.              "#[(runtime compiler-info)dbg-expression]"))
  68.            (conc-name dbg-expression/))
  69.   (block false read-only true)        ;dbg-block
  70.   (label false)                ;dbg-label
  71.   )
  72.  
  73. (define-integrable (dbg-expression/label-offset expression)
  74.   (dbg-label/offset (dbg-expression/label expression)))
  75.  
  76. (define-structure (dbg-procedure
  77.            (type vector)
  78.            (named
  79.             ((ucode-primitive string->symbol)
  80.              "#[(runtime compiler-info)dbg-procedure]"))
  81.            (constructor
  82.             make-dbg-procedure
  83.             (block label type name required optional rest auxiliary
  84.                source-code))
  85.            (conc-name dbg-procedure/))
  86.   (block false read-only true)        ;dbg-block
  87.   (label false)                ;dbg-label
  88.   (type false read-only true)
  89.   (name false read-only true)        ;procedure's name
  90.   (required false read-only true)    ;names of required arguments
  91.   (optional false read-only true)    ;names of optional arguments
  92.   (rest false read-only true)        ;name of rest argument, or #F
  93.   (auxiliary false read-only true)    ;names of internal definitions
  94.   (external-label false)        ;for closure, external entry
  95.   (source-code false read-only true)    ;SCode
  96.   )
  97.  
  98. (define (dbg-procedure/label-offset procedure)
  99.   (dbg-label/offset
  100.    (or (dbg-procedure/external-label procedure)
  101.        (dbg-procedure/label procedure))))
  102.  
  103. (define-integrable (dbg-procedure<? x y)
  104.   (< (dbg-procedure/label-offset x) (dbg-procedure/label-offset y)))
  105.  
  106. (define-structure (dbg-continuation
  107.            (type vector)
  108.            (named
  109.             ((ucode-primitive string->symbol)
  110.              "#[(runtime compiler-info)dbg-continuation]"))
  111.            (conc-name dbg-continuation/))
  112.   (block false read-only true)        ;dbg-block
  113.   (label false)                ;dbg-label
  114.   (type false read-only true)
  115.   (offset false read-only true)        ;difference between sp and block
  116.   (source-code false read-only true)
  117.   )
  118.  
  119. (define-integrable (dbg-continuation/label-offset continuation)
  120.   (dbg-label/offset (dbg-continuation/label continuation)))
  121.  
  122. (define-integrable (dbg-continuation<? x y)
  123.   (< (dbg-continuation/label-offset x) (dbg-continuation/label-offset y)))
  124.  
  125. (define-structure (dbg-block
  126.            (type vector)
  127.            (named
  128.             ((ucode-primitive string->symbol)
  129.              "#[(runtime compiler-info)dbg-block]"))
  130.            (constructor
  131.             make-dbg-block
  132.             (type parent original-parent layout stack-link))
  133.            (conc-name dbg-block/))
  134.   (type false read-only true)        ;continuation, stack, closure, ic
  135.   (parent false read-only true)        ;parent block, or #F
  136.   (original-parent false read-only true) ;for closures, closing block
  137.   (layout false read-only true)        ;vector of names, except #F for ic
  138.   (stack-link false read-only true)    ;next block on stack, or #F
  139.   (procedure false)            ;procedure which this is block of
  140.   )
  141.  
  142. (define-structure (dbg-variable
  143.            (type vector)
  144.            (named
  145.             ((ucode-primitive string->symbol)
  146.              "#[(runtime compiler-info)dbg-variable]"))
  147.            (conc-name dbg-variable/))
  148.   (name false read-only true)        ;symbol
  149.   (type false read-only true)        ;normal, cell, integrated
  150.   value                    ;for integrated, the value
  151.   )
  152.  
  153. (let-syntax
  154.     ((dbg-block-name
  155.       (macro (name)
  156.     (let ((symbol (symbol-append 'DBG-BLOCK-NAME/ name)))
  157.       `(DEFINE-INTEGRABLE ,symbol
  158.          ',((ucode-primitive string->symbol)
  159.         (string-append "#[(runtime compiler-info)"
  160.                    (string-downcase (symbol-name symbol))
  161.                    "]")))))))
  162.   ;; Various names used in `layout' to identify things that wouldn't
  163.   ;; otherwise have names.
  164.   (dbg-block-name dynamic-link)
  165.   (dbg-block-name ic-parent)
  166.   (dbg-block-name normal-closure)
  167.   (dbg-block-name return-address)
  168.   (dbg-block-name static-link))
  169.  
  170. (define (dbg-label/name label)
  171.   (cond ((dbg-label-2? label) (dbg-label-2/name label))
  172.     ((dbg-label-1? label) (dbg-label-1/name label))
  173.     (else
  174.      (error:wrong-type-argument label "debugging label" 'DBG-LABEL/NAME))))
  175.  
  176. (define (set-dbg-label/name! label name)
  177.   (cond ((dbg-label-1? label) (set-dbg-label-1/name! label name))
  178.     (else
  179.      (error:wrong-type-argument label "debugging label"
  180.                     'SET-DBG-LABEL/NAME!))))
  181.  
  182. (define (dbg-label/offset label)
  183.   (cond ((dbg-label-2? label) (dbg-label-2/offset label))
  184.     ((dbg-label-1? label) (dbg-label-1/offset label))
  185.     (else
  186.      (error:wrong-type-argument label "debugging label"
  187.                     'DBG-LABEL/OFFSET))))
  188.  
  189. (define (dbg-label/external? label)
  190.   (cond ((dbg-label-2? label) (dbg-label-2/external? label))
  191.     ((dbg-label-1? label) (dbg-label-1/external? label))
  192.     (else
  193.      (error:wrong-type-argument label "debugging label"
  194.                     'DBG-LABEL/EXTERNAL?))))
  195.  
  196. (define (set-dbg-label/external?! label external?)
  197.   (cond ((dbg-label-2? label) (set-dbg-label-2/external?! label external?))
  198.     ((dbg-label-1? label) (set-dbg-label-1/external?! label external?))
  199.     (else
  200.      (error:wrong-type-argument label "debugging label"
  201.                     'SET-DBG-LABEL/EXTERNAL?!))))
  202.  
  203. (define (dbg-label/names label)
  204.   (cond ((dbg-label-2? label) (dbg-label-2/names label))
  205.     ((dbg-label-1? label) (dbg-label-1/names label))
  206.     (else
  207.      (error:wrong-type-argument label "debugging label"
  208.                     'DBG-LABEL/NAMES))))
  209.  
  210. (define (set-dbg-label/names! label names)
  211.   (cond ((dbg-label-1? label) (set-dbg-label-1/names! label names))
  212.     (else
  213.      (error:wrong-type-argument label "debugging label"
  214.                     'SET-DBG-LABEL/NAMES!))))
  215.  
  216. (define-structure (dbg-label-1
  217.            (type vector)
  218.            (named
  219.             ((ucode-primitive string->symbol)
  220.              "#[(runtime compiler-info)dbg-label]"))
  221.            (constructor make-dbg-label (name offset))
  222.            (conc-name dbg-label-1/))
  223.   (name false)                ;a string, primary name
  224.   (offset false read-only true)        ;mach. dependent offset into code block
  225.   (external? false)            ;if true, can have pointer to this
  226.   (names (list name))            ;names of all labels at this offset
  227.   )
  228.  
  229. (define-integrable make-dbg-label-2 cons)
  230. (define-integrable dbg-label-2? pair?)
  231. (define-integrable dbg-label-2/name car)
  232. (define-integrable (dbg-label-2/offset label) (abs (cdr label)))
  233. (define-integrable (dbg-label-2/external? label) (negative? (cdr label)))
  234. (define-integrable (dbg-label-2/names label) (list (car label)))
  235.  
  236. (define (set-dbg-label-2/external?! label external?)
  237.   (let ((offset (cdr label)))
  238.     (if (if external?
  239.         (not (negative? offset))
  240.         (negative? offset))
  241.     (set-cdr! label (- offset))))
  242.   unspecific)