Skip to content


Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

316 lines (243 sloc) 9.611 kb
;;; File: "_env.scm", Time-stamp: <2007-06-28 18:50:52 feeley>
;;; Copyright (c) 1994-2007 by Marc Feeley, All Rights Reserved.
(include "fixnum.scm")
(include "_envadt.scm")
(include-adt "_gvmadt.scm")
(include-adt "_ptreeadt.scm")
(include-adt "_sourceadt.scm")
;;;; Environment manipulation and declaration handling module
(define next-var-stamp #f)
(define (var-lexical-level var)
(let ((bound (var-bound var)))
(if (or (eq? bound #f) (eq? bound #t))
(let loop ((node bound) (n 0))
(if node
(loop (node-parent node)
(+ n (if (prc? node) 1 0)))
;; temporary variables are used to name intermediate values
(define (make-temp-var name)
(make-var name #t (ptset-empty) (ptset-empty) #f))
(define (temp-var? var)
(eq? (var-bound var) #t))
;; special variable used to denote the return address of a procedure
(define ret-var '())
(define ret-var-set '())
;; special variable used to denote the pointer to the closed variables
(define closure-env-var '())
;; special variable used to denote empty slots
(define empty-var '())
;; structure that represents environments:
(define make-global-environment #f)
(set! make-global-environment
(lambda () (env-frame #f '())))
(define (env-frame env vars)
(vector (cons vars #f) ; cell containing variables in this frame
'() ; macro definitions
(if env (env-decl-ref env) '()) ; declarations
'() ; namespace
env)) ; parent env
(define (env-new-var! env name source)
(let* ((glob (not (env-parent-ref env)))
(var (make-var name (not glob) (ptset-empty) (ptset-empty) source)))
(env-vars-set! env (cons var (env-vars-ref env)))
(define (env-macro env name def)
(let ((name* (if (full-name? name)
(let ((prefix (env-namespace-prefix env name)))
(if prefix (make-full-name prefix name) name)))))
(vector (vector-ref env 0)
(cons (cons name* def) (env-macros-ref env))
(env-decl-ref env)
(env-namespace-ref env)
(env-parent-ref env))))
(define (env-declare env d)
(vector (vector-ref env 0)
(env-macros-ref env)
(cons d (env-decl-ref env))
(env-namespace-ref env)
(env-parent-ref env)))
(define (env-namespace env n)
(vector (vector-ref env 0)
(env-macros-ref env)
(env-decl-ref env)
(cons n (env-namespace-ref env))
(env-parent-ref env)))
(define (env-vars-ref env) (car (vector-ref env 0)))
(define (env-vars-set! env vars) (set-car! (vector-ref env 0) vars))
(define (env-macros-ref env) (vector-ref env 1))
(define (env-decl-ref env) (vector-ref env 2))
(define (env-namespace-ref env) (vector-ref env 3))
(define (env-parent-ref env) (vector-ref env 4))
(define (env-namespace-prefix env name)
(let loop ((lst (env-namespace-ref env)))
(if (pair? lst)
(let* ((x (car lst))
(space (car x))
(syms (cdr x)))
(if (or (null? syms) (memq name syms))
(loop (cdr lst))))
(define (env-lookup env name stop-at-first-frame? proc)
(define (search env name full?)
(if full?
(search* env name #t)
(let ((prefix (and ;(pair? (env-namespace-ref env));**********brad
(env-namespace-prefix env name))))
(if prefix
(search* env (make-full-name prefix name) #t)
(search* env name #f)))))
(define (search* env name full?)
(define (search-macros macros)
(if (pair? macros)
(let ((m (car macros)))
(if (eq? (car m) name)
(proc env name (cdr m))
(search-macros (cdr macros))))
(search-vars (env-vars-ref env))))
(define (search-vars vars)
(if (pair? vars)
(let ((v (car vars)))
(if (eq? (var-name v) name)
(proc env name v)
(search-vars (cdr vars))))
(let ((env* (env-parent-ref env)))
(if (or stop-at-first-frame? (not env*))
(proc env name #f)
(search env* name full?)))))
(search-macros (env-macros-ref env)))
(search env name (full-name? name)))
(define (valid-prefix? str) ; non-null name followed by a "#" at end is
(let ((l (string-length str))) ; valid as is the special prefix ""
(or (= l 0)
(and (>= l 2)
(char=? (string-ref str (- l 1)) #\#)))))
(define (full-name? sym) ; full name if it contains a "#"
(let ((str (symbol->string sym)))
(let loop ((i (- (string-length str) 1)))
(if (< i 0)
(if (char=? (string-ref str i) #\#)
(loop (- i 1)))))))
(define (make-full-name prefix sym)
(if (= (string-length prefix) 0)
(string->symbol (string-append prefix (symbol->string sym)))))
(define (env-lookup-var env name source)
(env-lookup env name #f
(lambda (env name x)
(if x
(if (var? x)
"env-lookup-var, name is that of a macro" name))
(env-new-var! env name source)))))
(define (env-define-var env name source)
(env-lookup env name #t
(lambda (env name x)
(if x
(if (var? x)
"Duplicate definition of a variable")
"env-define-var, name is that of a macro" name))
(env-new-var! env name source)))))
(define (env-lookup-global-var env name)
(let ((env* (env-global-env env)))
(define (search-vars vars)
(if (pair? vars)
(let ((v (car vars)))
(if (eq? (var-name v) name)
(search-vars (cdr vars))))
(env-new-var! env* name #f)))
(search-vars (env-vars-ref env*))))
(define (env-global-variables env)
(env-vars-ref (env-global-env env)))
(define (env-global-env env)
(let loop ((env env))
(let ((env* (env-parent-ref env)))
(if env*
(loop env*)
(define (env-lookup-macro env name)
(env-lookup env name #f
(lambda (env name x)
(if (or (not x) (var? x)) #f x))))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;;;; Declarations
;; A declaration has the form: (##declare <item1> <item2> ...)
;; an <item> can be one of 5 types:
;; - flag declaration : (<id>)
;; - parameterized declaration : (<id> <exact-integer>)
;; - boolean declaration : (<id>) or (NOT <id>)
;; - namable declaration : (<id> <name>...)
;; - namable boolean declaration: (<id> <name>...) or (NOT <id> <name>...)
;; Declarations table (for parsing):
(define flag-declarations '())
(define parameterized-declarations '())
(define boolean-declarations '())
(define namable-declarations '())
(define namable-boolean-declarations '())
(define (define-flag-decl name type)
(set! flag-declarations (cons (cons name type) flag-declarations))
(define (define-parameterized-decl name)
(set! parameterized-declarations (cons name parameterized-declarations))
(define (define-boolean-decl name)
(set! boolean-declarations (cons name boolean-declarations))
(define (define-namable-decl name type)
(set! namable-declarations (cons (cons name type) namable-declarations))
(define (define-namable-boolean-decl name)
(set! namable-boolean-declarations (cons name namable-boolean-declarations))
;; Declaration constructors:
(define (flag-decl source type val)
(list type val))
(define (parameterized-decl source id parm)
(list id parm))
(define (boolean-decl source id pos)
(list id pos))
(define (namable-decl source type val names)
(cons type (cons val names)))
(define (namable-boolean-decl source id pos names)
(cons id (cons pos names)))
;; Declaration querying:
(define (declaration-value name element default env)
(let loop ((lst (env-decl-ref env)))
(if (pair? lst)
(let ((d (car lst)))
(if (and (eq? (car d) name)
(or (null? (cddr d)) (memq element (cddr d))))
(cadr d)
(loop (cdr lst))))
;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define (env.begin!) ; initialize module
(set! next-var-stamp (make-counter 0))
(set! ret-var (make-temp-var 'ret))
(set! ret-var-set (varset-singleton ret-var))
(set! closure-env-var (make-temp-var 'closure-env))
(set! empty-var (make-temp-var #f))
(define (env.end!) ; finalize module
(set! next-var-stamp '())
(set! ret-var '())
(set! ret-var-set '())
(set! closure-env-var '())
(set! empty-var '())
Jump to Line
Something went wrong with that request. Please try again.