home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / front_end / shape.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  11.3 KB  |  286 lines
  1. (herald shape)
  2.                             
  3. ;;;============================================================================
  4. ;;;                             SHAPES
  5. ;;;============================================================================
  6.  
  7. ;;;   A shape contains all the variables lexically bound at a particular
  8. ;;; moment.  Variables are added to a shape using the procedure BIND-VARIABLES
  9. ;;; and removed using UNBIND-VARIABLES.
  10. ;;;   The shape also keeps track of the locale variable usage.
  11.  
  12. (define-structure-type shape
  13.   table        ; table of stacks of lexically bound variables, indexed by name
  14.   free         ; table of free variables
  15.   env          ; the superior definition-env to the module being compiled
  16.   new-env      ; a table of names => variables
  17.   borrowed     ; variables copied from ENV
  18.   system       ; variables copied from the system
  19.   introduced   ; variables referenced by integrated procedures
  20.   primops      ; primops defined in this module
  21.   )
  22.  
  23. (define (create-shape env)
  24.   (let ((new (make-shape)))
  25.     (set (shape-table        new) (make-table 'shape-table))
  26.     (set (shape-free         new) (make-table 'shape-free))
  27.     (set (shape-borrowed     new) (make-table 'shape-borrowed))
  28.     (set (shape-system       new) (make-table 'shape-system))
  29.     (set (shape-introduced   new) (make-pair-table 'shape-introduced))
  30.     (set (shape-env          new) env)
  31.     (set (shape-new-env      new) (make-table 'shape-new-env))
  32.     (set (shape-primops      new) '())
  33.     new))
  34.  
  35. ;;; Hash tables indexed by pairs.
  36.  
  37. (define (make-pair-table id)
  38.   (create-%table id 0 t pair?
  39.                  (lambda (l)
  40.                    (fixnum-abs (fx+ (descriptor-hash (car l))
  41.                                     (descriptor-hash (cdr l)))))
  42.                  (lambda (x y)
  43.                    (and (eq? (car x) (car y))
  44.                         (eq? (cdr x) (cdr y))))))
  45.  
  46. ;;; Get the appropriate variable.
  47. ;;; This depends on (IF '() '#t '#f) => #f
  48.  
  49. (define (obtain-variable shape name)
  50.   (cond ((table-entry (shape-table shape) name)    ; lexically bound
  51.          => car)
  52.         (else
  53.          (obtain-locale-variable shape name))))
  54.  
  55. (define (obtain-locale-variable shape name)
  56.   (cond ((table-entry (shape-new-env shape) name)  ; defined in this locale
  57.          => identity)
  58.         ((table-entry (shape-borrowed shape) name) ; already gotten from env
  59.          => identity)
  60.         (((shape-env shape) name)                  ; defined in env
  61.          => (lambda (def)
  62.               (let ((var (create-variable name)))
  63.                 (set (variable-definition var) def)
  64.                 (set (variable-refs var) '())
  65.                 (set (table-entry (shape-borrowed shape) name) var)
  66.                 var)))
  67.         ((table-entry (shape-free shape) name)     ; already found free
  68.          => identity)
  69.         (else                                      ; never seen before
  70.          (let ((var (create-variable name)))
  71.            (set (table-entry (shape-free shape) name) var)
  72.            var))))
  73.  
  74. ;;; Binding and unbinding lexical variables.
  75.  
  76. (define (bind-variables shape vars)
  77.   (let ((table (shape-table shape)))
  78.     (walk (lambda (var)
  79.             (if var
  80.                 (free-table-push table (variable-name var) var)))
  81.           vars)))
  82.  
  83. ;;; Remove the variables from the table checking for duplicate names in
  84. ;;; VARS.
  85.  
  86. (define (unbind-variables shape vars)
  87.   (let ((table (shape-table shape)))
  88.     (walk (lambda (var)
  89.             (if var
  90.                 (let* ((name (variable-name var))
  91.                        (entry (table-entry table name)))
  92.                   (cond ((and entry (eq? var (car entry)))
  93.                          (free-table-pop table name))
  94.                         ((any? (lambda (v)
  95.                                  (and (variable? v)
  96.                                       (eq? name (variable-name v))
  97.                                       (neq? v var)))
  98.                                vars)
  99.                          (modify (table-entry table name)
  100.                                  (lambda (l)
  101.                                    (delq! var l)))
  102.                          (push (variable-flags var) 'duplicate))
  103.                         (else
  104.                          (bug "variable ~S not in shape ~S" var shape))))))
  105.           vars)))
  106.  
  107. ;;; Adding locale variables to the shape.  What happens depends on whether or
  108. ;;; not a variable of the same name is already in the shape.
  109. ;;; If a variable is found in:
  110. ;;;   TABLE        A bug if VARIANT isn't SET.
  111. ;;;                Add the variable to LEXICAL.
  112. ;;;   FREE         Move the variable to NEW-ENV.
  113. ;;;   BORROWED     Shadowing message if the variants are not compatible.
  114. ;;;                Warning if the borrowed variable's value has been integrated.
  115. ;;;                Move the variable to NEW-ENV.
  116. ;;;   ENV          Shadowing message if the variants are not compatible.
  117. ;;;                Add a new variable to NEW-ENV.
  118. ;;;   NEW-ENV      Warning message if the variants are not compatible.
  119. ;;;                Additional warning if the earlier variable's value has been
  120. ;;;                integrated somewhere.
  121. ;;;   not found    Add a new variable to NEW-ENV
  122.  
  123. (define (add-definition shape name variant)
  124.   (cond ((table-entry (shape-table shape) name)
  125.          => (lambda (pair)
  126.               (let ((var (car pair)))
  127.                 (if (neq? variant 'set)
  128.                     (orbit-warning '"global definition on lexical variable ~S" var))
  129.                 (if (not (memq? 'lexical (variable-flags var)))
  130.                     (push (variable-flags var) 'lexical))
  131.                 var)))
  132.         (else
  133.          (add-global-definition shape name variant))))
  134.  
  135. (define (add-global-definition shape name variant)
  136.   (cond ((table-entry (shape-new-env shape) name)     ; defined in this locale
  137.          => (lambda (var)
  138.               (let ((def (variable-definition var)))
  139.                 (cond ((not (definition-variant def))
  140.                        (set (definition-variant def) variant))
  141.                       (else
  142.                        (check-multiple-defs name def variant)))
  143.                 var)))
  144.         ((table-entry (shape-free shape) name)        ; already found free
  145.          => (lambda (var)
  146.               (set (table-entry (shape-free shape) name) nil)
  147.               (add-to-new-env var variant shape)
  148.               var))
  149.         ((table-entry (shape-borrowed shape) name)    ; already gotten from env
  150.          => (lambda (var)
  151.               (let ((def (variable-definition var)))
  152.                 (cond ((not (compatible-variants variant
  153.                                                  (definition-variant def)))
  154.                        (orbit-warning '"shadowing ~S~%" name)
  155.                        (if (memq? 'integrated (variable-flags var))
  156.                            (orbit-warning
  157.                        '"shadowed definition of ~S has already been integrated"
  158.                                           name))))
  159.                 (set (table-entry (shape-borrowed shape) name) nil)
  160.                 (add-to-new-env var variant shape)
  161.                 var)))
  162.         (((shape-env shape) name)                     ; defined in env
  163.          => (lambda (def)
  164.               (if (not (compatible-variants variant (definition-variant def)))
  165.                   (orbit-warning '"shadowing ~S~%" name))
  166.               (let ((var (create-variable name)))
  167.                 (add-to-new-env var variant shape)
  168.                 var)))
  169.         (else                                         ; never seen before
  170.          (let ((var (create-variable name)))
  171.            (add-to-new-env var variant shape)
  172.            var))))
  173.  
  174. (define (add-to-new-env var variant shape)
  175.   (let ((new (make-definition-entry var (shape-env shape) '() variant nil nil)))
  176.     (set (definition-env new) (shape-env shape))
  177.     (set (table-entry (shape-new-env shape) (variable-name var)) var)))
  178.  
  179. ;;; Check that two definitions are compatible, issuing a warning if they aren't.
  180. ;;; The only compatible variant pairs are (SET, LSET) and (SET, SET).
  181. ;;; Most of this is just to get a coherent error message.
  182.  
  183. (define (check-multiple-defs name def variant)
  184.   (let ((variant1 (definition-variant def)))
  185.     (cond ((compatible-variants variant variant1)
  186.            => (lambda (variant)
  187.                 (if (not (memq? 'set (definition-data def)))
  188.                     (push (definition-data def) 'set))
  189.                 (set (definition-variant def) variant)))
  190.           ((eq? 'multiple variant1)
  191.            (orbit-warning '"~S is also ~A~%" name (variant-string variant)))
  192.           ((eq? variant variant1)
  193.            (set (definition-variant def) 'multiple)
  194.            (orbit-warning '"~S is ~A twice~%" name (variant-string variant)))
  195.           (else
  196.            (set (definition-variant def) 'multiple)
  197.            (orbit-warning '"~S is both ~A and ~A~%"
  198.                           name
  199.                           (variant-string variant)
  200.                           (variant-string variant1))))))
  201.  
  202. (define (compatible-variants v1 v2)
  203.   (cond ((and (eq? v1 'set)
  204.               (eq? v2 'set))
  205.          'set)
  206.         ((or (and (eq? v1 'lset)
  207.                   (eq? v2 'set))
  208.              (and (eq? v2 'lset)
  209.                   (eq? v1 'set)))
  210.          'lset)
  211.         (else nil)))
  212.  
  213. (define (variant-string variant)
  214.   (case variant
  215.     ((set)      '"set")
  216.     ((lset)     '"lset")
  217.     ((define)   '"defined")
  218.     (else (bug '"VARIANT-STRING got a funny variant ~S" variant))))
  219.  
  220. ;;;               interface routines
  221. ;;;===========================================================================
  222.  
  223. ;;; Add a primop to the list.
  224.  
  225. (define (add-new-primop shape primop)
  226.   (push (shape-primops shape) primop))
  227.  
  228. ;;; Get the variable NAME in the new environment if it is there.
  229.  
  230. (define (new-env-definition shape name)
  231.   (let ((var (table-entry (shape-new-env shape) name)))
  232.     (cond ((and var (variable-definition var))
  233.            => identity)
  234.           (else nil))))
  235.  
  236. ;;; A hack used when a reference to a system variable is needed.
  237.  
  238. (define (get-system-variable name)
  239.   (cond ((table-entry (shape-system *shape*) name)
  240.          => identity)
  241.         ((base-early-binding-env name)
  242.          => (lambda (def)
  243.               (let ((var (create-variable name)))
  244.                 (set (variable-definition var) def)
  245.                 (set (variable-refs var) '())
  246.                 (set (table-entry (shape-system *shape*) name) var)
  247.                 var)))
  248.         ((obtain-locale-variable *shape* name)
  249.          => (lambda (var)
  250. ;              (orbit-warning
  251. ;                     "variable ~S not in system, it will be treated as free~&"
  252. ;                     name)
  253.               (set (table-entry (shape-system *shape*) name) var)
  254.               var))
  255.         (else
  256.          (bug '"missing system variable ~S" name))))
  257.  
  258. ;;; This should not be used.
  259.  
  260. (define (get-free-variable name)
  261.   (obtain-locale-variable *shape* name))
  262.  
  263. ;;; This is called when a procedure being integrated contains free references.
  264.  
  265. (define (obtain-locale-bound-variable name env)
  266.   (cond ((eq? env *new-env*)
  267.          (obtain-locale-variable *shape* name))
  268.         (else
  269.          (let ((key (cons name env)))
  270.            (cond ((table-entry (shape-introduced *shape*) key)
  271.                   => identity)
  272.                  (else 
  273.                   (let ((def (env name))
  274.                         (var (create-variable name)))
  275.                     (set (variable-definition var) def)
  276.                     (set (variable-refs var) '())
  277.                     (set (table-entry (shape-introduced *shape*) key) var)
  278.                     var)))))))
  279.  
  280.  
  281.  
  282.  
  283.  
  284.  
  285.  
  286.