source: project/logo/evaluator.scm @ 5889

Last change on this file since 5889 was 5889, checked in by felix winkelmann, 12 years ago

initial import

File size: 16.6 KB
Line 
1;; This work is licensed under the Creative Commons
2;; Attribution-NonCommercial-ShareAlike License. To view a copy of this
3;; license, visit http://creativecommons.org/licenses/by-nc-sa/2.0/ or
4;; send a letter to Creative Commons, 559 Nathan Abbott Way, Stanford,
5;; California 94305, USA.
6;;
7;; The original author of this code is Arthur Nunes-Harwitt
8;;
9;;;;;;;;;;;;;;;;;;;;;;;;;
10;;;;;;;;;;; The Evaluator
11;;;;;;;;;;;;;;;;;;;;;;;;;
12
13
14(define *proc-return* '(no value))
15
16(define *logo-true* (make-name "TRUE"))
17
18(define *logo-false* (make-name "FALSE"))
19
20(define (logo-true? x)
21  (and (logo-name? x)
22       (eq? 'true (symbol<-logo-name x))))
23
24(define (logo-false? x)
25  (and (logo-name? x)
26       (eq? 'false (symbol<-logo-name x))))
27
28(define (logo-boolean? x)
29  (and (logo-name? x)
30       (or (eq? 'false (symbol<-logo-name x))
31           (eq? 'true (symbol<-logo-name x)))))
32
33(define (logo-bool<-bool x)
34  (case x
35    ((#t) *logo-true*)
36    ((#f) *logo-false*)
37    (else (logo-error "Not a boolean value" x))))
38
39(define (bool<-logo-bool x)
40  (case (symbol<-logo-name x)
41    ((true) #t)
42    ((false) #f)
43    (else (logo-error "Not a Logo boolean value" x))))
44
45(define (self-eval? exp)  (or (number? exp) 
46                              (logo-list? exp))) 
47
48(define (look-up name env)
49  (if (null? env)
50    (logo-error "unbound variable" name)
51    (let ((names (car env))
52          (vals (cadr env))
53          (rest-env (cddr env)))
54      (let loop ((names names)
55                  (vals vals))
56        (cond ((null? names)
57               (look-up name rest-env))
58              ((eq? name (car names))
59               (car vals))
60              (else (loop (cdr names) (cdr vals))))))))
61
62
63(define (v-look-up name env)
64  (if (null? env)
65    (logo-error "The variable" name "has no value")
66    (let ((names (car env))
67          (vals (cadr env))
68          (rest-env (cddr env)))
69      (let loop ((names names)
70                  (vals vals))
71        (cond ((null? names)
72               (v-look-up name rest-env))
73              ((eq? name (car names))
74               (car vals))
75              (else (loop (cdr names) (cdr vals))))))))
76
77
78(define (p-look-up name env)
79  (if (null? env)
80    (logo-error "I don't know how to" name)
81    (let ((names (car env))
82          (vals (cadr env))
83          (rest-env (cddr env)))
84      (let loop ((names names)
85                  (vals vals))
86        (cond ((null? names)
87               (p-look-up name rest-env))
88              ((eq? name (car names))
89               (car vals))
90              (else (loop (cdr names) (cdr vals))))))))
91
92
93(define (c-look-up name env)
94  (if (null? env)
95    (logo-error "I can't find the catch tag" name)
96    (let ((names (car env))
97          (vals (cadr env))
98          (rest-env (cddr env)))
99      (let loop ((names names)
100                  (vals vals))
101        (cond ((null? names)
102               (c-look-up name rest-env))
103              ((eq? name (car names))
104               (car vals))
105              (else (loop (cdr names) (cdr vals))))))))
106
107(define (extend env names vals)
108  (cons names (cons vals env)))
109
110(define (local-update! env name val)
111  (let ((names (car env))
112        (vals (cadr env))
113        (rest-env (cddr env)))
114    (let loop ((nmes names)
115               (vls vals))
116      (cond ((null? nmes)
117             (set-car! env (cons name names))
118             (set-car! (cdr env) (cons val vals)))
119            ((eq? name (car nmes))
120             (set-car! vls val))
121            (else (loop (cdr nmes) (cdr vls)))))))
122
123(define (update! env name val)
124  (let ((names (car env))
125        (vals (cadr env))
126        (rest-env (cddr env)))
127    (if (null? rest-env)
128      (let loop ((nmes names)
129                 (vls vals))
130      (cond ((null? nmes)
131             (set-car! env (cons name names))
132             (set-car! (cdr env) (cons val vals)))
133            ((eq? name (car nmes))
134             (set-car! vls val))
135            (else (loop (cdr nmes) (cdr vls)))))
136      (let loop ((nmes names)
137                 (vls vals))
138        (cond ((null? nmes) (update! rest-env name val))
139              ((eq? name (car nmes))
140               (set-car! vls val))
141              (else (loop (cdr nmes) (cdr vls))))))))
142
143
144(define (make-primitive prim)
145  (vector 'primitive prim))
146(define (logo-primitive? x)
147  (and (vector? x) (eq? (vector-ref x 0) 'primitive)))
148(define (code<-primitive x) (vector-ref x 1))
149
150(define (make-user-proc code rep)
151  (vector 'user-proc code rep))
152(define (logo-user-proc? x)
153  (and (vector? x) (eq? (vector-ref x 0) 'user-proc)))
154(define (code<-user-proc x) (vector-ref x 1))
155(define (rep<-user-proc x) (vector-ref x 2))
156(define (set-user-proc-code! up c) (vector-set! up 1 c))
157(define (set-user-proc-rep! up r) (vector-set! up 2 r))
158
159
160(define (code<-logo-proc-entry x) (vector-ref x 1))
161
162
163(define *init-var-env* (extend '() '() '()))
164
165(define *init-catch-env* '())
166
167(define (elog exp v-env p-env c-env k-s k-ret)
168  (cond ((stop? exp) 
169         (k-ret *proc-return*))
170        ((output? exp) 
171         (elog-output exp v-env p-env c-env k-s k-ret))
172        ((self-eval? exp) 
173         (k-s exp))
174        ((logo-literal-word? exp)
175         (elog-logo-literal-word exp v-env p-env c-env k-s k-ret))
176        ((logo-var? exp) 
177         (k-s (v-look-up (symbol<-logo-var exp) v-env)))
178        ((empty-seq? exp) 
179         (k-s *proc-return*))
180        ((seq? exp)
181         (elog-seq exp v-env p-env c-env k-s k-ret))
182        ((catch? exp)
183         (elog-catch exp v-env p-env c-env k-s k-ret))
184        ((throw? exp)
185         (elog-throw exp v-env p-env c-env k-s k-ret))
186        ((if? exp)
187         (elog-if exp v-env p-env c-env k-s k-ret))
188        ((ifelse? exp)
189         (elog-ifelse exp v-env p-env c-env k-s k-ret))
190        ((repeat? exp) 
191         (elog-repeat exp v-env p-env c-env k-s k-ret))
192        ((make? exp)
193         (elog-make exp v-env p-env c-env k-s k-ret))
194        ((proc? exp) 
195         (elog-proc exp v-env p-env c-env k-s k-ret))
196        ((sum? exp)
197         (elog-sum exp v-env p-env c-env k-s k-ret))
198        ((diff? exp)
199         (elog-diff exp v-env p-env c-env k-s k-ret))
200        ((prod? exp)
201         (elog-prod exp v-env p-env c-env k-s k-ret))
202        ((quo? exp) 
203         (elog-quo exp v-env p-env c-env k-s k-ret))
204        ((neg? exp)
205         (elog-neg exp v-env p-env c-env k-s k-ret))
206        ((power? exp) 
207         (elog-power exp v-env p-env c-env k-s k-ret))
208        ((syntax-equal? exp) 
209         (elog-syntax-equal exp v-env p-env c-env k-s k-ret))
210        ((syntax-less? exp) 
211         (elog-syntax-less exp v-env p-env c-env k-s k-ret))
212        ((syntax-greater? exp) 
213         (elog-syntax-greater exp v-env p-env c-env k-s k-ret))
214        ((call? exp) 
215         (elog-call exp v-env p-env c-env k-s k-ret))
216        (else (logo-error "unknown expression type" exp))))
217
218
219(define (elog-output exp v-env p-env c-env k-s k-ret)
220  (let ((exp1 (arg1 exp)))
221    (elog exp1 v-env p-env c-env k-ret k-ret)))
222
223(define (elog-logo-literal-word exp v-env p-env c-env k-s k-ret)
224  (let* ((str (string<-logo-literal-word exp))
225         (rstr (substring str 1 (string-length str)))
226         (result (if (string=? rstr "")
227                     (make-name "")
228                     (car (logo-lex rstr)))))
229    (k-s result)))
230
231
232(define (elog-seq exp v-env p-env c-env k-s k-ret)
233  (elog (arg1 exp)
234        v-env 
235        p-env 
236        c-env
237        (if (empty-seq? (arg2 exp))
238            (lambda (v) (k-s v))
239            (lambda (v)
240              (if (not (eq? v *proc-return*))
241                  (logo-error "You don't say what to do with" v)
242                  (elog (arg2 exp) v-env p-env c-env k-s k-ret))))
243        k-ret))
244
245(define (elog-catch exp v-env p-env c-env k-s k-ret)
246  (elog (arg1 exp)
247        v-env
248        p-env 
249        c-env
250        (lambda (name)
251          (if (logo-name? name)
252              (elog (arg2 exp)
253                    v-env
254                    p-env 
255                    c-env
256                    (lambda (rL)
257                      (if (logo-list? rL)
258                          (elog (parse rL) 
259                                v-env 
260                                p-env 
261                                (extend c-env
262                                        (list (symbol<-logo-name name))
263                                        (list k-s))
264                                k-s
265                                k-ret)
266                          (logo-error 
267                           "Catch's 2nd input should evaluate to a list")))
268                    k-ret)
269              (logo-error "Catch's first input should evaluate to a name")))
270        k-ret))
271
272(define (elog-throw exp v-env p-env c-env k-s k-ret)
273  (elog (arg1 exp)
274        v-env
275        p-env 
276        c-env
277        (lambda (name)
278          (if (logo-name? name)
279              (let ((new-k-s (c-look-up (symbol<-logo-name name) c-env)))
280                (new-k-s *proc-return*))
281              (logo-error "Throw's input should be a word")))
282        k-ret))
283
284(define (elog-sum exp v-env p-env c-env k-s k-ret)
285  (elog (arg1 exp)
286        v-env
287        p-env 
288        c-env
289        (lambda (num1)
290          (if (number? num1)
291              (elog (arg2 exp)
292                    v-env
293                    p-env 
294                    c-env
295                    (lambda (num2)
296                      (if (number? num2)
297                          (k-s (+ num1 num2))
298                          (logo-error "Inputs to + should be numbers")))
299                    k-ret)
300              (logo-error "Inputs to + should be numbers")))
301        k-ret))
302
303(define (elog-diff exp v-env p-env c-env k-s k-ret)
304  (elog (arg1 exp)
305        v-env
306        p-env 
307        c-env
308        (lambda (num1)
309          (if (number? num1)
310              (elog (arg2 exp)
311                    v-env
312                    p-env 
313                    c-env
314                    (lambda (num2)
315                      (if (number? num2)
316                          (k-s (- num1 num2))
317                          (logo-error "Inputs to - should be numbers")))
318                    k-ret)
319              (logo-error "Inputs to - should be numbers")))
320        k-ret))
321
322(define (elog-prod exp v-env p-env c-env k-s k-ret)
323  (elog (arg1 exp)
324        v-env
325        p-env 
326        c-env
327        (lambda (num1)
328          (if (number? num1)
329              (elog (arg2 exp)
330                    v-env
331                    p-env 
332                    c-env
333                    (lambda (num2)
334                      (if (number? num2)
335                          (k-s (* num1 num2))
336                          (logo-error "Inputs to * should be numbers")))
337                    k-ret)
338              (logo-error "Inputs to * should be numbers")))
339        k-ret))
340
341(define (elog-quo exp v-env p-env c-env k-s k-ret)
342  (elog (arg1 exp)
343        v-env
344        p-env 
345        c-env
346        (lambda (num1)
347          (if (number? num1)
348              (elog (arg2 exp)
349                    v-env
350                    p-env 
351                    c-env
352                    (lambda (num2)
353                      (if (number? num2)
354                          (if (not (= num2 0))
355                              (k-s (/ num1 num2))
356                              (logo-error "Divide by zero error in /"))
357                          (logo-error "Inputs to / should be numbers")))
358                    k-ret)
359              (logo-error "Inputs to / should be numbers")))
360        k-ret))
361
362(define (elog-neg exp v-env p-env c-env k-s k-ret)
363  (elog (arg1 exp)
364        v-env
365        p-env 
366        c-env
367        (lambda (num)
368          (if (number? num)
369              (k-s (- num))
370              (logo-error "Input to - should be a number")))
371        k-ret))
372
373(define (elog-power exp v-env p-env c-env k-s k-ret)
374  (elog (arg1 exp)
375        v-env
376        p-env 
377        c-env
378        (lambda (num1)
379          (if (number? num1)
380              (elog (arg2 exp)
381                    v-env
382                    p-env 
383                    c-env
384                    (lambda (num2)
385                      (if (number? num2)
386                          (if (or (and (zero? num1)
387                                       (real? num2)
388                                       (not (negative? num2)))
389                                  (not (zero? num1))
390                                  (not (real? num2)))
391                              (k-s (expt num1 num2))
392                              (logo-error "Divide by zero error in ^"))
393                          (logo-error "Inputs to ^ should be numbers")))
394                    k-ret)
395              (logo-error "Inputs to ^ should be numbers")))
396        k-ret))
397
398(define (elog-syntax-equal exp v-env p-env c-env k-s k-ret)
399  (elog (arg1 exp)
400        v-env
401        p-env 
402        c-env
403        (lambda (e1)
404          (elog (arg2 exp)
405                v-env
406                p-env 
407                c-env
408                (lambda (e2)
409                  (k-s (logo-bool<-bool (logo-equal? e1 e2))))
410                k-ret))
411        k-ret))
412
413(define (elog-syntax-less exp v-env p-env c-env k-s k-ret)
414  (elog (arg1 exp)
415        v-env
416        p-env 
417        c-env
418        (lambda (num1)
419          (if (real? num1)
420              (elog (arg2 exp)
421                    v-env
422                    p-env 
423                    c-env
424                    (lambda (num2)
425                      (if (real? num2)
426                          (k-s (if (< num1 num2) *logo-true* *logo-false*))
427                          (logo-error "Inputs to < should be real numbers")))
428                    k-ret)
429              (logo-error "Inputs to < should be real numbers")))
430        k-ret))
431
432(define (elog-syntax-greater exp v-env p-env c-env k-s k-ret)
433  (elog (arg1 exp)
434        v-env
435        p-env 
436        c-env
437        (lambda (num1)
438          (if (real? num1)
439              (elog (arg2 exp)
440                    v-env
441                    p-env 
442                    c-env
443                    (lambda (num2)
444                      (if (real? num2)
445                          (k-s (if (> num1 num2) *logo-true* *logo-false*))
446                          (logo-error "Inputs to > should be real numbers")))
447                    k-ret)
448              (logo-error "Inputs to > should be real numbers")))
449        k-ret))
450
451(define (elog-if exp v-env p-env c-env k-s k-ret)
452  (elog (arg1 exp) 
453        v-env
454        p-env 
455        c-env
456        (lambda (b)
457          (if (logo-boolean? b)
458              (if (bool<-logo-bool b)
459                  (elog (arg2 exp) 
460                        v-env 
461                        p-env 
462                        c-env
463                        (lambda (rL) 
464                          (if (logo-list? rL)
465                              (elog (parse rL) v-env p-env c-env k-s k-ret)
466                              (logo-error 
467                               "If's 2nd input should be a list")))
468                        k-ret)
469                  (k-s *proc-return*))
470              (logo-error "If's 1st input should be a Boolean")))
471        k-ret))
472
473(define (elog-ifelse exp v-env p-env c-env k-s k-ret)
474  (elog (arg1 exp) 
475        v-env
476        p-env 
477        c-env
478        (lambda (b) 
479          (if (logo-boolean? b)
480              (if (bool<-logo-bool b)
481                  (elog (arg2 exp) 
482                        v-env 
483                        p-env 
484                        c-env
485                        (lambda (rL) 
486                          (if (logo-list? rL)
487                              (elog (parse rL) v-env p-env c-env k-s k-ret)
488                              (logo-error "Ifelse's 2nd input should be a list")))
489                        k-ret)
490                  (elog (arg3 exp) 
491                        v-env 
492                        p-env 
493                        c-env
494                        (lambda (rL) 
495                          (if (logo-list? rL)
496                              (elog (parse rL) v-env p-env c-env k-s k-ret)
497                              (logo-error "Ifelse's 3rd input should be a list")))
498                        k-ret))
499              (logo-error "Ifelse's 1st input should be a Boolean")))
500        k-ret))
501
502(define (elog-repeat exp v-env p-env c-env k-s k-ret)
503  (elog (arg1 exp)
504        v-env 
505        p-env 
506        c-env
507        (lambda (num)
508          (if (and (number? num) (<= 0 num))
509              (elog (arg2 exp)
510                    v-env 
511                    p-env 
512                    c-env
513                    (lambda (rL)
514                      (if (logo-list? rL)
515                          (let ((run-exp (parse rL)))
516                            (letrec ((k-rep
517                                      (lambda (v)
518                                        (if (not (eq? v *proc-return*))
519                                            (logo-error 
520                                             "You don't say what to do with" v)
521                                            (begin
522                                              (set! num (- num 1))
523                                              (if (= num 0)
524                                                  (k-s *proc-return*)
525                                                  (elog run-exp
526                                                        v-env 
527                                                        p-env 
528                                                        c-env 
529                                                        k-rep
530                                                        k-ret)))))))
531                              (if (= num 0)
532                                  (k-s *proc-return*)
533                                  (elog run-exp
534                                        v-env 
535                                        p-env 
536                                        c-env 
537                                        k-rep
538                                        k-ret))))
539                          (logo-error 
540                           "Repeat's 2nd input should be a list")))
541                    k-ret)
542              (logo-error 
543               "Repeat's 1st input should be a number")))
544        k-ret))
545
546(define (elog-make exp v-env p-env c-env k-s k-ret)
547  (elog (arg1 exp)
548        v-env 
549        p-env 
550        c-env
551        (lambda (name)
552          (if (logo-name? name)
553              (elog (arg2 exp)
554                    v-env 
555                    p-env 
556                    c-env
557                    (lambda (val)
558                      (update! v-env (symbol<-logo-name name) val)
559                      (k-s *proc-return*))
560                    k-ret)
561              (logo-error 
562               "Make expects its first input to be a variable name")))
563        k-ret))
564
565(define (elog-proc exp v-env p-env c-env k-s k-ret)
566  (let* ((name (symbol<-logo-name (arg1 exp)))
567         (formals (map symbol<-logo-var (arg2 exp)))
568         (unparsed-body (arg3 exp))
569         (code (lambda (args v-env p-env c-env k-ret)
570                 (elog (parse unparsed-body)
571                       (extend v-env formals args)
572                       p-env
573                       c-env
574                       k-ret
575                       k-ret)))
576         (obj (make-user-proc code exp)))
577    (update! p-env name obj)
578    (k-s *proc-return*)))
579
580(define (elog-call exp v-env p-env c-env k-s k-ret)
581  (let* ((proc-entry (p-look-up (symbol<-logo-name (arg1 exp)) p-env))
582         (code (code<-logo-proc-entry proc-entry)))
583    (if (and (logo-user-proc? proc-entry)
584             (< (length (arg2 exp)) (get-logo-arity (arg1 exp))))
585        (logo-error (arg1 exp) "got too few inputs")
586        (elog-args (arg2 exp)
587                   v-env 
588                   p-env 
589                   c-env
590                   (lambda (args) (code args v-env p-env c-env k-s))
591                   k-ret))))
592
593(define (elog-args exps v-env p-env c-env k-s k-ret)
594  (if (null? exps)
595    (k-s '())
596    (elog (car exps) 
597          v-env 
598          p-env
599          c-env
600          (lambda (v)
601            (if (eq? v *proc-return*)
602              (logo-error "the caller was expecting a value")
603              (elog-args (cdr exps)
604                         v-env
605                         p-env 
606                         c-env
607                         (lambda (L) (k-s (cons v L)))
608                         k-ret)))
609          k-ret)))
610                           
611(define (read-paragraph)
612  (let loop ((p "")
613             (s (read-line (current-input-port))))
614    (if (= (string-length s) 0)
615        p
616        (loop (string-append p " " s)
617               (read-line (current-input-port))))))
618
619(define (logo)
620  (display "?")
621  (let* ((input (read-paragraph))
622         (pinput (parse (logo-lex input)))
623         (result
624          (elog pinput *init-var-env* 
625                       *init-proc-env* 
626                       *init-catch-env*
627                       (lambda (v) v) 
628                       (lambda (v) v))))
629    (if (eq? result *proc-return*)
630      (logo)
631      (logo-error "You don't say what to do with" result))))
632
633(define *logo-reset-cont* 'dummy-val)
634
635(define (logo-error . messages)
636  (for-each (lambda (message)
637              (if (or (number? message)
638                      (tword? message)
639                      (logo-list? message))
640                (begin (logo-show message)
641                       (display " "))
642                (begin (display message)
643                       (display " "))))
644            messages)
645  (newline)
646  (logo-reset))
647
648
649(define (logo-reset) (*logo-reset-cont* 'dummy-val))
650
651(define (go-logo)
652  (display "Welcome to Arthur Nunes-Harwitt's Classic Logo")
653  (newline)
654  (call-with-current-continuation
655   (lambda (k)
656     (set! *logo-reset-cont* k)))
657  (logo))
Note: See TracBrowser for help on using the repository browser.