home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Interp⁄Comp (.scm) / env.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  9.8 KB  |  334 lines  |  [TEXT/gamI]
  1. ;==============================================================================
  2.  
  3. ; file: "env.scm"
  4.  
  5. ;------------------------------------------------------------------------------
  6. ;
  7. ; Environment manipulation and declaration handling package:
  8. ;
  9. ;------------------------------------------------------------------------------
  10.  
  11. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  12. ;
  13. ; Environment manipulation:
  14. ; ------------------------
  15.  
  16. ; structure that represents variables:
  17.  
  18. (define (make-var
  19.  
  20.     name       ; symbol that denotes the variable
  21.     bound      ; procedure node that binds the variable (#f if global)
  22.     refs       ; set of nodes that reference this variable
  23.     sets       ; set of nodes that assign a value to this variable
  24.     source)    ; source where variable is first encountered
  25.  
  26.   (vector var-tag name bound refs sets source #f))
  27.  
  28. (define (var? x)
  29.   (and (vector? x)
  30.        (> (vector-length x) 0)
  31.        (eq? (vector-ref x 0) var-tag)))
  32.  
  33. (define (var-name x)          (vector-ref x 1))
  34. (define (var-bound x)         (vector-ref x 2))
  35. (define (var-refs x)          (vector-ref x 3))
  36. (define (var-sets x)          (vector-ref x 4))
  37. (define (var-source x)        (vector-ref x 5))
  38. (define (var-info x)          (vector-ref x 6))
  39. (define (var-name-set! x y)   (vector-set! x 1 y))
  40. (define (var-bound-set! x y)  (vector-set! x 2 y))
  41. (define (var-refs-set! x y)   (vector-set! x 3 y))
  42. (define (var-sets-set! x y)   (vector-set! x 4 y))
  43. (define (var-source-set! x y) (vector-set! x 5 y))
  44. (define (var-info-set! x y)   (vector-set! x 6 y))
  45.  
  46. (define var-tag (list 'VAR-TAG))
  47.  
  48. (define (var-copy var)
  49.   (make-var (var-name var)
  50.             #t
  51.             (set-empty)
  52.             (set-empty)
  53.             (var-source var)))
  54.  
  55.  
  56. ; temporary variables are used to name intermediate values
  57.  
  58. (define (make-temp-var name)
  59.   (make-var name #t (set-empty) (set-empty) #f))
  60.  
  61. (define (temp-var? var)
  62.   (eq? (var-bound var) #t))
  63.  
  64. ; special variable used to denote the return address of a procedure
  65.  
  66. (define ret-var (make-temp-var 'ret))
  67. (define ret-var-set (set-singleton ret-var))
  68.  
  69. ; special variable used to denote the pointer to the closed variables
  70.  
  71. (define closure-env-var (make-temp-var 'closure-env))
  72.  
  73. ; special variable used to denote empty slots
  74.  
  75. (define empty-var (make-temp-var #f))
  76.  
  77.  
  78. ; structure that represents environments:
  79.  
  80. (define make-global-environment #f)
  81. (set! make-global-environment
  82.   (lambda () (env-frame #f '())))
  83.  
  84. (define (env-frame env vars)
  85.   (vector (cons vars #f) ; variables in this frame
  86.           '()            ; macro definitions
  87.           '()            ; declarations
  88.           env))          ; parent env
  89.  
  90. (define (env-new-var! env name source)
  91.   (let* ((glob (not (env-parent-ref env)))
  92.          (var (make-var name (not glob) (set-empty) (set-empty) source)))
  93.     (env-vars-set! env (cons var (env-vars-ref env)))
  94.     var))
  95.  
  96. (define (env-macro env name def)
  97.   (let ((name* (if (full-name? name)
  98.                  name
  99.                  (let ((prefix (env-namespace-prefix env name)))
  100.                    (if prefix (make-full-name prefix name) name)))))
  101.     (vector (vector-ref env 0)
  102.             (cons (cons name* def) (env-macros-ref env))
  103.             (env-decls-ref env)
  104.             (env-parent-ref env))))
  105.  
  106. (define (env-declare env decl)
  107.   (vector (vector-ref env 0)
  108.           (env-macros-ref env)
  109.           (cons decl (env-decls-ref env))
  110.           (env-parent-ref env)))
  111.  
  112. (define (env-vars-ref env)       (car (vector-ref env 0)))
  113. (define (env-vars-set! env vars) (set-car! (vector-ref env 0) vars))
  114. (define (env-macros-ref env)     (vector-ref env 1))
  115. (define (env-decls-ref env)      (vector-ref env 2))
  116. (define (env-parent-ref env)     (vector-ref env 3))
  117.  
  118. (define (env-namespace-prefix env name)
  119.   (let loop ((decls (env-decls-ref env)))
  120.     (if (pair? decls)
  121.       (let ((decl (car decls)))
  122.         (if (eq? (car decl) NAMESPACE-sym)
  123.           (let ((syms (cddr decl)))
  124.             (if (or (null? syms) (memq name syms))
  125.               (cadr decl)
  126.               (loop (cdr decls))))
  127.           (loop (cdr decls))))
  128.       #f)))
  129.  
  130. (define (env-lookup env name stop-at-first-frame? proc)
  131.  
  132.   (define (search env name full?)
  133.     (if full?
  134.       (search* env name full?)
  135.       (let ((prefix (env-namespace-prefix env name)))
  136.         (if prefix
  137.           (search* env (make-full-name prefix name) #t)
  138.           (search* env name full?)))))
  139.  
  140.   (define (search* env name full?)
  141.  
  142.     (define (search-macros macros)
  143.       (if (pair? macros)
  144.         (let ((m (car macros)))
  145.           (if (eq? (car m) name)
  146.             (proc env name (cdr m))
  147.             (search-macros (cdr macros))))
  148.         (search-vars (env-vars-ref env))))
  149.  
  150.     (define (search-vars vars)
  151.       (if (pair? vars)
  152.         (let ((v (car vars)))
  153.           (if (eq? (var-name v) name)
  154.             (proc env name v)
  155.             (search-vars (cdr vars))))
  156.         (let ((env* (env-parent-ref env)))
  157.           (if (or stop-at-first-frame? (not env*))
  158.             (proc env name #f)
  159.             (search env* name full?)))))
  160.  
  161.     (search-macros (env-macros-ref env)))
  162.  
  163.   (search env name (full-name? name)))
  164.  
  165. (define (valid-prefix? str)      ; non-null name followed by a "#" at end is
  166.   (let ((l (string-length str))) ; valid as is the special prefix ""
  167.     (or (= l 0)
  168.         (and (>= l 2)
  169.              (char=? (string-ref str (- l 1)) #\#)))))
  170.  
  171. (define (full-name? sym) ; full name if it contains a "#"
  172.   (let ((str (symbol->string sym)))
  173.     (let loop ((i (- (string-length str) 1)))
  174.       (if (< i 0)
  175.         #f
  176.         (if (char=? (string-ref str i) #\#)
  177.           #t
  178.           (loop (- i 1)))))))
  179.  
  180. (define (make-full-name prefix sym)
  181.   (if (= (string-length prefix) 0)
  182.     sym
  183.     (string->canonical-symbol (string-append prefix (symbol->string sym)))))
  184.  
  185. (define (env-lookup-var env name source)
  186.   (env-lookup env name #f
  187.     (lambda (env name x)
  188.       (if x
  189.         (if (var? x)
  190.           x
  191.           (compiler-internal-error
  192.             "env-lookup-var, name is that of a macro" name))
  193.         (env-new-var! env name source)))))
  194.  
  195. (define (env-define-var env name source)
  196.   (env-lookup env name #t
  197.     (lambda (env name x)
  198.       (if x
  199.         (if (var? x)
  200.           (pt-syntax-error source "Duplicate definition of a variable")
  201.           (compiler-internal-error
  202.             "env-define-var, name is that of a macro" name))
  203.         (env-new-var! env name source)))))
  204.  
  205. (define (env-lookup-global-var env name)
  206.   (let ((env* (env-global-env env)))
  207.  
  208.     (define (search-vars vars)
  209.       (if (pair? vars)
  210.         (let ((v (car vars)))
  211.           (if (eq? (var-name v) name)
  212.             v
  213.             (search-vars (cdr vars))))
  214.         (env-new-var! env* name #f)))
  215.  
  216.     (search-vars (env-vars-ref env*))))
  217.  
  218. (define (env-global-variables env)
  219.   (env-vars-ref (env-global-env env)))
  220.  
  221. (define (env-global-env env)
  222.   (let loop ((env env))
  223.     (let ((env* (env-parent-ref env)))
  224.       (if env*
  225.         (loop env*)
  226.         env))))
  227.  
  228. (define (env-lookup-macro env name)
  229.   (env-lookup env name #f
  230.     (lambda (env name x)
  231.       (if (or (not x) (var? x)) #f x))))
  232.  
  233. (define (env-declarations env)
  234.   env)
  235.  
  236.  
  237. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  238. ;
  239. ; Declarations:
  240. ; ------------
  241. ;
  242. ; A declaration has the form: (##declare <item1> <item2> ...)
  243. ;
  244. ; an <item> can be one of 6 types:
  245. ;
  246. ; - flag declaration           : (<id>)
  247. ; - parameterized declaration  : (<id> <parameter>)
  248. ; - boolean declaration        : (<id>)  or  (NOT <id>)
  249. ; - namable declaration        : (<id> <name>...)
  250. ; - namable boolean declaration: (<id> <name>...)  or  (NOT <id> <name>...)
  251. ; - namable string declaration : (<id> <string> <name>...)
  252.  
  253. ; Declarations table (for parsing):
  254.  
  255. (define flag-declarations            '())
  256. (define parameterized-declarations   '())
  257. (define boolean-declarations         '())
  258. (define namable-declarations         '())
  259. (define namable-boolean-declarations '())
  260. (define namable-string-declarations  '())
  261.  
  262. (define (define-flag-decl name type)
  263.   (set! flag-declarations (cons (cons name type) flag-declarations))
  264.   '())
  265.  
  266. (define (define-parameterized-decl name)
  267.   (set! parameterized-declarations (cons name parameterized-declarations))
  268.   '())
  269.  
  270. (define (define-boolean-decl name)
  271.   (set! boolean-declarations (cons name boolean-declarations))
  272.   '())
  273.  
  274. (define (define-namable-decl name type)
  275.   (set! namable-declarations (cons (cons name type) namable-declarations))
  276.   '())
  277.  
  278. (define (define-namable-boolean-decl name)
  279.   (set! namable-boolean-declarations (cons name namable-boolean-declarations))
  280.   '())
  281.  
  282. (define (define-namable-string-decl name)
  283.   (set! namable-string-declarations (cons name namable-string-declarations))
  284.   '())
  285.  
  286. ; Declaration constructors:
  287.  
  288. (define (flag-decl source type val)
  289.   (list type val))
  290.  
  291. (define (parameterized-decl source id parm)
  292.   (list id parm))
  293.  
  294. (define (boolean-decl source id pos)
  295.   (list id pos))
  296.  
  297. (define (namable-decl source type val names)
  298.   (cons type (cons val names)))
  299.  
  300. (define (namable-boolean-decl source id pos names)
  301.   (cons id (cons pos names)))
  302.  
  303. (define (namable-string-decl source id str names)
  304.   (if (and (eq? id NAMESPACE-sym) (not (valid-prefix? str)))
  305.     (pt-syntax-error source "Illegal namespace"))
  306.   (cons id (cons str names)))
  307.  
  308. ; Declaration querying:
  309.  
  310. (define (declaration-value name element default decls)
  311.   (if (not decls)
  312.     default
  313.     (let loop ((l (env-decls-ref decls)))
  314.       (if (pair? l)
  315.         (let ((d (car l)))
  316.           (if (and (eq? (car d) name)
  317.                    (or (null? (cddr d)) (memq element (cddr d))))
  318.             (cadr d)
  319.             (loop (cdr l))))
  320.         (declaration-value name element default (env-parent-ref decls))))))
  321.  
  322.  
  323. ; Namespace declaration:
  324. ;
  325. ; (namespace <space>)                 set namespace for all plain identifiers
  326. ; (namespace <space> <var1> ...)      only for given variables
  327.  
  328. (define NAMESPACE-sym (string->canonical-symbol "NAMESPACE"))
  329.  
  330. (define-namable-string-decl NAMESPACE-sym)
  331.  
  332.  
  333. ;==============================================================================
  334.