blob: 49fdab11fc3d109acb591d010d9eadcdc170ae4c (
plain) (
blame)
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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
|
;;; logo.scm part of programming project #4
;;; Problem A1 make-line-obj
(define (make-line-obj text)
(error "make-line-obj not written yet!"))
;;; Problem A2 logo-type
(define (logo-type val)
(error "logo-type not written yet!"))
(define (logo-print val)
(logo-type val)
(newline)
'=no-value=)
(define (logo-show val)
(logo-print (list val)))
;;; Problem B3 variables (logo-meta.scm is also affected)
(define (make env var val)
(error "make not written yet!")
'=no-value=)
;;; Here are the primitives RUN, IF, and IFELSE. Problem B2 provides
;;; support for these, but you don't have to modify them.
(define (run env exp)
(eval-line (make-line-obj exp) env))
(define (logo-if env t/f exp)
(cond ((eq? t/f 'true) (eval-line (make-line-obj exp) env))
((eq? t/f 'false) '=no-value=)
(else (error "Input to IF not true or false" t/f))))
(define (ifelse env t/f exp1 exp2)
(cond ((eq? t/f 'true) (eval-line (make-line-obj exp1) env))
((eq? t/f 'false) (eval-line (make-line-obj exp2) env))
(else (error "Input to IFELSE not true or false" t/f))))
;;; Problem B2 logo-pred
(define (logo-pred pred)
pred) ;; This isn't written yet but we fake it for now.
;;; Here is an example of a Scheme predicate that will be turned into
;;; a Logo predicate by logo-pred:
(define (equalp a b)
(if (and (number? a) (number? b))
(= a b)
(equal? a b)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Stuff below here is needed for the interpreter to work but you ;;;
;;; don't have to modify anything or understand how they work. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The Logo reader
(define left-paren-symbol (string->symbol (make-string 1 #\( )))
(define right-paren-symbol (string->symbol (make-string 1 #\) )))
(define quote-symbol (string->symbol (make-string 1 #\" )))
(define (logo-read)
(define lookahead #f)
(define (logo-read-help depth)
(define (get-char)
(if lookahead
(let ((char lookahead))
(set! lookahead #f)
char)
(let ((char (read-char)))
(if (eq? char #\\)
(list (read-char))
char))))
(define (quoted char)
(if (pair? char)
char
(list char)))
(define (get-symbol char)
(define (iter sofar char)
(cond ((pair? char) (iter (cons (car char) sofar) (get-char)))
((memq char
'(#\space #\newline #\+ #\- #\* #\/
#\= #\< #\> #\( #\) #\[ #\] ))
(set! lookahead char)
sofar)
(else (iter (cons char sofar) (get-char))) ))
(string->word (list->string (reverse (iter '() char)))) )
(define (get-token space-flag)
(let ((char (get-char)))
(cond ((eq? char #\space) (get-token #t))
((memq char '(#\+ #\* #\/ #\= #\< #\> #\( #\) ))
(string->symbol (make-string 1 char)))
((eq? char #\-)
(if space-flag
(let ((char (get-char)))
(let ((result (if (eq? char #\space)
'-
'=unary-minus=)))
(set! lookahead char)
result))
'-))
((eq? char #\[) (logo-read-help (1+ depth)))
((pair? char) (get-symbol char))
((eq? char #\")
(let ((char (get-char)))
(if (memq char '(#\[ #\] #\newline))
(begin (set! lookahead char) quote-symbol)
(string->symbol (word quote-symbol
(get-symbol (quoted char)))))))
(else (get-symbol char)) )))
(define (after-space)
(let ((char (get-char)))
(if (eq? char #\space)
(after-space)
char)))
(let ((char (get-char)))
(cond ((eq? char #\newline)
(if (> depth 0) (set! lookahead char))
'())
((eq? char #\space)
(let ((char (after-space)))
(if (eq? char #\newline)
(begin (if (> depth 0) (set! lookahead char))
'())
(begin (set! lookahead char)
(let ((token (get-token #t)))
(cons token (logo-read-help depth)))))))
((eq? char #\])
(if (> depth 0) '() (error "Unexpected ]")))
((eof-object? char) char)
(else (set! lookahead char)
(let ((token (get-token #f)))
(cons token (logo-read-help depth)) )))))
(logo-read-help 0))
;;; Assorted stuff
(define (make-logo-arith op)
(lambda args (apply op (map maybe-num args))))
(define (maybe-num val)
(string->word (word->string val)))
(define tty-port (current-input-port))
(define (prompt string)
(if (eq? (current-input-port) tty-port) (display string)))
(define (meta-load fn)
(define (loader)
(let ((exp (logo-read)))
(if (eof-object? exp)
'()
(begin (eval-line (make-line-obj exp)
the-global-environment)
(loader)))))
(with-input-from-file (symbol->string fn) loader)
'=no-value=)
|