PasteRack.org
Paste # 33642
2025-04-27 08:51:18

Fork as a new paste.

Paste viewed 389 times.


Embed:

evaluate-cps

  1. #lang racket
  2.  
  3. (define primitives
  4.   (make-hash `((+ . ,+)
  5.                (- . ,-)
  6.                (* . ,*)
  7.                (/ . ,/)
  8.                (> . ,>)
  9.                (< . ,<)
  10.                (= . ,=))))
  11.  
  12. (define (make-base-environment)
  13.   (list primitives))
  14.  
  15. (define (make-empty-frame)
  16.   (make-hash))
  17.  
  18. (define (extend-current-frame env symbol value)
  19.   (hash-set! (car env) symbol value))
  20.  
  21. (define (push-frame env)
  22.   (cons (make-empty-frame) env))
  23.  
  24. (define (lookup-env env symbol)
  25.   (let loop ([frames env])
  26.     (cond
  27.       [(null? frames)
  28.        (error 'evaluate "failed to find symbol: ~a" symbol)]
  29.       [(hash-has-key? (car frames) symbol)
  30.        (hash-ref (car frames) symbol)]
  31.       [else (loop (cdr frames))])))
  32.  
  33. (define (evaluate-cps expr env cont)
  34.   (match expr
  35.     [(? number?) (cont expr)]
  36.     [(? boolean?) (cont expr)]
  37.     [(? symbol?) (cont (lookup-env env expr))]
  38.     [`(define ,name ,val-expr)
  39.       (evaluate-cps
  40.         val-expr
  41.         env
  42.         (lambda (val)
  43.           (extend-current-frame env name val)
  44.           (cont val)))]
  45.     [`(if ,cond ,then-expr ,else-expr)
  46.       (evaluate-cps
  47.         cond
  48.         env
  49.         (lambda (cond-result)
  50.           (if cond-result
  51.             (evaluate-cps then-expr env cont)
  52.             (evaluate-cps else-expr env cont))))]
  53.     [`(fn (,name ,params ...) ,body)
  54.       (letrec ([proc (lambda args
  55.                        (let ([new-env (push-frame env)])
  56.                          (extend-current-frame new-env name proc)
  57.                          (for ([param params]
  58.                                [arg args])
  59.                            (extend-current-frame new-env param arg))
  60.                          (evaluate-cps body new-env cont)))])
  61.         (extend-current-frame env name proc)
  62.         (cont proc))]
  63.     [`(,func ,args ...)
  64.       (if (hash-has-key? primitives func)
  65.         (evaluate-args-cps args env (lambda (args-vals) (cont (apply (hash-ref primitives func) args-vals))))
  66.         (evaluate-cps
  67.           func
  68.           env
  69.           (lambda (f-val)
  70.             (evaluate-args-cps args env (lambda (args-vals) (apply f-val (append args-vals '(cont))))))))]))
  71.  
  72. (define (evaluate-args-cps exprs env cont)
  73.   (match exprs
  74.     ['() (cont '())]
  75.     [(cons x xs)
  76.      (evaluate-cps x env (lambda (v) (evaluate-args-cps xs env (lambda (vs) (cont (cons v vs))))))]))
  77.  
  78. (define env (make-base-environment))
  79.  
  80. (define (halt expr)
  81.   expr)
  82.  
  83. (define (evaluate expr env)
  84.   (evaluate-cps expr env halt))
  85.  
  86. (evaluate '(fn (foo a b c) b) env)
  87. (evaluate '(foo 1 2 3) env)
  88. (evaluate '(+ 1 2 3) env)
  89. (evaluate '(fn (fact n) (if (= n 1) n (* n (fact (- n 1))))) env)
  90. (evaluate '(fact 4) env)

=>

#<procedure:proc>

2

6

#<procedure:proc>

24