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 / prgcop.scm < prev    next >
Text File  |  1999-01-02  |  10KB  |  313 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: prgcop.scm,v 1.6 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 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. ;;;; Program copier
  23. ;;; package: (runtime program-copier)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define-primitives
  28.   (object-new-type primitive-object-new-type 2))
  29.  
  30. (define (initialize-package!)
  31.   (set! copier/scode-walker
  32.     (make-scode-walker
  33.      copy-constant
  34.      `((ACCESS ,(%copy-pair (ucode-type ACCESS)))
  35.        (ASSIGNMENT ,(%copy-triple (ucode-type ASSIGNMENT)))
  36.        (COMBINATION ,copy-COMBINATION-object)
  37.        (COMMENT ,copy-COMMENT-object)
  38.        (CONDITIONAL ,(%copy-triple (ucode-type CONDITIONAL)))
  39.        (DEFINITION ,(%copy-pair (ucode-type DEFINITION)))
  40.        (DELAY ,(%copy-pair (ucode-type DELAY)))
  41.        (DISJUNCTION ,(%copy-pair (ucode-type DISJUNCTION)))
  42.        (IN-PACKAGE ,(%copy-pair (ucode-type IN-PACKAGE)))
  43.        (LAMBDA ,copy-LAMBDA-object)
  44.        (QUOTATION ,(%copy-pair (ucode-type QUOTATION)))
  45.        (SEQUENCE ,copy-SEQUENCE-object)
  46.        (THE-ENVIRONMENT ,copy-constant)
  47.        (VARIABLE ,copy-VARIABLE-object))))
  48.   unspecific)
  49.  
  50. ;;;; Top level
  51.  
  52. (define *default/copy-constants?* false)
  53.  
  54. (define *copy-constants?*)
  55.  
  56. (define *object-copies*)
  57. (define copier/scode-walker)
  58.  
  59. (define-integrable (make-object-association-table)
  60.   (list '*OBJECT-COPIES*))
  61.  
  62. (define-integrable (object-association object)
  63.   (assq object (cdr *object-copies*)))
  64.  
  65. (define (add-association! object other)
  66.   (let* ((table *object-copies*)
  67.      (place (assq object (cdr table))))
  68.     (cond ((not place)
  69.        (set-cdr! table (cons (cons object other) (cdr table))))
  70.       ((not (eq? (cdr place) other))
  71.        (error "add-association!: Multiple associations" object other)))
  72.     unspecific))
  73.  
  74. (define (copy-program exp #!optional copy-constants?)
  75.   ;; There should be an option to unlink a linked program.
  76.   ;; This is currently difficult because procedure caches
  77.   ;; do not have enough information to determine what the
  78.   ;; variable name was.  The original block can be used for
  79.   ;; this, but it may as well be copied then.
  80.   (fluid-let ((*copy-constants?*
  81.            (if (default-object? copy-constants?)
  82.            *default/copy-constants?*
  83.            copy-constants?))
  84.           (*object-copies*
  85.            (make-object-association-table)))
  86.     (copy-object exp)))
  87.  
  88. (define (copy-object obj)
  89.   (let ((association (object-association obj)))
  90.     (if association
  91.     (cdr association)
  92.     ((scode-walk copier/scode-walker obj) obj))))
  93.  
  94. (define (copy-constant obj)
  95.   (cond ((compiled-code-address? obj)
  96.      (%copy-compiled-code-address obj))
  97.     ((compiled-code-block? obj)
  98.      (%copy-compiled-code-block obj))
  99.     ((not *copy-constants?*)
  100.      obj)
  101.     (else
  102.      (%copy-constant obj))))
  103.  
  104. (define (%copy-constant obj)
  105.   (cond ((or (number? obj)
  106.          (symbol? obj)
  107.          (boolean? obj)
  108.          (null? obj)
  109.          (char? obj)
  110.          (object-type? (ucode-type REFERENCE-TRAP) obj))
  111.      obj)
  112.     ((pair? obj)
  113.      (%%copy-pair (ucode-type PAIR) obj))
  114.     ((vector? obj)
  115.      (%%copy-vector (ucode-type VECTOR) obj))
  116.     ((string? obj)
  117.      (let ((copy (string-copy obj)))
  118.        (add-association! obj copy)
  119.        copy))
  120.     ((bit-string? obj)
  121.      (let ((copy (bit-string-copy obj)))
  122.        (add-association! obj copy)
  123.        copy))
  124.     (else
  125.      ;; This includes procedures and environments.
  126.      (error "copy-constant: Can't handle" obj))))
  127.  
  128. (define (%copy-compiled-code-address obj)
  129.   (let ((new-block (copy-compiled-code-block
  130.             (compiled-code-address->block obj))))
  131.     (atomically
  132.      (lambda ()
  133.        (object-new-type
  134.     (object-type obj)
  135.     (+ (compiled-code-address->offset obj)
  136.        (object-datum new-block)))))))
  137.  
  138. (define (copy-compiled-code-block obj)
  139.   (let ((association (object-association obj)))
  140.     (if association
  141.     (cdr association)
  142.     (%copy-compiled-code-block obj))))
  143.  
  144. (define (%copy-compiled-code-block obj)
  145.   (let* ((new (vector-copy (object-new-type (ucode-type VECTOR) obj)))
  146.      (typed (object-new-type (ucode-type compiled-code-block) new))
  147.      (len (vector-length new)))
  148.     ((ucode-primitive declare-compiled-code-block 1) typed)
  149.     (add-association! obj typed)
  150.     (do ((i (fix:+ (object-datum (vector-ref new 0)) 1) (fix:+ 1 i)))    
  151.     ((not (fix:< i len)))
  152.       (vector-set! new i (copy-object (vector-ref new i))))
  153.     typed))
  154.  
  155. (define-integrable (atomically thunk)
  156.   (with-absolutely-no-interrupts thunk))  
  157.  
  158. (define ((%copy-pair type) obj)
  159.   (%%copy-pair type obj))
  160.  
  161. (define (%%copy-pair type obj)
  162.   (let ((the-car (system-pair-car obj))
  163.     (the-cdr (system-pair-cdr obj)))
  164.     (let* ((new (cons the-car the-cdr))
  165.        (typed (object-new-type type new)))
  166.       (add-association! obj typed)
  167.       (set-car! new (copy-object the-car))
  168.       (set-cdr! new (copy-object the-cdr))
  169.       typed)))
  170.  
  171. (define ((%copy-triple type) obj)
  172.   (%%copy-triple type obj))
  173.  
  174. (define (%%copy-triple type obj)
  175.   (let ((the-cxr0 (system-hunk3-cxr0 obj))
  176.     (the-cxr1 (system-hunk3-cxr1 obj))
  177.     (the-cxr2 (system-hunk3-cxr2 obj)))
  178.     (let* ((new (hunk3-cons the-cxr0 the-cxr1 the-cxr2))
  179.        (typed (object-new-type type new)))
  180.       (add-association! obj typed)
  181.       (system-hunk3-set-cxr0! new (copy-object the-cxr0))
  182.       (system-hunk3-set-cxr1! new (copy-object the-cxr1))
  183.       (system-hunk3-set-cxr2! new (copy-object the-cxr2))
  184.       typed)))
  185.  
  186. #|
  187. (define ((%copy-quad type) obj)
  188.   (%%copy-quad type obj))
  189.  
  190. (define (%%copy-quad type obj)
  191.   (let ((the-cxr0 (system-hunk4-cxr0 obj))
  192.     (the-cxr1 (system-hunk4-cxr1 obj))
  193.     (the-cxr2 (system-hunk4-cxr2 obj))
  194.     (the-cxr3 (system-hunk4-cxr3 obj)))
  195.     (let* ((new (hunk4-cons the-cxr0 the-cxr1 the-cxr2 the-cxr3))
  196.        (typed (object-new-type type new)))
  197.       (add-association! obj typed)
  198.       (system-hunk4-set-cxr0! new (copy-object the-cxr0))
  199.       (system-hunk4-set-cxr1! new (copy-object the-cxr1))
  200.       (system-hunk4-set-cxr2! new (copy-object the-cxr2))
  201.       (system-hunk4-set-cxr3! new (copy-object the-cxr3))
  202.       typed)))
  203. |#
  204.  
  205. (define (copy-vector vec)
  206.   (let ((association (object-association vec)))
  207.     (if association
  208.     (cdr association)
  209.     (%%copy-vector (ucode-type VECTOR) vec))))
  210.  
  211. (define ((%copy-vector type) obj)
  212.   (%%copy-vector type obj))
  213.  
  214. (define (%%copy-vector type obj)
  215.   (let* ((new (vector-copy
  216.            (object-new-type (ucode-type VECTOR) obj)))
  217.      (typed (object-new-type type new))
  218.      (len (vector-length new)))
  219.     (add-association! obj typed)
  220.     (do ((i 0 (fix:+ i 1)))
  221.     ((not (fix:< i len)))
  222.       (vector-set! new i (copy-object (vector-ref new i))))
  223.     typed))
  224.  
  225. (define (copy-SEQUENCE-object obj)
  226.   (cond ((object-type? (ucode-type SEQUENCE-2) obj)
  227.      (%%copy-pair (ucode-type SEQUENCE-2) obj))
  228.     ((object-type? (ucode-type SEQUENCE-3) obj)
  229.      (%%copy-triple (ucode-type SEQUENCE-3) obj))
  230.     (else
  231.      (error "copy-SEQUENCE-object: Unknown type" obj))))
  232.  
  233. (define (copy-COMBINATION-object obj)
  234.   (cond ((object-type? (ucode-type combination) obj)
  235.      (%%copy-vector (ucode-type combination) obj))
  236.     ((object-type? (ucode-type combination-1) obj)
  237.      (%%copy-pair (ucode-type combination-1) obj))
  238.     ((object-type? (ucode-type combination-2) obj)
  239.      (%%copy-triple (ucode-type combination-2) obj))
  240.     ((object-type? (ucode-type primitive-combination-0) obj)
  241.      obj)                    ; Non-pointer
  242.     ((object-type? (ucode-type primitive-combination-1) obj)
  243.      (%%copy-pair (ucode-type primitive-combination-1) obj))
  244.     ((object-type? (ucode-type primitive-combination-2) obj)
  245.      (%%copy-triple (ucode-type primitive-combination-2) obj))
  246.     ((object-type? (ucode-type primitive-combination-3) obj)
  247.      (%%copy-vector (ucode-type primitive-combination-3) obj))
  248.     (else
  249.      (error "copy-COMBINATION-object: Unknown type" obj))))
  250.  
  251. (define (copy-LAMBDA-object obj)
  252.   (cond ((object-type? (ucode-type lambda) obj)
  253.      (%%copy-pair (ucode-type lambda) obj))
  254.     ((object-type? (ucode-type extended-lambda) obj)
  255.      (%%copy-triple (ucode-type extended-lambda) obj))
  256.     ((object-type? (ucode-type lexpr) obj)
  257.      (%%copy-pair (ucode-type lexpr) obj))
  258.     (else
  259.      (error "COPY-LAMBDA-object: Unknown type" obj))))
  260.  
  261. (define (copy-VARIABLE-object obj)
  262.   (let ((var (make-variable (variable-name obj))))
  263.     (add-association! obj var)
  264.     var))    
  265.  
  266. (define (copy-COMMENT-object obj)
  267.   (let ((the-text (comment-text obj)))
  268.     (if (not (dbg-info-vector? the-text))
  269.     (%%copy-pair (ucode-type COMMENT) obj)
  270.     (let ((the-car (system-pair-car obj))
  271.           (the-cdr (system-pair-cdr obj)))
  272.       (let* ((new (cons the-car the-cdr))
  273.          (typed (object-new-type (ucode-type COMMENT) new)))
  274.         (add-association! obj typed)
  275.         (let ((text-copy (copy-dbg-info-vector the-text)))
  276.           (set-car! new (if (eq? the-car the-text)
  277.                 text-copy
  278.                 (copy-object the-car)))
  279.           (set-cdr! new (if (eq? the-cdr the-text)
  280.                 text-copy
  281.                 (copy-object the-cdr)))
  282.           typed))))))
  283.  
  284. (define (copy-dbg-info-vector obj)
  285.   (let ((association (object-association obj)))
  286.     (cond (association
  287.        (cdr association))
  288.       ((vector? obj)
  289.        (%%copy-vector (ucode-type VECTOR) obj))
  290.       ((pair? obj)
  291.        ;; Guarantee that top-level vectors are copied.
  292.        (for-each (lambda (element)
  293.                (if (vector? element)
  294.                (copy-vector element)))
  295.              obj)
  296.        (copy-list obj))
  297.       (else
  298.        (error "copy-dbg-info-vector: Unknown type" obj)))))
  299.  
  300. (define (copy-list obj)
  301.   (let ((association (object-association obj)))
  302.     (cond (association
  303.        (cdr association))
  304.       ((not (pair? obj))
  305.        ((scode-walk copier/scode-walker obj) obj))
  306.       (else
  307.        (let ((the-car (car obj))
  308.          (the-cdr (cdr obj)))
  309.          (let ((new (cons the-car the-cdr)))
  310.            (add-association! obj new)
  311.            (set-car! new (copy-object the-car))
  312.            (set-cdr! new (copy-list the-cdr))
  313.            new))))))