PasteRack.org
Paste # 9350
2019-12-21 01:02:38

Fork as a new paste.

Paste viewed 593 times.


Embed:

  1. #lang racket
  2. ;;
  3. ;; eval.scm - 6.037
  4. ;;
  5. ; NOTE (load-meval-defs)
  6. ;      (driver-loop)
  7. (require r5rs)
  8. (define first car)
  9. (define second cadr)
  10. (define third caddr)
  11. (define fourth cadddr)
  12. (define rest cdr)
  13. ;; Tell DrRacket to print mutable pairs using the compact syntax for
  14. ;; ordinary pairs.
  15. (print-as-expression #f)
  16. (print-mpair-curly-braces #f)
  17.  
  18. ;; mutable cons cell version of map
  19. (define (mmap f lst)
  20.   (if (null? lst)
  21.       '()
  22.       (cons (f (car lst)) (mmap f (cdr lst)))))
  23.  
  24. (define (tagged-list? exp tag)
  25.   (and (pair? exp) (eq? (car exp) tag)))
  26.  
  27. (define (self-evaluating? exp)
  28.   (cond ((number? exp) #t)
  29.         ((string? exp) #t)
  30.         ((boolean? exp) #t)
  31.         (else #f)))
  32.  
  33. (define (quoted? exp) (tagged-list? exp 'quote))
  34. (define (text-of-quotation exp) (cadr exp))
  35.  
  36. (define (variable? exp) (symbol? exp))
  37. (define (assignment? exp) (tagged-list? exp 'set!))
  38. (define (assignment-variable exp) (cadr exp))
  39. (define (assignment-value exp) (caddr exp))
  40. (define (make-assignment var expr)
  41.   (list 'set! var expr))
  42.  
  43. (define (definition? exp) (tagged-list? exp 'define))
  44. (define (definition-variable exp)
  45.   (if (symbol? (cadr exp))   (cadr exp)   (caadr exp)))
  46. (define (definition-value exp)
  47.   (if (symbol? (cadr exp))
  48.       (caddr exp)
  49.       (make-lambda (cdadr exp) (cddr exp))))  ; formal params, body
  50. (define (make-define var expr)
  51.   (list 'define var expr))
  52. ; HW14P2 +
  53. (define (make-define-proc name params expr)
  54.   (make-define (list name (first params) (second params)) expr))
  55.  
  56. (define (lambda? exp) (tagged-list? exp 'lambda))
  57. (define (lambda-parameters lambda-exp) (cadr lambda-exp))
  58. (define (lambda-body lambda-exp) (cddr lambda-exp))
  59. (define (make-lambda parms body) (cons 'lambda (cons parms body)))
  60.  
  61. (define (if? exp) (tagged-list? exp 'if))
  62. (define (if-predicate exp) (cadr exp))
  63. (define (if-consequent exp) (caddr exp))
  64. (define (if-alternative exp) (cadddr exp))
  65. (define (make-if pred conseq alt) (list 'if pred conseq alt))
  66.  
  67. (define (cond? exp) (tagged-list? exp 'cond))
  68. (define (cond-clauses exp) (cdr exp))
  69. (define first-cond-clause car)
  70. (define rest-cond-clauses cdr)
  71. (define (make-cond seq) (cons 'cond seq))
  72.  
  73. (define (let? expr) (tagged-list? expr 'let))
  74. (define (let-bound-variables expr) (mmap first (second expr)))
  75. (define (let-values expr) (mmap second (second expr)))
  76. (define (let-body expr) (cddr expr)) ;differs from lecture--body may be a sequence
  77. (define (make-let bindings body)
  78.   (cons 'let (cons bindings body)))
  79.  
  80. (define (begin? exp) (tagged-list? exp 'begin))
  81. (define (begin-actions begin-exp) (cdr begin-exp))
  82. (define (last-exp? seq) (null? (cdr seq)))
  83. (define (first-exp seq) (car seq))
  84. (define (rest-exps seq) (cdr seq))
  85. (define (sequence->exp seq)
  86.   (cond ((null? seq) seq)
  87.         ((last-exp? seq) (first-exp seq))
  88.         (else (make-begin seq))))
  89. (define (make-begin exp) (cons 'begin exp))
  90.  
  91. (define (application? exp) (pair? exp))
  92. (define (operator app) (car app))
  93. (define (operands app) (cdr app))
  94. (define (no-operands? args) (null? args))
  95. (define (first-operand args) (car args))
  96. (define (rest-operands args) (cdr args))
  97. (define (make-application rator rands)
  98.   (cons rator rands))
  99.  
  100. (define (time? exp) (tagged-list? exp 'time))
  101.  
  102. (define (or? exp) (tagged-list? exp 'or))
  103. (define (or-args exp) (cdr exp))
  104. (define (make-or args) (cons 'or args))
  105.  
  106. (define (and? exp) (tagged-list? exp 'and))
  107. (define (and-args exp) (cdr exp))
  108.  
  109. ; HW14P3 +
  110. (define (while? exp) (tagged-list? exp 'while))
  111. (define (while-test exp) (cadr exp))
  112. (define (while-body exp) (cddr exp))
  113.  
  114. ;;
  115. ;; this section is the actual implementation of meval
  116. ;;
  117.  
  118. (define (m-eval exp env)
  119.   (cond ((self-evaluating? exp) exp)
  120.         ((variable? exp) (lookup-variable-value exp env))
  121.         ((quoted? exp) (text-of-quotation exp))
  122.         ((assignment? exp) (eval-assignment exp env))
  123.         ((definition? exp) (eval-definition exp env))
  124.         ((if? exp) (eval-if exp env))
  125.         ;((or? exp) (m-eval (or->if exp) env))
  126.         ((and? exp) (m-eval (and->if exp) env))
  127.         ((or? exp) (eval-or exp env))
  128.         ((while? exp) (eval-while exp env))
  129.         ((lambda? exp)
  130.          (make-procedure (lambda-parameters exp) (lambda-body exp) env))
  131.         ((begin? exp) (eval-sequence (begin-actions exp) env))
  132.         ((cond? exp) (m-eval (cond->if exp) env))
  133.         ((let? exp) (m-eval (let->application exp) env))
  134.         ((time? exp) (time (m-eval (second exp) env)))
  135.         ((application? exp)
  136.          (m-apply (m-eval (operator exp) env)
  137.                   (list-of-values (operands exp) env)))
  138.         (else (error "Unknown expression type -- EVAL" exp))))
  139.  
  140. ; HW12P4 +
  141. (define (or->if exp)
  142.   (define (loop args)
  143.     (cond
  144.       [(null? args) #f]
  145.       [(null? (cdr args)) (car args)]
  146.       [else (make-if (car args) (car args) (loop (cdr args)))]))
  147.   (loop (or-args exp)))
  148.  
  149. (define (and->if exp)
  150.   (define (loop args)
  151.     (cond
  152.       [(null? args) #t]
  153.       [(null? (cdr args)) (car args)]
  154.       [else (make-if (car args) (loop (cdr args)) (car args))]))
  155.   (loop (and-args exp)))
  156.  
  157. (define (eval-or exp env)
  158.   (define (loop args)
  159.     (if (null? args)
  160.         #f
  161.         (let ([v (m-eval (car args) env)])
  162.           (if v
  163.               v
  164.               (loop (cdr args))))))
  165.   (loop (cdr exp)))
  166.  
  167. (define (eval-while exp env)
  168.   (if (m-eval (while-test exp) env)
  169.       (begin
  170.         (eval-sequence (while-body exp) env)
  171.         (eval-while exp env))
  172.       (void)))
  173.  
  174. (define (fibonacci n)
  175.   (cond ((= n 0) 0)
  176.         ((= n 1) 1)
  177.         (else (+ (fibonacci (- n 1)) (fibonacci (- n 2))))))
  178.  
  179. (define (time-fibonacci)
  180.   (time (fibonacci 21))) ; if n > 20 time not null
  181.  
  182. ;(define (fibonacci-iter-timed)
  183. ;  (time
  184. ;   (let ([n 8000]) ; cpu time not null
  185. ;  (define (fibo-iter current previous index)
  186. ;    (if (< index n) (fibo-iter (+ current previous) current (+ index 1))
  187. ;        current))
  188. ;  (cond ((= n 0) 0)
  189. ;        ((= n 1) 1)
  190. ;        (else (fibo-iter 1 0 1))))))
  191.  
  192. ; TEST
  193. ; in (driver-loop)
  194. ;(let ([x 0])
  195. ;(while (< x 5)
  196. ; (display x)
  197. ; (newline)
  198. ; (set! x (+ x 1))))
  199.  
  200. (define (m-apply procedure arguments)
  201.   (cond ((primitive-procedure? procedure)
  202.          (apply-primitive-procedure procedure arguments))
  203.         ((compound-procedure? procedure)
  204.          (eval-sequence
  205.           (procedure-body procedure)
  206.           (extend-environment (make-frame (procedure-parameters procedure)
  207.                                           arguments)
  208.                               (procedure-environment procedure))))
  209.         (else (error "Unknown procedure type -- APPLY" procedure))))
  210.  
  211. (define (list-of-values exps env)
  212.   (cond ((no-operands? exps) '())
  213.         (else (cons (m-eval (first-operand exps) env)
  214.                     (list-of-values (rest-operands exps) env)))))
  215.  
  216. (define (eval-if exp env)
  217.   (if (m-eval (if-predicate exp) env)
  218.       (m-eval (if-consequent exp) env)
  219.       (m-eval (if-alternative exp) env)
  220.       ))
  221.  
  222. (define (eval-sequence exps env)
  223.   (cond ((last-exp? exps) (m-eval (first-exp exps) env))
  224.         (else (m-eval (first-exp exps) env)
  225.               (eval-sequence (rest-exps exps) env))))
  226.  
  227. (define (eval-assignment exp env)
  228.   (set-variable-value! (assignment-variable exp)
  229.                        (m-eval (assignment-value exp) env)
  230.                        env))
  231.  
  232. (define (eval-definition exp env)
  233.   (define-variable! (definition-variable exp)
  234.     (m-eval (definition-value exp) env)
  235.     env))
  236.  
  237. (define (let->application expr)
  238.   (let ((names (let-bound-variables expr))
  239.         (values (let-values expr))
  240.         (body (let-body expr)))
  241.     (make-application (make-lambda names body)
  242.                       values)))
  243.  
  244. (define (cond->if expr)
  245.   (let ((clauses (cond-clauses expr)))
  246.     (if (null? clauses)
  247.         #f
  248.         (if (eq? (car (first-cond-clause clauses)) 'else)
  249.             (sequence->exp (cdr (first-cond-clause clauses)))
  250.             (make-if (car (first-cond-clause clauses))
  251.                      (sequence->exp (cdr (first-cond-clause clauses)))
  252.                      (make-cond (rest-cond-clauses clauses)))))))
  253.  
  254. (define input-prompt ";;; M-Eval input level ")
  255. (define output-prompt ";;; M-Eval value:")
  256.  
  257. (define (driver-loop) (repl #f))
  258.  
  259. (define (repl port)
  260.   (if port #f (prompt-for-input input-prompt))
  261.   (let ((input (if port (read port) (read))))
  262.     (cond ((eof-object? input)   'meval-done)
  263.           ((eq? input '**quit**) 'meval-done)
  264.           (else
  265.            (let ((output (m-eval input the-global-environment)))
  266.              (if port #f (begin
  267.                            (announce-output output-prompt)
  268.                            (pretty-display output)))
  269.              (repl port))))))
  270.  
  271. (define (prompt-for-input string)
  272.   (newline) (newline) (display string) (display meval-depth) (newline))
  273.  
  274. (define (announce-output string)
  275.   (newline) (display string) (newline))
  276.  
  277.  
  278. ;;
  279. ;;
  280. ;; implementation of meval environment model
  281. ;;
  282.  
  283. ; double bubbles
  284. (define (make-procedure parameters body env)
  285.   (list 'procedure parameters body env))
  286. (define (compound-procedure? proc)
  287.   (tagged-list? proc 'procedure))
  288. (define (procedure-parameters proc) (second proc))
  289. (define (procedure-body proc) (third proc))
  290. (define (procedure-environment proc) (fourth proc))
  291.  
  292.  
  293. ; bindings
  294. (define (make-binding var val)
  295.   (list 'binding var val))
  296. (define (binding? b)
  297.   (tagged-list? b 'binding))
  298. (define (binding-variable binding)
  299.   (if (binding? binding)
  300.       (second binding)
  301.       (error "Not a binding: " binding)))
  302. (define (binding-value binding)
  303.   (if (binding? binding)
  304.       (third binding)
  305.       (error "Not a binding: " binding)))
  306. (define (set-binding-value! binding val)
  307.   (if (binding? binding)
  308.       (set-car! (cddr binding) val)
  309.       (error "Not a binding: " binding)))
  310.  
  311. ; frames
  312. (define (make-frame variables values)
  313.   (define (make-frame-bindings rest-vars rest-vals)
  314.     (cond ((and (null? rest-vars) (null? rest-vals))
  315.            '())
  316.           ((null? rest-vars)
  317.            (error "Too many args supplied" variables values))
  318.           ((symbol? rest-vars)
  319.            (list (make-binding rest-vars rest-vals)))
  320.           ((null? rest-vals)
  321.            (error "Too few args supplied" variables values))
  322.           (else
  323.            (cons (make-binding (car rest-vars) (car rest-vals))
  324.                  (make-frame-bindings (cdr rest-vars) (cdr rest-vals))))))
  325.   (make-frame-from-bindings (make-frame-bindings variables values)))
  326.  
  327. (define (make-frame-from-bindings list-of-bindings)
  328.   (cons 'frame list-of-bindings))
  329.  
  330. (define (frame? frame)
  331.   (tagged-list? frame 'frame))
  332. (define (frame-variables frame)
  333.   (if (frame? frame)
  334.       (mmap binding-variable (cdr frame))
  335.       (error "Not a frame: " frame)))
  336. (define (frame-values frame)
  337.   (if (frame? frame)
  338.       (mmap binding-value (cdr frame))
  339.       (error "Not a frame: " frame)))
  340. (define (add-binding-to-frame! binding frame)
  341.   (if (frame? frame)
  342.       (if (binding? binding)
  343.           (set-cdr! frame (cons binding (cdr frame)))
  344.           (error "Not a binding: " binding))
  345.       (error "Not a frame: " frame)))
  346. (define (find-in-frame var frame)
  347.   (define (search-helper var bindings)
  348.     (if (null? bindings)
  349.         #f
  350.         (if (eq? var (binding-variable (first bindings)))
  351.             (first bindings)
  352.             (search-helper var (rest bindings)))))
  353.   (if (frame? frame)
  354.       (search-helper var (cdr frame))
  355.       (error "Not a frame: " frame)))
  356.  
  357. ; environments
  358. (define the-empty-environment '(environment))
  359. (define (extend-environment frame base-env)
  360.   (if (environment? base-env)
  361.       (if (frame? frame)
  362.           (list 'environment frame base-env)
  363.           (error "Not a frame: " frame))
  364.       (error "Not an environment: " base-env)))
  365. (define (environment? env)
  366.   (tagged-list? env 'environment))
  367. (define (enclosing-environment env)
  368.   (if (environment? env)
  369.       (if (eq? the-empty-environment env)
  370.           (error "No enclosing environment of the empty environment")
  371.           (third env))
  372.       (error "Not an environment: " env)))
  373. (define (environment-first-frame env)
  374.   (if (environment? env)
  375.       (second env)
  376.       (error "Not an environment: " env)))
  377. (define (find-in-environment var env)
  378.   (if (eq? env the-empty-environment)
  379.       #f
  380.       (let ((frame (environment-first-frame env)))
  381.         (let ((binding (find-in-frame var frame)))
  382.           (if binding
  383.               binding
  384.               (find-in-environment var (enclosing-environment env)))))))
  385.  
  386.  
  387. ; name rule
  388. (define (lookup-variable-value var env)
  389.   (let ((binding (find-in-environment var env)))
  390.     (if binding
  391.         (binding-value binding)
  392.         (error "Unbound variable -- LOOKUP" var))))
  393.  
  394. (define (set-variable-value! var val env)
  395.   (let ((binding (find-in-environment var env)))
  396.     (if binding
  397.         (set-binding-value! binding val)
  398.         (error "Unbound variable -- SET" var))))
  399.  
  400. (define (define-variable! var val env)
  401.   (let ((frame (environment-first-frame env)))
  402.     (let ((binding (find-in-frame var frame)))
  403.       (if binding
  404.           (set-binding-value! binding val)
  405.           (add-binding-to-frame!
  406.            (make-binding var val)
  407.            frame)))))
  408.  
  409. ; primitives procedures - hooks to underlying Scheme procs
  410. (define (make-primitive-procedure implementation)
  411.   (list 'primitive implementation))
  412. (define (primitive-procedure? proc) (tagged-list? proc 'primitive))
  413. (define (primitive-implementation proc) (cadr proc))
  414. (define (primitive-procedures)
  415.   (list (list 'car car)
  416.         (list 'cdr cdr)
  417.         (list 'cadr cadr)
  418.         (list 'cddr cddr)
  419.         (list 'caadr caadr)
  420.         (list 'cdadr cdadr)
  421.         (list 'cdddr cdddr)
  422.         (list 'caddr caddr)
  423.         (list 'cadddr cadddr)
  424.         (list 'list list)
  425.         (list 'cons cons)
  426.         (list 'set-car! set-car!)
  427.         (list 'set-cdr! set-cdr!)
  428.         (list 'null? null?)
  429.         (list 'symbol? symbol?)
  430.         (list 'pair? pair?)
  431.         (list 'eq? eq?)
  432.         (list 'number? number?)
  433.         (list 'string? string?)
  434.         (list 'boolean? boolean?)
  435.  
  436.         (list '+ +)
  437.         (list '- -)
  438.         (list '* *)
  439.         (list '/ /)
  440.         (list '< <)
  441.         (list '> >)
  442.         (list '= =)
  443.  
  444.         (list 'display display)
  445.         (list 'newline newline)
  446.  
  447.         (list 'not not)
  448.         ; ... more primitives
  449.         ))
  450.  
  451. (define (primitive-procedure-names) (mmap car (primitive-procedures)))
  452.  
  453. (define (primitive-procedure-objects)
  454.   (mmap make-primitive-procedure (mmap cadr (primitive-procedures))))
  455.  
  456. (define (apply-primitive-procedure proc args)
  457.   (apply (primitive-implementation proc) args))
  458.  
  459. ; used to initialize the environment
  460. (define (setup-environment)
  461.   (extend-environment (make-frame (primitive-procedure-names)
  462.                                   (primitive-procedure-objects))
  463.                       the-empty-environment))
  464.  
  465. (define the-global-environment (setup-environment))
  466.  
  467.  
  468.  
  469. ;;;;;;;; Code necessary for question 6
  470. ;;
  471. ;; This section doesn't contain any user-servicable parts -- you
  472. ;; shouldn't need to edit it for any of the questions on the project,
  473. ;; including question 5.  However, if you're curious, comments provide a
  474. ;; rough outline of what it does.
  475.  
  476. ;; Keep track of what depth we are into nesting
  477. (define meval-depth 1)
  478.  
  479. ;; These procedures are needed to make it possible to run inside meval
  480. (define additional-primitives
  481.   (list (list 'eof-object?      eof-object?)
  482.         (list 'read             read)
  483.         (list 'read-line        read-line)
  484.         (list 'open-input-file  open-input-file)
  485.         (list 'this-expression-file-name
  486.               (lambda () (this-expression-file-name)))
  487.         (list 'pretty-display   pretty-display)
  488.         (list 'error            error)
  489.         (list 'apply            m-apply))) ;; <-- This line is somewhat interesting
  490. (define stubs
  491.   '(require r5rs mzlib/etc print-as-expression print-mpair-curly-braces))
  492. (define additional-names (mmap first additional-primitives))
  493. (define additional-values (mmap make-primitive-procedure
  494.                                 (mmap second additional-primitives)))
  495.  
  496. (require mzlib/etc)
  497. (define (load-meval-defs)
  498.   ;; Jam some additional bootstrapping structures into the global
  499.   ;; environment
  500.   (set! the-global-environment
  501.         (extend-environment
  502.          (make-frame stubs
  503.                      (mmap (lambda (name)
  504.                              (m-eval '(lambda (x) x) the-global-environment)) stubs))
  505.          (extend-environment
  506.           (make-frame additional-names
  507.                       additional-values)
  508.           the-global-environment)))
  509.   ;; Open this file for reading
  510.   (let ((stream (open-input-file (this-expression-file-name))))
  511.     (read-line stream) ;; strip off "#lang racket" line
  512.     (repl stream))     ;; feed the rest of the definitions into meval
  513.  
  514.   ;; Update the meval-depth variable inside the environment we're simulating
  515.   (set-variable-value! 'meval-depth (+ meval-depth 1) the-global-environment)
  516.   'loaded)

=>