API tools faq
paste
Advertisement
timothy235

sicp-4-1-7-repl-program

timothy235
Mar 16th, 2017
185
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Racket 20.49 KB | None | 0 0
raw download clone embed print report
  1. #lang racket
  2. (require racket/mpair)
  3. (provide (all-defined-out))
  4.  
  5. ;; This is the repl program through the end of section 4.1.7.  Syntactic analysis has
  6. ;; been separated from evaluation, and letrec has been added.  Use
  7. ;; "4-1-7-repl-test.rkt" to test basic functionality.
  8.  
  9. ;; NOTES:
  10.  
  11. ;; 1. Environments are mutable lists.  All other lists are regular immutable lists.
  12. ;; 2. We use the implementation for frames from exercises 4.11 and 4.12.
  13. ;; 3. Book terms that shadow Racket built-ins are prefixed with my-.
  14. ;; 4. The alternate cond test, when true, will be inefficiently evaluated twice.
  15. ;; 5. The body of a lambda or let statement can be a sequence.
  16. ;; 6. '*unassigned* is a self-evaluating reserved symbol, used to implement letrec.
  17. ;; 7. scan-out-defines has been moved from procedure-body, which is now a procedure
  18.     ;; and not an expression, to analyze-lambda.
  19.  
  20. ;; PROGRAM SECTIONS:
  21.  
  22. ;; 1. my-eval and analyze
  23. ;; 2. self-evaluating expressions, variables, and quotations
  24. ;; 3. definition and assignment
  25. ;; 4. lambdas, procedures and applications
  26. ;; 5. sequences and begin expressions
  27. ;; 6. boolean expressions
  28. ;; 7. if and cond expressions
  29. ;; 8. let, let*, named-let, and letrec
  30. ;; 9. environment and frames
  31. ;; 10. primitive procedures and the global environment
  32. ;; 11. repl operations
  33.  
  34. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  35. ;; 1. MY-EVAL AND ANALYZE  ;;
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37.  
  38. (define (my-eval expr env)
  39.   ((analyze expr) env))
  40.  
  41. (define (analyze expr)
  42.   (cond [(self-evaluating? expr)
  43.          (analyze-self-evaluating expr)]
  44.         [(quoted? expr) (analyze-quoted expr)]
  45.         [(variable? expr) (analyze-variable expr)]
  46.         [(assignment? expr) (analyze-assignment expr)]
  47.         [(definition? expr) (analyze-definition expr)]
  48.         [(if? expr) (analyze-if expr)]
  49.         [(lambda? expr) (analyze-lambda expr)]
  50.         [(begin? expr) (analyze-sequence (begin-actions expr))]
  51.         [(cond? expr) (analyze (cond->if expr))]
  52.         [(and? expr) (analyze-and expr)]
  53.         [(or? expr) (analyze-or expr)]
  54.         [(let? expr) (analyze (let->combination expr))]
  55.         [(let*? expr) (analyze (let*->nested-lets expr))]
  56.         [(named-let? expr) (analyze (named-let->sequence expr))]
  57.         [(letrec? expr) (analyze (letrec->simultaneous-lets expr))]
  58.         [(application? expr) (analyze-application expr)]
  59.         [else (error "Unknown expression type -- ANALYZE" expr)]))
  60.  
  61. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  62. ;; 2. SELF-EVALUATING EXPRESSIONS, VARIABLES, AND QUOTATIONS  ;;
  63. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  64.  
  65. (define (tagged-list? expr tag)
  66.   (if (pair? expr)
  67.     (eq? (first expr) tag)
  68.     false))
  69. (define *reserved-symbols*
  70.   (list
  71.     '*unassigned*
  72.     ))
  73.  
  74. ;; Only numbers, strings, and reserved symbols are self-evaluating.
  75. (define (self-evaluating? expr)
  76.   (or (number? expr)
  77.       (string? expr)
  78.       (member expr *reserved-symbols*)))
  79. (define (analyze-self-evaluating expr)
  80.   (lambda (env) expr))
  81.  
  82. ;; variables
  83. (define (variable? expr)
  84.   (and (symbol? expr)
  85.        (not (member expr *reserved-symbols*))))
  86. (define (analyze-variable expr)
  87.   (lambda (env) (lookup-variable-value expr env)))
  88.  
  89. ;; Quotations have the form:  (quote <text-of-quotation>)
  90. (define (quoted? expr)
  91.   (tagged-list? expr 'quote))
  92. (define (text-of-quotation expr)
  93.   (second expr))
  94. (define (analyze-quoted expr)
  95.   (define qval (text-of-quotation expr))
  96.   (lambda (env) qval))
  97.  
  98. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  99. ;; 3. DEFINITION AND ASSIGNMENT  ;;
  100. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  101.  
  102. ;; Variable definitions have the form:  (define <var> <value>)
  103.  
  104. ;; Procedure definitions have the form:
  105. ;; (define (<var> <parameter-1> ... <parameter-n>) <body>)
  106. ;; which is equivalent to:
  107. ;; (define <var> (lambda (<parameter-1> ... <parameter-n>) <body>))
  108.  
  109. (define (definition? expr) (tagged-list? expr 'define))
  110. (define (definition-variable expr)
  111.   (if (symbol? (second expr))
  112.     (second expr)
  113.     (first (second expr))))
  114. (define (definition-value expr)
  115.   (if (symbol? (second expr))
  116.     (third expr)
  117.     (make-lambda (rest (second expr)) ; formal parameters
  118.                  (drop expr 2))))
  119. (define (analyze-definition expr)
  120.   (define var (definition-variable expr))
  121.   (define vproc (analyze (definition-value expr)))
  122.   (lambda (env)
  123.     (define-variable! var (vproc env) env)
  124.     'ok))
  125.  
  126. ;; Assignments have the form:  (set! <var> <value>)
  127. (define (assignment? expr)
  128.   (tagged-list? expr 'set!))
  129. (define (assignment-variable expr) (second expr))
  130. (define (assignment-value expr) (third expr))
  131. (define (analyze-assignment expr)
  132.   (define var (assignment-variable expr))
  133.   (define vproc (analyze (assignment-value expr)))
  134.   (lambda (env)
  135.     (set-variable-value! var (vproc env) env)
  136.     'ok))
  137.  
  138. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  139. ;; 4. LAMBDAS, PROCEDURES AND APPLICATIONS  ;;
  140. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  141.  
  142. ;; Lambda expressions have the form:
  143. ;; (lambda (<parameters>) <body>)
  144. (define (lambda? expr) (tagged-list? expr 'lambda))
  145. (define (lambda-parameters expr) (second expr))
  146. (define (lambda-body expr)
  147.   (drop expr 2))
  148. (define (make-lambda parameters body)
  149.   (cons 'lambda (cons parameters body)))
  150. (define (scan-out-defines body)
  151.   (define defines (filter definition? body))
  152.   (cond [(empty? defines) body]
  153.         [else
  154.           (define rest-of-body (filter-not definition? body))
  155.           (define vars (map definition-variable defines))
  156.           (define vals (map definition-value defines))
  157.           (define bindings
  158.             (for/list ([v vars])
  159.                       (list v '*unassigned*)))
  160.           (define assigns
  161.             (for/list ([v vars]
  162.                        [e vals])
  163.                       (list 'set! v e)))
  164.           ; a body is a list of expressions
  165.           (list
  166.             (make-let
  167.               bindings
  168.               (append assigns rest-of-body)))]))
  169. (define (analyze-lambda expr)
  170.   (define vars (lambda-parameters expr))
  171.   (define bproc (analyze-sequence (scan-out-defines (lambda-body expr))))
  172.   (lambda (env) (make-procedure vars bproc env)))
  173.  
  174. ;; Procedures:
  175. (define (compound-procedure? p)
  176.   (tagged-list? p 'procedure))
  177. (define (make-procedure parameters body env)
  178.   (list 'procedure parameters body env))
  179. (define (procedure-parameters p) (second p))
  180. (define (procedure-body p) (third p))
  181. (define (procedure-environment p) (fourth p))
  182.  
  183. ;; Procedure applications have the from:
  184. ;; (<var> <parameter> ...)
  185. (define (application? expr) (pair? expr))
  186. (define (operator expr) (first expr))
  187. (define (operands expr) (rest expr))
  188. (define (no-operands? ops) (empty? ops))
  189. (define (first-operand ops) (first ops))
  190. (define (rest-operands ops) (rest ops))
  191. (define (analyze-application expr)
  192.   (define fproc (analyze (operator expr)))
  193.   (define aprocs (map analyze (operands expr)))
  194.   (lambda (env)
  195.     (execute-application (fproc env)
  196.                          (map (lambda (aproc) (aproc env))
  197.                               aprocs))))
  198. (define (execute-application proc args)
  199.   (cond [(primitive-procedure? proc)
  200.          (apply-primitive-procedure proc args)]
  201.         [(compound-procedure? proc)
  202.          ((procedure-body proc)
  203.           (extend-environment (procedure-parameters proc)
  204.                               args
  205.                               (procedure-environment proc)))]
  206.         [else
  207.           (error "Unknown procedure type -- EXECUTE-APPLICATION" proc)]))
  208.  
  209. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  210. ;; 5. SEQUENCES AND BEGIN EXPRESSIONS  ;;
  211. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  212.  
  213. ;; Begin has the form:  (begin <actions>)
  214. (define (begin? expr) (tagged-list? expr 'begin))
  215. (define (begin-actions expr) (rest expr))
  216. (define (last-exp? seq) (empty? (rest seq)))
  217. (define (first-exp seq) (first seq))
  218. (define (rest-exps seq) (rest seq))
  219. (define (sequence->exp seq)
  220.   (cond [(empty? seq) seq]
  221.         [(last-exp? seq) (first-exp seq)]
  222.         [else (make-begin seq)]))
  223. (define (make-begin seq) (cons 'begin seq))
  224. (define (analyze-sequence exprs)
  225.   (define (sequentially proc1 proc2)
  226.     (lambda (env) (proc1 env) (proc2 env)))
  227.   (define (loop first-proc rest-procs)
  228.     (if (empty? rest-procs)
  229.       first-proc
  230.       (loop (sequentially first-proc (first rest-procs))
  231.             (rest rest-procs))))
  232.   (define procs (map analyze exprs))
  233.   (if (null? procs)
  234.     (error "Empty sequence -- ANALYZE")
  235.     (loop (first procs) (rest procs))))
  236.  
  237. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  238. ;; 6. BOOLEAN EXPRESSIONS  ;;
  239. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  240.  
  241. (define (true? x) (not (false? x)))
  242. (define (and? expr) (tagged-list? expr 'and))
  243. (define (and-operands expr) (rest expr))
  244. (define (make-and sequence) (cons 'and sequence))
  245. (define (analyze-and expr)
  246.   (define (and-sequentially proc1 proc2)
  247.     (lambda (env) (and (proc1 env) (proc2 env))))
  248.   (define (loop first-proc rest-procs)
  249.     (if (empty? rest-procs)
  250.       first-proc
  251.       (loop (and-sequentially first-proc (first rest-procs))
  252.             (rest rest-procs))))
  253.   (define procs (map analyze (and-operands expr)))
  254.   (if (empty? procs)
  255.     true
  256.     (loop (first procs) (rest procs))))
  257.  
  258. (define (or? expr) (tagged-list? expr 'or))
  259. (define (or-operands expr) (rest expr))
  260. (define (make-or sequence) (cons 'or sequence))
  261. (define (analyze-or expr)
  262.   (define (or-sequentially proc1 proc2)
  263.     (lambda (env) (or (proc1 env) (proc2 env))))
  264.   (define (loop first-proc rest-procs)
  265.     (if (empty? rest-procs)
  266.       first-proc
  267.       (loop (or-sequentially first-proc (first rest-procs))
  268.             (rest rest-procs))))
  269.   (define procs (map analyze (or-operands expr)))
  270.   (if (empty? procs)
  271.     false
  272.     (loop (first procs) (rest procs))))
  273.  
  274. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  275. ;; 7. IF AND COND EXPRESSIONS  ;;
  276. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  277.  
  278. ;; Conditionals have the form:  (if <predicate> <consequent> <alternative>)
  279. ;; If no alternative, use false.
  280. (define (if? expr) (tagged-list? expr 'if))
  281. (define (if-predicate expr) (second expr))
  282. (define (if-consequent expr) (third expr))
  283. (define (if-alternative expr)
  284.   (if (not (empty? (drop expr 3)))
  285.     (fourth expr)
  286.     'false))
  287. (define (make-if predicate consequent alternative)
  288.   (list 'if predicate consequent alternative))
  289. (define (analyze-if expr)
  290.   (define pproc (analyze (if-predicate expr)))
  291.   (define cproc (analyze (if-consequent expr)))
  292.   (define aproc (analyze (if-alternative expr)))
  293.   (lambda (env)
  294.     (if (true? (pproc env))
  295.       (cproc env)
  296.       (aproc env))))
  297.  
  298. ;; Cond has the form:
  299. ;; (cond ((<predicate> <actions>)
  300.        ;; (else <actions>))) ; if no else, assume (else false) clause
  301. (define (cond? expr) (tagged-list? expr 'cond))
  302. (define (cond-clauses expr) (rest expr))
  303. ;; regular cond clause
  304. (define (cond-predicate clause) (first clause))
  305. (define (cond-actions clause) (rest clause))
  306. ;; alternate test clause
  307. (define (cond-alternate-clause? clause)
  308.   (eq? (second clause) '=>))
  309. (define (cond-test clause) (first clause))
  310. (define (cond-recipient clause) (third clause))
  311. ;; else clause
  312. (define (cond-else-clause? clause)
  313.   (eq? (cond-predicate clause) 'else))
  314. ;; derive cond from if
  315. (define (cond->if expr)
  316.   (expand-clauses (cond-clauses expr)))
  317. (define (expand-clauses clauses)
  318.   (cond [(empty? clauses) 'false] ; no else clause
  319.         [else
  320.           (define first-clause (first clauses))
  321.           (define rest-clauses (rest clauses))
  322.           (cond [(cond-else-clause? first-clause)
  323.                  (if (empty? rest-clauses)
  324.                    (sequence->exp (cond-actions first-clause))
  325.                    (error "ELSE clause is not last -- COND->IF" clauses))]
  326.                 [(cond-alternate-clause? first-clause)
  327.                  (define test (cond-test first-clause)) ; gets evaluated twice
  328.                  (make-if test
  329.                           (list (cond-recipient first-clause)
  330.                                 test)
  331.                           (expand-clauses rest-clauses))]
  332.                 [else
  333.                   (make-if (cond-predicate first-clause)
  334.                            (sequence->exp (cond-actions first-clause))
  335.                            (expand-clauses rest-clauses))])]))
  336.  
  337. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  338. ;; 8. LET, LET*, NAMED-LET, AND LETREC  ;;
  339. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  340.  
  341. ;; Let has the form:  (let (<bindings>) <body>)
  342. (define (let? expr)
  343.   (and (tagged-list? expr 'let)
  344.        (list? (second expr))))
  345. (define (let-bindings expr) (second expr))
  346. (define (let-parameters expr) (map first (let-bindings expr)))
  347. (define (let-expressions expr) (map second (let-bindings expr)))
  348. (define (let-body expr) (drop expr 2))
  349. (define (let->combination expr)
  350.   (cond [(empty? (let-bindings expr)) ; do not unnecessarily lambda wrap
  351.          (sequence->exp (let-body expr))]
  352.         [else
  353.           (cons (make-lambda (let-parameters expr)
  354.                              (let-body expr))
  355.                 (let-expressions expr))]))
  356. (define (make-let bindings body)
  357.   (cons 'let (cons bindings body)))
  358.  
  359. ;; Let* has the same form as let, but bindings are sequential.
  360. (define (let*? expr) (tagged-list? expr 'let*))
  361. (define (let*-bindings expr) (second expr))
  362. (define (let*-body expr) (drop expr 2))
  363. (define (make-let* bindings body)
  364.   (cons 'let* (cons bindings body)))
  365. (define (let*->nested-lets expr)
  366.   (define bindings (let*-bindings expr))
  367.   (cond [(empty? bindings)
  368.          (sequence->exp (let-body expr))]
  369.         [else
  370.           (list 'let
  371.                 (list (first bindings))
  372.                 (let*->nested-lets
  373.                   (make-let* (rest bindings)
  374.                              (let-body expr))))]))
  375.  
  376. ;; Named-let has the form:  (let <name> (<bindings>) <body>)
  377. (define (named-let? expr)
  378.   (and (tagged-list? expr 'let)
  379.        (not (list? (second expr)))))
  380. (define (named-let-name expr) (second expr))
  381. (define (named-let-bindings expr) (third expr))
  382. (define (named-let-parameters expr) (map first (named-let-bindings expr)))
  383. (define (named-let-expressions expr) (map second (named-let-bindings expr)))
  384. (define (named-let-body expr) (drop expr 3))
  385. (define (named-let->sequence expr)
  386.   (define bindings (named-let-bindings expr))
  387.   (cond [(empty? bindings)
  388.          (sequence->exp (named-let-body expr))]
  389.         [else
  390.           (list 'begin
  391.                 (cons 'define ; first define the named function
  392.                       (cons (cons (named-let-name expr)
  393.                                   (named-let-parameters expr))
  394.                             (named-let-body expr)))
  395.                 (cons (named-let-name expr) ; then apply it to the expressions
  396.                       (named-let-expressions expr)))]))
  397.  
  398. ;; Letrec has the same form as let, but letrec parameters are first bound to
  399. ;; '*unassigned* and then set! to their values to mimic simultaneous definitions.
  400. (define (letrec? expr) (tagged-list? expr 'letrec))
  401. (define (letrec-bindings expr) (second expr))
  402. (define (letrec-body expr) (drop expr 2))
  403. (define (letrec->simultaneous-lets expr)
  404.   (define bindings (letrec-bindings expr))
  405.   (cond [(empty? bindings)
  406.          (letrec-body expr)]
  407.         [else
  408.           (define vars (map first bindings))
  409.           (define vals (map second bindings))
  410.           (define new-bindings
  411.             (for/list ([v vars])
  412.                       (list v '*unassigned*)))
  413.           (define assigns
  414.             (for/list ([v vars]
  415.                        [e vals])
  416.                       (list 'set! v e)))
  417.           (make-let
  418.             new-bindings
  419.             (append assigns (letrec-body expr)))]))
  420.  
  421. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  422. ;; 9. ENVIRONMENT AND FRAMES  ;;
  423. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  424.  
  425. ;; An environment is a mutable list of frames.  The enclosing environment is the mcdr
  426. ;; of the list.  A frame is a mutable list of bindings with a 'frame header.  A
  427. ;; binding is a var-val pair ie (mcons var val).
  428.  
  429. ;; Environments support four procedures:
  430.     ;; lookup-variable-value
  431.     ;; extend-environment
  432.     ;; define-variable
  433.     ;; set-variable-value
  434.  
  435. ;; Two helper functions support the environment procedures:
  436.     ;; find-binding-in-frame
  437.     ;; find-binding-in-environment
  438.  
  439. (define (enclosing-environment env) (mcdr env))
  440. (define (first-frame env) (mcar env))
  441. (define the-empty-environment empty)
  442. (define the-empty-frame (mlist 'frame))
  443. (define (empty-frame? frame)
  444.   (empty? (frame-bindings frame)))
  445. (define (make-frame vars vals)
  446.   (mcons 'frame
  447.          (mmap mcons
  448.                (list->mlist vars)
  449.                (list->mlist vals))))
  450. (define (frame-bindings frame) (mcdr frame))
  451. (define (frame-variables frame) (mmap mcar (frame-bindings frame)))
  452. (define (frame-values frame) (mmap mcdr (frame-bindings frame)))
  453.  
  454. (define (binding-variable binding) (mcar binding))
  455. (define (binding-value binding) (mcdr binding))
  456. (define (set-value! binding val) (set-mcdr! binding val))
  457. (define (add-binding-to-frame! var val frame)
  458.   (mappend! frame (mlist (mcons var val))))
  459. (define (find-binding-in-frame var frame)
  460.   ; Return the var-val pair if present else false.
  461.   (define (loop bindings)
  462.     (cond [(empty? bindings) false]
  463.           [else
  464.             (define b (mcar bindings))
  465.             (if (eq? var (binding-variable b))
  466.               b
  467.               (loop (mcdr bindings)))]))
  468.   (loop (frame-bindings frame)))
  469. (define (find-binding-in-env var env)
  470.   ; Return the closest binding for var if present else false.
  471.   (cond [(eq? env the-empty-environment) false]
  472.         [else
  473.           (define b (find-binding-in-frame var (first-frame env)))
  474.           (or b (find-binding-in-env var (enclosing-environment env)))]))
  475.  
  476. (define (lookup-variable-value var env)
  477.   (define b (find-binding-in-env var env))
  478.   (if (false? b)
  479.     (error "Unbound variable" var)
  480.     (binding-value b)))
  481. (define (extend-environment vars vals base-env)
  482.   (cond [(= (length vars) (length vals))
  483.          (mcons (make-frame vars vals) base-env)]
  484.         [else
  485.           (if (< (length vars) (length vals))
  486.             (error "Too many arguments supplied" vars vals)
  487.             (error "Too few arguments supplied" vars vals))]))
  488. (define (define-variable! var val env)
  489.   (define frame (first-frame env))
  490.   (define b (find-binding-in-frame var frame))
  491.   (if b
  492.     (set-value! b val)
  493.     (add-binding-to-frame! var val frame)))
  494. (define (set-variable-value! var val env)
  495.   (define b (find-binding-in-env var env))
  496.   (if b
  497.     (set-value! b val)
  498.     (error "Unbound variable -- SET!" var)))
  499.  
  500. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  501. ;; 10. PRIMITIVE PROCEDURES AND THE GLOBAL ENVIRONMENT  ;;
  502. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  503.  
  504. (define primitive-procedures
  505.   (list
  506.     (list 'cons cons)
  507.     (list 'car car)
  508.     (list 'cdr cdr)
  509.     (list '+ +)
  510.     (list '* *)
  511.     (list '- -)
  512.     (list '< <)
  513.     (list '> >)
  514.     (list '<= <=)
  515.     (list '>= >=)
  516.     (list '= =)
  517.     (list 'not not)
  518.     (list 'false? false?)
  519.     (list 'true? (lambda (x) (not (false? x))))
  520.     (list 'empty? empty?)
  521.     ))
  522. (define (primitive-procedure? proc)
  523.   (tagged-list? proc 'primitive))
  524. (define (primitive-implementation proc)
  525.   (second proc))
  526. (define (primitive-procedure-names)
  527.   (map first primitive-procedures))
  528. (define (primitive-procedure-objects)
  529.   (map (lambda (proc) (list 'primitive (second proc)))
  530.        primitive-procedures))
  531. (define apply-in-underlying-scheme apply)
  532. ;; The metacircular evaluator's apply is my-apply.
  533. (define (apply-primitive-procedure proc args)
  534.   (apply-in-underlying-scheme
  535.     (primitive-implementation proc) args))
  536.  
  537. (define (setup-environment)
  538.   (define initial-env
  539.     (extend-environment (primitive-procedure-names)
  540.                         (primitive-procedure-objects)
  541.                         the-empty-environment))
  542.   (define-variable! 'true true initial-env)
  543.   (define-variable! 'false false initial-env)
  544.   initial-env)
  545. (define the-global-environment (setup-environment))
  546.  
  547. ;;;;;;;;;;;;;;;;;;;;;;;;;;
  548. ;; 11. REPL OPERATIONS  ;;
  549. ;;;;;;;;;;;;;;;;;;;;;;;;;;
  550.  
  551. (define input-prompt ";;; M-Eval input:")
  552. (define output-prompt ";;; M-Eval value:")
  553. (define (driver-loop)
  554.   (prompt-for-input input-prompt)
  555.   (let* ([input (read)]
  556.          [output (my-eval input the-global-environment)])
  557.     (announce-output output-prompt)
  558.     (user-print output))
  559.   (driver-loop))
  560. (define prompt-for-input displayln)
  561. (define announce-output displayln)
  562. (define (user-print object)
  563.   (if (compound-procedure? object)
  564.     (displayln (list 'compound-procedure
  565.                    (procedure-parameters object)
  566.                    (procedure-body object)
  567.                    '<procedure-env>))
  568.     (displayln object)))
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!