ompayne
/
sicp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

More re-arranging 

All code now loads OK.  Still need to extend initial environment to
include built-in procedures.
This commit is contained in:
Oliver Payne 2023-06-24 23:04:41 +01:00
parent 8453df4563
commit b517f8c9aa
5 changed files with 112 additions and 157 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
mceval/dd-mceval.rkt
View File

@ -6,6 +6,7 @@
(#%require "dispatch-table.rkt")
(#%require "syntax.rkt")
(#%require "environment.rkt")
(#%require "common.rkt")
;; This is a lightly modified version of ch4-mceval.scm to work in racket.
@ -77,6 +78,56 @@
(cons (mce-eval (first-operand exps) env)
(list-of-values (rest-operands exps) env))))
;; Exercise 4.16: Scan out the defines when accessing the body, so we
;; only incur the overhead if it is needed. There may be procedure
;; bodies that are never evaluated, so it makes sense to process them
;; lazily.
(define (procedure-body p) (scan-out-defines (caddr p)))
(define (procedure-environment p) (cadddr p))
;; Exercise 4.16: transform the body to scan out internal
;; definitions. Variables will be created unassigned by a let and
;; then initialised by a set! inside the let body. Perhaps it is
;; possible to do this in one pass while still keeping the clean
;; recursive structure (ie not resorting to append or set! at each
;; iteration), but this is probably good enough, given that the size
;; of the body is likely to be quite small.
(define (scan-out-defines body)
;; Get a list of defined variables in the body
(define (scan-vars body)
(if (null? body)
'()
(let ((exp (first-exp body)))
(if (definition? exp)
(cons (definition-variable exp)
(scan-vars (rest-exps body)))
(scan-vars (rest-exps body))))))
;; Convert all definitions to assignments
(define (definition->assignment body)
(if (null? body)
'()
(let ((exp (first-exp body)))
(cons
(if (definition? exp)
(make-assignment (definition-variable exp)
(definition-value exp))
exp)
(definition->assignment (rest-exps body))))))
(define (make-unassigned-let vars body)
(make-let
(map (lambda (var)
(list var '*unassigned*))
vars)
body))
(let ((vars (scan-vars body)))
(if (null? vars)
body
(make-body
(make-unassigned-let vars
(definition->assignment body))))))
(define (eval-if exp env)
(if (true? (mce-eval (if-predicate exp) env))
(mce-eval (if-consequent exp) env)
@ -151,12 +202,15 @@
(define input-prompt ";;; M-Eval input:")
(define output-prompt ";;; M-Eval value:")
(define (driver-loop)
(prompt-for-input input-prompt)
(let ((input (read)))
(let ((output (mce-eval input the-global-environment)))
(announce-output output-prompt)
(mce-user-print output)))
(define (repl)
(define the-global-environment (setup-environment))
(define (driver-loop)
(prompt-for-input input-prompt)
(let ((input (read)))
(let ((output (mce-eval input the-global-environment)))
(announce-output output-prompt)
(mce-user-print output))
(driver-loop)))
(driver-loop))
(define (prompt-for-input string)
@ -206,8 +260,7 @@
(for ,(lambda (exp env)
(mce-eval (for->named-let exp) env)))
(unless ,(lambda (exp env)
(mce-eval (unless->if exp) env)))
(driver-loop ,driver-loop)))
(mce-eval (unless->if exp) env)))))
;; (define (eval-dispatch-lookup type)
;; ((dispatch-table 'lookup) type))

67
mceval/dispatch-table.rkt
View File

@ -1,33 +1,50 @@
#lang sicp
(#%require "table.rkt")
(#%provide make-dispatch-table
put!
put-alist!
get)
(define (assoc key records)
(cond ((null? records) false)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (make-dispatch-table)
(let ((dispatch-table (make-2d-table)))
(define (put! evaluator symbol proc)
((dispatch-table 'insert-proc!) evaluator symbol proc))
(define (get evaluator symbol)
((dispatch-table 'lookup-proc) evaluator symbol))
(let ((local-table (list '*dispatch-table*)))
(define (get sym)
(let ((value (assoc sym (cdr local-table))))
(if value
(cdr value)
#f)))
;; We are using alists, so the newest association
;; is always found, so there is no need to overwrite
;; an existing binding.
(define (put! sym proc)
(set-cdr! local-table
(cons
(cons sym proc)
(cdr local-table))))
(define (put-alist! sym-proc-alist)
(if (not (null? sym-proc-alist))
(let ((sym (caar sym-proc-alist))
(proc (cdar sym-proc-alist)))
(put! sym proc)
(put-alist! (cdr sym-proc-alist)))))
(define (dispatch m)
(cond ((eq? m 'put!) put!)
((eq? m 'get) get)
(else (error "Unknown input - DISPATCH-TABLE"))))
(cond ((eq? m 'get) get)
((eq? m 'put!) put!)
((eq? m 'put-alist!) put-alist!)
(else (error "Unknown operation -- DISPATCH-TABLE" m))))
dispatch))
;; (define (make-dispatch-table types-procs-alist)
;; (let ((eval-dispatch-table (make-1d-table)))
;; (define (eval-dispatch-put! type proc)
;; ((eval-dispatch-table 'insert-proc!) type proc))
;; (define (eval-dispatch-lookup type)
;; ((eval-dispatch-table 'lookup-proc) type))
;; (define (build-table types-procs)
;; (if (pair? types-procs)
;; (let ((type (caar types-procs))
;; (proc (cadar types-procs)))
;; (begin (eval-dispatch-put! type proc)
;; (build-table (cdr types-procs))))))
;; (define (dispatch m)
;; (cond ((eq? m 'lookup) eval-dispatch-lookup)
;; (else (error "Unknown input - DISPATCH-TABLE" m))))
;; (build-table types-procs-alist)
;; dispatch))
(define (put! table key proc)
((table 'put!) key proc))
(define (put-alist! table sym-proc-alist)
((table 'put-alist!) sym-proc-alist))
(define (get table key)
((table 'get) key))

16
mceval/environment.rkt
View File

@ -1,5 +1,12 @@
#lang sicp
(#%provide lookup-variable-value
set-variable-value!
define-variable!
make-unbound-variable!
extend-environment
setup-environment)
(define (enclosing-environment env) (cdr env))
(define (first-frame env) (car env))
@ -161,8 +168,6 @@
;; more primitives
))
(define (primitive-implementation proc) (cadr proc))
(define (primitive-procedure-names)
(map car
primitive-procedures))
@ -171,13 +176,6 @@
(map (lambda (proc) (list 'primitive (cadr proc)))
primitive-procedures))
;[moved to start of file] (define apply-in-underlying-scheme apply)
(define (apply-primitive-procedure proc args)
(apply
(primitive-implementation proc) args))
(define (setup-environment)
(let ((initial-env
(extend-environment (primitive-procedure-names)

49
mceval/syntax.rkt
View File

@ -1,5 +1,7 @@
#lang sicp
(#%provide (all-defined))
(define (self-evaluating? exp)
(cond ((number? exp) true)
((string? exp) true)
@ -324,53 +326,6 @@
(define (procedure-parameters p) (cadr p))
;; Exercise 4.16: Scan out the defines when accessing the body, so we
;; only incur the overhead if it is needed. There may be procedure
;; bodies that are never evaluated, so it makes sense to process them
;; lazily.
(define (procedure-body p) (scan-out-defines (caddr p)))
(define (procedure-environment p) (cadddr p))
;; Exercise 4.16: transform the body to scan out internal
;; definitions. Variables will be created unassigned by a let and
;; then initialised by a set! inside the let body. Perhaps it is
;; possible to do this in one pass while still keeping the clean
;; recursive structure (ie not resorting to append or set! at each
;; iteration), but this is probably good enough, given that the size
;; of the body is likely to be quite small.
(define (scan-out-defines body)
;; Get a list of defined variables in the body
(define (scan-vars body)
(if (null? body)
'()
(let ((exp (first-exp body)))
(if (definition? exp)
(cons (definition-variable exp)
(scan-vars (rest-exps body)))
(scan-vars (rest-exps body))))))
;; Convert all definitions to assignments
(define (definition->assignment body)
(if (null? body)
'()
(let ((exp (first-exp body)))
(cons
(if (definition? exp)
(make-assignment (definition-variable exp)
(definition-value exp))
exp)
(definition->assignment (rest-exps body))))))
(define (make-unassigned-let vars body)
(make-let
(map (lambda (var)
(list var '*unassigned*))
vars)
body))
(let ((vars (scan-vars body)))
(if (null? vars)
body
(make-body
(make-unassigned-let vars
(definition->assignment body))))))
;;;SECTION 4.1.4

68
table.rkt
View File

@ -1,68 +0,0 @@
#lang sicp
(#%require (only racket/base provide))
(provide make-1d-table make-2d-table)
;;;-----------
;;; Derived from code in the book to provide 1d and 2d tables.
;;;from section 3.3.3 for section 2.4.3
;;; to support operation/type table for data-directed dispatch
(define (assoc key records)
(cond ((null? records) false)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (make-1d-table)
(let ((local-table (list '*table*)))
(define (lookup key)
(let ((value (assoc key (cdr local-table))))
(if value
(cdr value)
#f)))
;; We are using alists, so the newest association
;; is always found, so there is no need to overwrite
;; an existing binding.
(define (insert! key value)
(set-cdr! local-table
(cons
(cons key value)
(cdr local-table))))
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define (make-2d-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))