2010.01.24 10:42

taoi-part1 -session2

이제 다시 손으로 생각해 보자.
driver-loop를 변경해 본다. 

(define (driver)
  (driver-loop '(((+ - * = eq? cons car cdr null? ) + - * = eq? cons car cdr null?)) (display '|LITHP ITH LITHTENING|))
  )

(define (driver-loop env hunoz)
  (driver-loop-1 env (read)))

(define (driver-loop-1 env form  )
  (cond ((not (list? form ))    
         (driver-loop env (display (mceval form env))))
        ((eq? (car form ) 'define)
         (driver-loop (bind (list (caadr form ))
                             (list (list '&procedure (cdadr form) (caddr form ))) 
                                   env)
                      (display (caadr form ))))
        (#t (driver-loop  (display (mceval form env)))) 
        
     )
 )

변경된 driver-loop를 돌려보자.

디버그 모드에서 ( define (f a b) (+ a b))를 입력하면 다음과 같이 표시된다. 
 

-->env => {{{f} {&procedure {a b} {+ a b}}} {{+ - * = eq? cons car cdr null?} + - * = eq? cons car cdr null?}}

원하는 대로 된 것 같다. 

그런데 eval 의 코드가 바뀌어서 #t #f 를 변수로 만들어 주어야 한다. 드라이버에서 처음으로 주어지는 프리미티브를 바꾸어 주어야 한다. 예전의 procedure 때와 같은 모습이다. 

(define (driver)
  (driver-loop '(((+ - * = eq? cons car cdr null? #t #f ) + - * = eq? cons car cdr null? #t #f)) (display '|LITHP ITH LITHTENING|))
  )


mceva 과 mcapply  evlis evcon 모두 바뀌었다. 대신 지난번의 설비 lookup 이나 bind 같은 것들은 변한 것이 없다.

기념으로 다시 factorial 을 돌려보자. 

(driver)

LITHP ITH LITHTENING

(define (factorial n)
  (cond  ((= n 1)       1)
      (#t  (* (factorial (- n 1)) n))))
-->factorial

(factorial 10)
-->3628800

그리고 중요한 변화로 mapcar 처럼 데이타와  프로시저를 변수 구별하지 않는다. 

(driver)
LITHP ITH LITHTENING

(define (square x) (* x x))
-->square

(define (mapcar fun lst)
(cond ((null? lst)  '())
(#t (cons (fun (car lst)) (mapcar fun (cdr lst))))))
--->mapcar

(mapcar square '(1 2 3) )
-->(1 4 9)

일단 테스트할 수 있는 정도로는 충분하다!
다음번에는 동적 바인딩에 대해 조금 더 살펴 보기로 하자.

소스 코드는 지난번과 거의 같다. 

(define (bind vars vals base-env)
  (if (= (length vars) (length vals))
      (cons (cons  vars vals) base-env)
      (if (< (length vars) (length vals))
          (display 'error Too many arguments supplied)
          (display 'error Too few arguments supplied ))))

(define (value name env)
  (value1 name (lookup name env))
    )

(define (value1 name slot )
  ( cond ((eq? slot '&UNBOUND) (display 'errorunbound))
         (else (car slot))
   )
  )

(define (lookup name env)
  (cond ((null? env ) '&UNBOUND)
        (else (lookup1 name (caar env) (cdar env) env))))
  
(define (lookup1 name vars vals env)
  
      (cond ((null? vars)
             (lookup name (cdr env) ))
            
            ((eq? name (car vars)) vals)
            (else (lookup1 name (cdr vars) (cdr vals) env))))
    


(define (driver)
  (driver-loop '(((+ - * = eq? cons car cdr null? #t #f ) + - * = eq? cons car cdr null? #t #f)) (display '|LITHP ITH LITHTENING|))
  )

(define (driver-loop env hunoz)
  (driver-loop-1 env (read)))

(define (driver-loop-1 env form  )
  (cond ((not (list? form ))    
         (driver-loop env (display (mceval form env))))
        ((eq? (car form ) 'define)
         (driver-loop (bind (list (caadr form ))
                             (list (list '&procedure (cdadr form) (caddr form ))) 
                                   env)
                      (display (caadr form ))))
        (#t (driver-loop  env (display (mceval form env)))) 
        
     )
 )


(define (mceval exp env )
  (cond ((not (list? exp)) ;;atom exp
        ( cond
           ((number? exp ) exp)
           (else  (value exp env))
         ))
     
        ((eq? (car exp) 'quote)  (cadr exp))
        ((eq? (car exp) 'cond) ( evcond (cdr exp)  env ))
       
        (else
         (mcapply (value (car exp)  env)
                (evlis (cdr exp)  env )
              env) )))

(define (evcond clauses env  )

    (cond ((null? clauses) 'error)
          ((mceval (caar clauses) env )
           (mceval (cadar clauses) env ))
      (else (evcond (cdr clauses) env  ))))

(define (mcapply fun args env  )
  (cond ((primeop? fun) (primeop-apply  fun args))
        ((eq? (car fun) '&procedure) (mceval (caddr fun) (bind (cadr fun) args env))) 
        (else 'error-mcapply )  ))

(define (evlis  arglist env  )        ;map evaluator over list

    (cond ((null? arglist) '())

          (else (cons (mceval (car arglist) env )

                      (evlis (cdr arglist) env )))))

(define (primeop? fun)
  (or (eq? fun '+)
      (eq? fun '-)
      (eq? fun '/)
      (eq? fun '*)
       (eq? fun '=)
      (eq? fun 'eq?)
      (eq? fun 'car)
      (eq? fun 'cdr)
      (eq? fun 'cons)
      (eq? fun 'null?)
     
      ;; more
      ))

(define (primeop-apply fun args)
 (cond ( (eq? fun '+ ) (+ (car args) (cadr args)))
       ( (eq? fun '- ) (- (car args) (cadr args)))
       ( (eq? fun '* ) (* (car args) (cadr args)))
       ( (eq? fun '/ ) (/ (car args) (cadr args)))
       ( (eq? fun '= ) (= (car args) (cadr args)))
       ( (eq? fun 'eq? ) (eq? (car args) (cadr args)))
       ( (eq? fun 'cons ) (cons (car args) (cadr args)))
       ( (eq? fun 'car ) (car (car args)))
       ( (eq? fun 'cdr ) (cdr (car args)))
       ( (eq? fun 'null?) (null? (car args)))
      ; ( (eq? fun 'atom ) (* (car args) (cadr args)))
      ; ( (eq? fun '* ) (* (car args) (cadr args)))
        ))

Trackback 0 Comment 0


티스토리 툴바