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
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
|
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
; Miniature evaluator.
(define (eval form package)
(evil form package))
(define (evil exp env)
(cond ((symbol? exp) (env exp))
((not (pair? exp)) exp)
((eq? (car exp) 'quote) (cadr exp))
((eq? (car exp) 'lambda)
(lambda args
(evil-begin (cddr exp) (bind (cadr exp) args env))))
((eq? (car exp) 'if)
(evil (if (evil (cadr exp) env)
(caddr exp)
(cadddr exp))
env))
((eq? (car exp) 'define)
(let* ((pat (cadr exp))
(lhs (if (pair? pat) (car pat) pat))
(rhs (if (pair? pat)
`(lambda ,(cdr pat) ,@(cddr exp))
(caddr exp))))
((env '%%define%%) lhs (evil rhs env))))
(else
(apply (evil (car exp) env)
(map (lambda (arg) (evil arg env)) (cdr exp))))))
(define (evil-begin exp-list env)
(if (null? (cdr exp-list))
(evil (car exp-list) env)
(begin (evil (car exp-list) env)
(evil-begin (cdr exp-list) env))))
(define (bind names vals env)
(let ((alist (map cons names vals)))
(lambda (name)
(let ((probe (assq name alist)))
(if probe (cdr probe) (env name))))))
; Initial package
(define (initial-package name)
(let ((probe (assq name *initial-bindings*)))
(if probe (cdr probe) (assertion-violation 'initial-package "unbound" name))))
(define (define-initial name val)
(let ((probe (assq name *initial-bindings*)))
(if probe
(set-cdr! probe val)
(set! *initial-bindings*
(cons (cons name val) *initial-bindings*)))))
(define *initial-bindings*
(list (cons '%%define%% define-initial)))
(define-syntax define-initial-stuff
(syntax-rules ()
((define-initial-stuff ?name ...)
(for-each define-initial
'(?name ...)
(list ?name ...)))))
(define-initial-stuff
cons car cdr + - * / < = > list map append reverse
make-vector vector-ref vector-set! vector-length
apply)
; LOAD
(define (load filename)
(load-into filename (interaction-environment)))
(define (load-into filename env)
(call-with-input-file filename
(lambda (port)
(let loop ()
(let ((form (read port)))
(cond ((eof-object? form))
(else
(eval form env)
(loop))))))))
(define (eval-from-file forms env filename)
(for-each (lambda (form) (eval form env)) forms))
(define (eval-scanned-forms forms env filename)
(for-each (lambda (form) (eval form env)) forms))
; Interaction environment
(define (set-interaction-environment! package)
(set! *interaction-environment* package))
(define (interaction-environment)
*interaction-environment*)
(define *interaction-environment* initial-package)
(define (set-scheme-report-environment! n package)
(set! *scheme-report-environment* package))
(define (scheme-report-environment n)
*scheme-report-environment*)
(define (null-environment n)
*scheme-report-environment*)
(define *scheme-report-environment* #f)
|
