File: env.scm

package info (click to toggle)
scsh 0.5.1-2
  • links: PTS
  • area: non-free
  • in suites: potato, slink
  • size: 6,540 kB
  • ctags: 8,656
  • sloc: lisp: 39,346; ansic: 13,466; sh: 1,669; makefile: 624
file content (97 lines) | stat: -rw-r--r-- 2,969 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.



; Accessing packages

(define (environment-ref package name)
  (carefully (package-lookup package name) contents package name))

(define (environment-set! package name value)
  (let ((binding (package-lookup package name)))
    (if (and (binding? binding)
	     (not (variable-type? (binding-type binding))))
	(error "invalid assignment" name package value)
	(carefully binding
		   (lambda (loc)
		     (set-contents! loc value))
		   package name))))

(define (environment-define! package name value)
  (set-contents! (package-define! package name usual-variable-type) value))

(define (*structure-ref struct name)
  (let ((binding (structure-lookup struct name #f)))
    (if binding
	(carefully binding contents struct name)
	(error "structure-ref: name not exported" struct name))))

(define (carefully binding action env name)
  (if (binding? binding)
      (if (eq? (binding-type binding) syntax-type)
	  (error "attempt to reference syntax as variable" name env)
	  (let ((loc (binding-place binding)))
	    (if (location? loc)
		(if (location-defined? loc)
		    (action loc)
		    (error "unbound variable" name env))
		(error "variable has no location" name env))))
      (if (unbound? binding)
	  (error "unbound variable" name env)
	  (error "peculiar binding" binding name env))))



; Interaction environment

(define $interaction-environment (make-fluid #f))

(define (interaction-environment)
  (fluid $interaction-environment))

(define (set-interaction-environment! p)
  (if (package? p)
      (set-fluid! $interaction-environment p)
      (call-error "invalid package" set-interaction-environment! p)))

(define (with-interaction-environment p thunk)
  (if (package? p)
      (let-fluid $interaction-environment p thunk)
      (call-error "invalid package" with-interaction-environment p)))


; Scheme report environment.  Should be read-only; fix later.

(define (scheme-report-environment n)
  (if (= n *scheme-report-number*)
      *scheme-report-environment*
      (error "no such Scheme report environment")))

(define *scheme-report-environment* #f)
(define *scheme-report-number* 0)

(define (set-scheme-report-environment! repnum env)
  (set! *scheme-report-number* repnum)
  (set! *scheme-report-environment* env))



; Make an infinite tower of packages for syntax.
; structs should be a non-null list of structures that should be
; opened at EVERY level of the tower.

(define (make-reflective-tower eval structs id)
  (let recur ((level 1))
    (delay (cons eval
		 (make-simple-package structs
				      eval
				      (recur (+ level 1))
				      `(for-syntax ,level ,id))))))

; (set-reflective-tower-maker! p (lambda (clauses id) ...))
; where clauses is a list of DEFINE-STRUCTURE clauses

(define set-reflective-tower-maker!
  (let ((name (string->symbol ".make-reflective-tower.")))
    (lambda (p proc)
      (environment-define! p name proc))))