;==============================================================================

; File: "_env.scm", Time-stamp: <2006-01-02 23:48:13 feeley>

; Copyright (C) 1994-2006 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))
      0
      (let loop ((node bound) (n 0))
        (if node
          (loop (node-parent node)
                (+ n (if (prc? node) 1 0)))
          n)))))


; 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)))
    var))

(define (env-macro env name def)
  (let ((name* (if (full-name? 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))
          space
          (loop (cdr lst))))
      #f)))

(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)
        #f
        (if (char=? (string-ref str i) #\#)
          #t
          (loop (- i 1)))))))

(define (make-full-name prefix sym)
  (if (= (string-length prefix) 0)
    sym
    (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)
          x
          (compiler-internal-error
            "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)
          (pt-syntax-error source "Duplicate definition of a variable")
          (compiler-internal-error
            "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)
            v
            (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*)
        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))))
      default)))


; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(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 '())
  '())


;==============================================================================