The Lambda Lab
/
projects
/
scheme.forth.jl.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Updated readme.
[scheme.forth.jl.git]
/
examples
/
metacirc.scm
diff --git
a/examples/metacirc.scm
b/examples/metacirc.scm
index
4778591
..
fe4c965
100644
(file)
--- a/
examples/metacirc.scm
+++ b/
examples/metacirc.scm
@@
-2,12
+2,14
@@
;; Mandatory SICP Metacircular Evaluator ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Mandatory SICP Metacircular Evaluator ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; To use, simply (load "metacirc.scm") and run the (driver-loop) command.
+
(define apply-in-underlying-scheme apply)
(define apply-in-underlying-scheme apply)
+(define true #t)
+(define false #f)
;; Verbatim code from SICP
;; Verbatim code from SICP
-(display "eval and apply\n")
-
(define (eval exp env)
(cond ((self-evaluating? exp)
exp)
(define (eval exp env)
(cond ((self-evaluating? exp)
exp)
@@
-86,6
+88,13
@@
env)
'ok)
env)
'ok)
+(define (eval-definition exp env)
+ (define-variable!
+ (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+
(define (self-evaluating? exp)
(cond ((number? exp) true)
((string? exp) true)
(define (self-evaluating? exp)
(cond ((number? exp) true)
((string? exp) true)
@@
-128,8
+137,6
@@
(cddr exp)))) ; body
(cddr exp)))) ; body
-(display "lambda... \n")
-
(define (lambda? exp)
(tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
(define (lambda? exp)
(tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
@@
-176,8
+183,6
@@
(define (rest-operands ops) (cdr ops))
(define (rest-operands ops) (cdr ops))
-(display "cond... \n")
-
(define (cond? exp)
(tagged-list? exp 'cond))
(define (cond-clauses exp) (cdr exp))
(define (cond? exp)
(tagged-list? exp 'cond))
(define (cond-clauses exp) (cdr exp))
@@
-214,9
+219,6
@@
(eq? x false))
(eq? x false))
-(display "make-procedure...\n")
-
-
(define (make-procedure parameters body env)
(list 'procedure parameters body env))
(define (compound-procedure? p)
(define (make-procedure parameters body env)
(list 'procedure parameters body env))
(define (compound-procedure? p)
@@
-230,8
+232,6
@@
(define the-empty-environment '())
(define the-empty-environment '())
-(display "make-frame\n")
-
(define (make-frame variables values)
(cons variables values))
(define (frame-variables frame) (car frame))
(define (make-frame variables values)
(cons variables values))
(define (frame-variables frame) (car frame))
@@
-240,8
+240,6
@@
(set-car! frame (cons var (car frame)))
(set-cdr! frame (cons val (cdr frame))))
(set-car! frame (cons var (car frame)))
(set-cdr! frame (cons val (cdr frame))))
-(display "extend-environment\n")
-
(define (extend-environment vars vals base-env)
(if (= (length vars) (length vals))
(cons (make-frame vars vals) base-env)
(define (extend-environment vars vals base-env)
(if (= (length vars) (length vals))
(cons (make-frame vars vals) base-env)
@@
-253,8
+251,6
@@
vars
vals))))
vars
vals))))
-(display "lookup-variable\n")
-
(define (lookup-variable-value var env)
(define (env-loop env)
(define (scan vars vals)
(define (lookup-variable-value var env)
(define (env-loop env)
(define (scan vars vals)
@@
-272,8
+268,6
@@
(frame-values frame)))))
(env-loop env))
(frame-values frame)))))
(env-loop env))
-(display "set-variable\n")
-
(define (set-variable-value! var val env)
(define (env-loop env)
(define (scan vars vals)
(define (set-variable-value! var val env)
(define (env-loop env)
(define (scan vars vals)
@@
-291,8
+285,6
@@
(frame-values frame)))))
(env-loop env))
(frame-values frame)))))
(env-loop env))
-(display "define-variable\n")
-
(define (define-variable! var val env)
(let ((frame (first-frame env)))
(define (scan vars vals)
(define (define-variable! var val env)
(let ((frame (first-frame env)))
(define (scan vars vals)
@@
-301,13
+293,12
@@
var val frame))
((eq? var (car vars))
(set-car! vals val))
var val frame))
((eq? var (car vars))
(set-car! vals val))
- (else (scan (cdr vars)
+ (else
+ (scan (cdr vars)
(cdr vals)))))
(scan (frame-variables frame)
(frame-values frame))))
(cdr vals)))))
(scan (frame-variables frame)
(frame-values frame))))
-(display "setup-environment...\n")
-
(define (setup-environment)
(let ((initial-env
(extend-environment
(define (setup-environment)
(let ((initial-env
(extend-environment
@@
-318,6
+309,7
@@
(define-variable! 'false false initial-env)
initial-env))
(define-variable! 'false false initial-env)
initial-env))
+
(define (primitive-procedure? proc)
(tagged-list? proc 'primitive))
(define (primitive-procedure? proc)
(tagged-list? proc 'primitive))
@@
-341,8
+333,6
@@
(list 'primitive (cadr proc)))
primitive-procedures))
(list 'primitive (cadr proc)))
primitive-procedures))
-
-
(define (apply-primitive-procedure proc args)
(apply-in-underlying-scheme
(primitive-implementation proc) args))
(define (apply-primitive-procedure proc args)
(apply-in-underlying-scheme
(primitive-implementation proc) args))
@@
-351,9
+341,6
@@
(define output-prompt ";;; M-Eval value:")
(define output-prompt ";;; M-Eval value:")
-(display "driver-loop...\n")
-
-
(define (driver-loop)
(prompt-for-input input-prompt)
(let ((input (read)))
(define (driver-loop)
(prompt-for-input input-prompt)
(let ((input (read)))
@@
-380,5
+367,5
@@
'<procedure-env>))
(display object)))
'<procedure-env>))
(display object)))
-(define the-global-environment
-
(setup-environment))
+
+
(define the-global-environment
(setup-environment))