160 lines
5.3 KiB
Scheme
160 lines
5.3 KiB
Scheme
;;; Ported from Scheme 48 1.9. See file COPYING for notices and license.
|
|
;;;
|
|
;;; Port Author: Andrew Whatson
|
|
;;;
|
|
;;; Original Authors: Richard Kelsey
|
|
;;;
|
|
;;; scheme48-1.9.2/ps-compiler/node/node.scm
|
|
;;;
|
|
;;; This file contains the definitions of the node tree data structure.
|
|
|
|
(define-module (ps-compiler node variable)
|
|
#:use-module (prescheme scheme48)
|
|
#:use-module (prescheme s48-defrecord)
|
|
#:use-module (prescheme record-discloser)
|
|
#:use-module (ps-compiler node node)
|
|
#:use-module (ps-compiler util util)
|
|
#:replace (variable? make-variable)
|
|
#:export (global-variable? make-global-variable
|
|
variable-name set-variable-name!
|
|
variable-id
|
|
variable-type set-variable-type!
|
|
variable-binder set-variable-binder!
|
|
variable-refs set-variable-refs!
|
|
variable-flag set-variable-flag!
|
|
variable-flags set-variable-flags!
|
|
variable-generate set-variable-generate!
|
|
new-variable-id
|
|
erase-variable
|
|
reset-node-id node-hash node-unhash
|
|
variable-index copy-variable used? unused?
|
|
variable-flag-accessor variable-flag-setter variable-flag-remover
|
|
variable-known-value
|
|
add-variable-known-value!
|
|
remove-variable-known-value!
|
|
variable-simplifier
|
|
add-variable-simplifier!
|
|
remove-variable-simplifier!
|
|
note-known-global-lambda!
|
|
variable-known-lambda))
|
|
|
|
;;;---------------------------------------------------------------------------
|
|
;;; Records to represent variables.
|
|
|
|
(define-record-type variable
|
|
((name) ;; Source code name for variable (used for debugging only)
|
|
(id) ;; Unique numeric identifier (used for debugging only)
|
|
(type) ;; Type for variable's value
|
|
)
|
|
(binder ;; LAMBDA node which binds this variable
|
|
(refs '()) ;; List of leaf nodes n for which (REFERENCE-VARIABLE n) = var.
|
|
(flag #f) ;; Useful slot, used by shapes, COPY-NODE, NODE->VECTOR, etc.
|
|
;; all users must leave this is #F
|
|
(flags '()) ;; For various annotations, e.g. IGNORABLE
|
|
(generate #f) ;; For whatever code generation wants
|
|
))
|
|
|
|
(define-record-discloser type/variable
|
|
(lambda (var)
|
|
(node-hash var)
|
|
(list 'variable (variable-name var) (variable-id var))))
|
|
|
|
(define (make-variable name type)
|
|
(variable-maker name (new-variable-id) type))
|
|
|
|
(define (make-global-variable name type)
|
|
(let ((var (make-variable name type)))
|
|
(set-variable-binder! var #f)
|
|
var))
|
|
|
|
(define (global-variable? var)
|
|
(not (variable-binder var)))
|
|
|
|
;; Every variable has a unique numeric identifier that is used for printing.
|
|
|
|
(define *variable-id* 0)
|
|
|
|
(define (new-variable-id)
|
|
(let ((id *variable-id*))
|
|
(set! *variable-id* (+ 1 *variable-id*))
|
|
id))
|
|
|
|
(define (erase-variable var)
|
|
(cond ((eq? (variable-id var) '<erased>)
|
|
(bug "variable ~S already erased" var))
|
|
(else
|
|
(set-variable-id! var '<erased>))))
|
|
|
|
(define *node-hash-table* #f)
|
|
|
|
(define (reset-node-id)
|
|
(set! *variable-id* 0)
|
|
(set! *node-hash-table* (make-table)))
|
|
|
|
(define (node-hash var-or-lambda)
|
|
(let ((id (if (variable? var-or-lambda)
|
|
(variable-id var-or-lambda)
|
|
(lambda-id var-or-lambda))))
|
|
(table-set! *node-hash-table* id var-or-lambda)))
|
|
|
|
(define (node-unhash n)
|
|
(table-ref *node-hash-table* n))
|
|
|
|
;; The index of VAR in the variables bound by its binder.
|
|
|
|
(define (variable-index var)
|
|
(let ((binder (variable-binder var)))
|
|
(if (not binder)
|
|
(bug "VARIABLE-INDEX called on global variable ~S" var)
|
|
(do ((i 0 (+ i 1))
|
|
(vs (lambda-variables binder) (cdr vs)))
|
|
((eq? (car vs) var)
|
|
i)))))
|
|
|
|
;; Copy an old variable.
|
|
|
|
(define (copy-variable old)
|
|
(let ((var (make-variable (variable-name old) (variable-type old))))
|
|
(set-variable-flags! var (variable-flags old))
|
|
var))
|
|
|
|
;; An unused variable is either #F or a variable with no references.
|
|
|
|
(define (used? var)
|
|
(and var
|
|
(not (null? (variable-refs var)))))
|
|
|
|
(define (unused? var)
|
|
(not (used? var)))
|
|
|
|
;; known values for top-level variables
|
|
|
|
(define (variable-flag-accessor flag)
|
|
(lambda (var)
|
|
(let ((p (flag-assq flag (variable-flags var))))
|
|
(if p (cdr p) #f))))
|
|
|
|
(define (variable-flag-setter flag)
|
|
(lambda (var value)
|
|
(set-variable-flags! var
|
|
(cons (cons flag value)
|
|
(variable-flags var)))))
|
|
|
|
(define (variable-flag-remover flag)
|
|
(lambda (var)
|
|
(set-variable-flags! var (filter (lambda (x)
|
|
(or (not (pair? x))
|
|
(not (eq? (car x) flag))))
|
|
(variable-flags var)))))
|
|
|
|
(define variable-known-value (variable-flag-accessor 'known-value))
|
|
(define add-variable-known-value! (variable-flag-setter 'known-value))
|
|
(define remove-variable-known-value! (variable-flag-remover 'known-value))
|
|
|
|
(define variable-simplifier (variable-flag-accessor 'simplifier))
|
|
(define add-variable-simplifier! (variable-flag-setter 'simplifier))
|
|
(define remove-variable-simplifier! (variable-flag-remover 'simplifier))
|
|
|
|
(define variable-known-lambda (variable-flag-accessor 'known-lambda))
|
|
(define note-known-global-lambda! (variable-flag-setter 'known-lambda))
|