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 / compiler / back / lapgn3.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  4.3 KB  |  149 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: lapgn3.scm,v 4.12 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1987-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. ;;;; LAP Generator
  23. ;;; package: (compiler lap-syntaxer)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Constants
  28.  
  29. (define *next-constant*)
  30. (define *interned-constants*)
  31. (define *interned-variables*)
  32. (define *interned-assignments*)
  33. (define *interned-uuo-links*)
  34. (define *interned-global-links*)
  35. (define *interned-static-variables*)
  36.  
  37. (define (allocate-named-label prefix)
  38.   (let ((label
  39.      (string->uninterned-symbol
  40.       (string-append prefix (number->string *next-constant*)))))
  41.     (set! *next-constant* (1+ *next-constant*))
  42.     label))
  43.  
  44. (define (allocate-constant-label)
  45.   (allocate-named-label "CONSTANT-"))
  46.  
  47. (define (warning-assoc obj pairs)
  48.   (define (local-eqv? obj1 obj2)
  49.     (or (eqv? obj1 obj2)
  50.     (and (string? obj1)
  51.          (string? obj2)
  52.          (zero? (string-length obj1))
  53.          (zero? (string-length obj2)))))
  54.  
  55.   (let ((pair (assoc obj pairs)))
  56.     (if (and compiler:coalescing-constant-warnings?
  57.          (pair? pair)
  58.          (not (local-eqv? obj (car pair))))
  59.     (warn "Coalescing two copies of constant object" obj))
  60.     pair))
  61.  
  62. (define-integrable (object->label find read write allocate-label)
  63.   (lambda (object)
  64.     (let ((entry (find object (read))))
  65.       (if entry
  66.       (cdr entry)
  67.       (let ((label (allocate-label object)))
  68.         (write (cons (cons object label)
  69.              (read)))
  70.         label)))))
  71.  
  72. (let-syntax ((->label
  73.           (macro (find var #!optional suffix)
  74.         `(object->label ,find
  75.                 (lambda () ,var)
  76.                 (lambda (new)
  77.                   (declare (integrate new))
  78.                   (set! ,var new))
  79.                 ,(if (default-object? suffix)
  80.                      `(lambda (object)
  81.                     object ; ignore
  82.                     (allocate-named-label "OBJECT-"))
  83.                      `(lambda (object)
  84.                     (allocate-named-label
  85.                      (string-append (symbol->string object)
  86.                             ,suffix))))))))
  87. (define constant->label
  88.   (->label warning-assoc *interned-constants*))
  89.  
  90. (define free-reference-label
  91.   (->label assq *interned-variables* "-READ-CELL-"))
  92.  
  93. (define free-assignment-label
  94.   (->label assq *interned-assignments* "-WRITE-CELL-"))
  95.  
  96. (define free-static-label
  97.   (->label assq *interned-static-variables* "-HOME-"))
  98.  
  99. ;; End of let-syntax
  100. )
  101.  
  102. ;; These are different because different uuo-links are used for different
  103. ;; numbers of arguments.
  104.  
  105. (define (allocate-uuo-link-label prefix name frame-size)
  106.   (allocate-named-label
  107.    (string-append prefix
  108.           (symbol->string name)
  109.           "-"
  110.           (number->string (-1+ frame-size))
  111.           "-ARGS-")))
  112.  
  113. (define-integrable (uuo-link-label read write! prefix)
  114.   (lambda (name frame-size)
  115.     (let* ((all (read))
  116.        (entry (assq name all)))
  117.       (if entry
  118.       (let ((place (assv frame-size (cdr entry))))
  119.         (if place
  120.         (cdr place)
  121.         (let ((label (allocate-uuo-link-label prefix name frame-size)))
  122.           (set-cdr! entry
  123.                 (cons (cons frame-size label)
  124.                   (cdr entry)))
  125.           label)))
  126.       (let ((label (allocate-uuo-link-label prefix name frame-size)))
  127.         (write! (cons (list name (cons frame-size label))
  128.               all))
  129.         label)))))
  130.  
  131. (define free-uuo-link-label
  132.   (uuo-link-label (lambda () *interned-uuo-links*)
  133.           (lambda (new)
  134.             (set! *interned-uuo-links* new))
  135.           ""))
  136.  
  137. (define global-uuo-link-label
  138.   (uuo-link-label (lambda () *interned-global-links*)
  139.           (lambda (new)
  140.             (set! *interned-global-links* new))
  141.           "GLOBAL-"))
  142.  
  143. (define (prepare-constants-block)
  144.   (generate/constants-block *interned-constants*
  145.                 *interned-variables*
  146.                 *interned-assignments*
  147.                 *interned-uuo-links*
  148.                 *interned-global-links*
  149.                 *interned-static-variables*))