mirror of https://gitlab.com/RaphyJake/sicp.git
fuck delayed evaluation
This commit is contained in:
Raphael Jakobs
parent
9b8fbacd2f
commit
822fee198d
|
|
@ -0,0 +1,11 @@
|
|||
```scheme
|
||||
|
||||
(define (inc x) (+ x 1))
|
||||
|
||||
(define (app f x) (f x))
|
||||
|
||||
(app inc 2)
|
||||
|
||||
```
|
||||
|
||||
in the last call inc would be a thunk which is not a procedure, or a compound procedure, thus fucking all up.
|
||||
|
|
@ -0,0 +1,572 @@
|
|||
(define apply-in-underlying-scheme apply) ;; Saving this for later
|
||||
|
||||
|
||||
(define (make-table) ;; A quick table implementation.
|
||||
(define table '())
|
||||
|
||||
(define (assoc key current)
|
||||
(cond ((null? current) #f)
|
||||
((eq? (caar current) key) (car current))
|
||||
(else (assoc key (cdr current)))))
|
||||
|
||||
(define (lookup key)
|
||||
(let ((record (assoc key table)))
|
||||
(if record (cdr record) #f)))
|
||||
|
||||
(define (insert! key value)
|
||||
(let ((place (assoc key table)))
|
||||
(if place
|
||||
(set-cdr! place value)
|
||||
(set! table (cons (cons key value) table)))))
|
||||
|
||||
|
||||
(define (dispatch m)
|
||||
(cond ((eq? m 'lookup) lookup)
|
||||
((eq? m 'insert!) insert!)
|
||||
(else (display "f you"))
|
||||
))
|
||||
dispatch)
|
||||
|
||||
(define optable (make-table))
|
||||
(define (add-op op fun) ((optable 'insert!) op fun))
|
||||
(define (get-op op) ((optable 'lookup) op))
|
||||
|
||||
|
||||
(define (eval exp env) (display exp) (newline)
|
||||
((analyze exp) env))
|
||||
|
||||
|
||||
(define (analyze exp)
|
||||
(cond ((self-evaluating? exp) (analyze-self-evaluating exp))
|
||||
((variable? exp) (analyze-variable exp))
|
||||
((get-op (car exp)) ((get-op (car exp)) exp))
|
||||
((application? exp) (analyze-application exp))
|
||||
(else (display "FUCK IT!"))
|
||||
))
|
||||
|
||||
(define (analyze-self-evaluating exp) (lambda (en) exp))
|
||||
|
||||
(define (analyze-quoted exp)
|
||||
(let ((qval (text-of-quotation exp)))
|
||||
(lambda (en) qval)))
|
||||
|
||||
(define (analyze-variable exp)
|
||||
(lambda (en) (lookup-variable-value exp en)))
|
||||
|
||||
(define (analyze-assignment exp)
|
||||
(let ((var (assignment-variable exp))
|
||||
(vproc (analyze (assignment-value exp))))
|
||||
(lambda (en) (set-variable-value! var (vproc en) en)
|
||||
'ok)))
|
||||
|
||||
(define (analyze-definition exp)
|
||||
(let ((var (definition-variable exp))
|
||||
(vproc (analyze (assignment-value exp))))
|
||||
(lambda (en) (define-variable! var (vproc en) en)
|
||||
'ok)))
|
||||
|
||||
(define (analyze-if exp)
|
||||
(let ((pproc (analyze (if-predicate exp)))
|
||||
(cproc (analyze (if-consequent exp)))
|
||||
(aproc (analyze (if-alternative exp))))
|
||||
(lambda (en)
|
||||
(if (true? (pproc en))
|
||||
(cproc en)
|
||||
(aproc en)))))
|
||||
|
||||
(define (analyze-lambda exp)
|
||||
(let ((vars (lambda-parameters exp))
|
||||
(bproc (analyze-sequence (lambda-body exp))))
|
||||
(lambda (en) (make-procedure vars bproc en))))
|
||||
|
||||
(define (analyze-sequence exps)
|
||||
(define (sequentially proc1 proc2)
|
||||
(lambda (env) (proc1 env) (proc2 env)))
|
||||
(define (loop first-proc rest-procs)
|
||||
(if (null? rest-procs)
|
||||
first-proc
|
||||
(loop (sequentially first-proc (car rest-procs))
|
||||
(cdr rest-procs))))
|
||||
(let ((procs (map analyze exps)))
|
||||
(if (null? procs)
|
||||
(display "Empty sequence: ANALYZE"))
|
||||
(loop (car procs) (cdr procs))))
|
||||
|
||||
(define (analyze-application exp)
|
||||
(let ((fproc (analyze (operator exp)))
|
||||
(aprocs (map analyze (operands exp))))
|
||||
(lambda (env)
|
||||
(execute-application
|
||||
(fproc env)
|
||||
(map (lambda (aproc) (aproc env))
|
||||
aprocs)))))
|
||||
|
||||
|
||||
(define (execute-application proc args)
|
||||
(cond ((primitive-procedure? proc)
|
||||
(apply-primitive-procedure proc args))
|
||||
((compound-procedure? proc)
|
||||
((procedure-body proc)
|
||||
(extend-environment (procedure-parameters proc) args
|
||||
(procedure-environment proc))))
|
||||
(else (display "Unknown procedure type:
|
||||
EXECUTE-APPLICATION"
|
||||
proc))))
|
||||
|
||||
|
||||
(define (list-of-values exps env)
|
||||
(if (no-operands? exps)
|
||||
'()
|
||||
(cons (eval (first-operand exps) env)
|
||||
(list-of-values (rest-operands exps) env))))
|
||||
|
||||
|
||||
(define (tagged-list? exp tag)
|
||||
(if (pair? exp)
|
||||
(eq? tag (car exp))
|
||||
#f))
|
||||
|
||||
|
||||
|
||||
(define (self-evaluating? exp)
|
||||
(cond ((string? exp) #t)
|
||||
((number? exp) #t)
|
||||
(else #f)))
|
||||
|
||||
(define (variable? exp) (symbol? exp))
|
||||
|
||||
;;; Quotations
|
||||
|
||||
;; 'quote <text-of-quotation>
|
||||
|
||||
(define (text-of-quotation exp) (cadr exp))
|
||||
|
||||
|
||||
|
||||
;;; Assignment 'set!
|
||||
|
||||
;; 'set! <variable> <value>
|
||||
|
||||
(define set-symbol 'set!)
|
||||
(define (make-set variable value) (list set-symbol variable value))
|
||||
|
||||
(define (assignment-variable exp) (cadr exp))
|
||||
(define (assignment-value exp) (caddr exp))
|
||||
|
||||
|
||||
;;Definition 'define
|
||||
|
||||
;; 'define <variable> <value>
|
||||
;; or
|
||||
;; 'define (<procedure-name> <formal parameters>) <body>
|
||||
|
||||
(define define-symbol 'define)
|
||||
(define (make-define-variable variable value) (list define-symbol variable value))
|
||||
(define (make-define-fun proc-name parameters body) (append (list define-symbol (cons proc-name parameters)) body))
|
||||
|
||||
(define (definition-variable exp)
|
||||
(if (symbol? (cadr exp))
|
||||
(cadr exp)
|
||||
(caadr exp)))
|
||||
|
||||
(define (definition-value exp)
|
||||
(if (symbol? (cadr exp))
|
||||
(caddr exp)
|
||||
(make-lambda (cdadr exp) ;; Formal parameters
|
||||
(cddr exp)) ;; Body
|
||||
))
|
||||
|
||||
|
||||
;;Lambda expressions
|
||||
|
||||
;; 'lambda (<formal parameters>) <body>
|
||||
|
||||
(define lambda-symbol 'lambda)
|
||||
(define (make-lambda parameters body)
|
||||
(cons lambda-symbol (cons parameters body)))
|
||||
|
||||
(define (lambda-parameters exp) (cadr exp))
|
||||
|
||||
(define (lambda-body exp) (cddr exp))
|
||||
|
||||
|
||||
;;Let expressions
|
||||
|
||||
;; 'let ((<variable> <expression>)) <body>
|
||||
;; or
|
||||
;; 'let <variable> ((<variable> <expression>)) <body>
|
||||
|
||||
(define let-symbol 'let)
|
||||
(define (make-let bindings body) (append (list let-symbol bindings) body))
|
||||
(define (make-named-let var bindings body) (list let-symbol bindings body))
|
||||
|
||||
(define (named-let? exp) (symbol? (cadr exp)))
|
||||
(define (let-variables exp) (map car (if (named-let? exp) (caddr exp) (cadr exp))))
|
||||
(define (let-expressions exp) (map cadr (if (named-let? exp) (caddr exp) (cadr exp))))
|
||||
(define (let-body exp) (if (named-let? exp) (cdddr exp) (cddr exp)))
|
||||
(define (named-let-variable exp) (cadr exp))
|
||||
|
||||
(define (let->combination exp)
|
||||
(if (named-let? exp)
|
||||
(make-begin (list (make-define-fun (named-let-variable exp) (let-variables exp) (let-body exp))
|
||||
(cons (named-let-variable exp) (let-expressions exp))))
|
||||
(cons (make-lambda (let-variables exp) (let-body exp)) (let-expressions exp))))
|
||||
|
||||
;;Let* expression. Nice!
|
||||
|
||||
;; 'let* ((<variable> <expression)) <body>
|
||||
|
||||
(define let*-symbol 'let*)
|
||||
(define (make-let* bindings body) (append (list let-symbol bindings) body))
|
||||
|
||||
(define (let*-variables exp) (map car (cadr exp)))
|
||||
(define (let*-expressions exp) (map cadr (cadr exp)))
|
||||
(define (let*-body exp) (cddr exp))
|
||||
|
||||
(define (let*->lets exp)
|
||||
(expand-let* (let*-variables exp) (let*-expressions exp) (let*-body exp)))
|
||||
|
||||
|
||||
(define (expand-let* variables expressions body)
|
||||
(if (or (null? (cdr variables)) (null? (cdr expressions))) ;; these should always be the same anyway..
|
||||
(make-let (list (list (car variables) (car expressions)))
|
||||
body)
|
||||
(make-let (list (list (car variables) (car expressions)))
|
||||
(list (expand-let* (cdr variables) (cdr expressions) body)))
|
||||
))
|
||||
|
||||
;;Conditionals
|
||||
|
||||
;; 'if <condition> <consequent> <alternative>
|
||||
|
||||
(define if-symbol 'if)
|
||||
|
||||
(define (make-if predicate consequent alternative)
|
||||
(list if-symbol predicate consequent alternative))
|
||||
|
||||
(define (if-predicate exp) (cadr exp))
|
||||
(define (if-consequent exp) (caddr exp))
|
||||
(define (if-alternative exp) (cadddr exp)) ;; Should we support ifs with no alternative?
|
||||
|
||||
|
||||
|
||||
;;Begin 'begin
|
||||
|
||||
;; 'begin <expressions>
|
||||
|
||||
(define begin-symbol 'begin)
|
||||
(define (make-begin seq) (cons begin-symbol seq))
|
||||
|
||||
(define (begin-actions exp) (cdr exp))
|
||||
(define (last-exp? seq) (null? (cdr seq)))
|
||||
(define (first-exp seq) (car seq))
|
||||
(define (rest-exps seq) (cdr seq))
|
||||
|
||||
|
||||
(define (sequence->exp seq)
|
||||
(cond ((null? seq) seq)
|
||||
((last-exp? seq) (first-exp seq))
|
||||
(else (make-begin seq))))
|
||||
|
||||
|
||||
|
||||
|
||||
;;Switch case, or cond 'cond
|
||||
|
||||
;; 'cond ((<condition> <consequent))
|
||||
;; or
|
||||
;; 'cond ((<condition> => <function>))
|
||||
;; or
|
||||
;; 'cond ((else <consequent>))
|
||||
|
||||
(define cond-symbol 'cond)
|
||||
(define else-symbol 'else)
|
||||
(define (make-cond clauses) (cons cond-symbol clauses))
|
||||
|
||||
(define (cond-clauses exp) (cdr exp))
|
||||
(define (cond-else-clause? clause) (eq? (cond-predicate clause) else-symbol))
|
||||
|
||||
(define (cond-predicate clause) (car clause))
|
||||
(define (cond-special-syntax? clause) (eq? (cadr clause) '=>))
|
||||
(define (cond-special-syntax-function clause) (caddr clause))
|
||||
(define (cond-actions clause) (cdr clause))
|
||||
|
||||
(define (cond->if exp)
|
||||
(expand-clauses (cond-clauses exp)))
|
||||
|
||||
(define (expand-clauses clauses)
|
||||
(if (null? clauses)
|
||||
'false ; no else clause
|
||||
(let ((first (car clauses))
|
||||
(rest (cdr clauses)))
|
||||
(if (cond-else-clause? first)
|
||||
(if (null? rest)
|
||||
(sequence->exp
|
||||
(cond-actions first))
|
||||
(display "ELSE clause isn't last: COND->IF"))
|
||||
(if (cond-special-syntax? first)
|
||||
(list (make-lambda (list 'x)
|
||||
(list (make-if 'x
|
||||
(list (cond-special-syntax-function first) 'x)
|
||||
(expand-clauses rest))))
|
||||
(cond-predicate first))
|
||||
(make-if (cond-predicate first)
|
||||
(sequence->exp
|
||||
(cond-actions first))
|
||||
(expand-clauses
|
||||
rest)))))))
|
||||
|
||||
;;Or and And
|
||||
|
||||
;; 'or <expressions> <expression> ..
|
||||
|
||||
;; 'and <expression> <expression> ..
|
||||
|
||||
(define or-symbol 'or)
|
||||
(define and-symbol 'and)
|
||||
(define (make-or expressions) (cons or-symbol expressions))
|
||||
(define (make-and expressions) cons and-symbol expressions)
|
||||
|
||||
(define (or-and-clauses exp) (cdr exp))
|
||||
(define (or-and-last-clause? seq) (null? (cdr seq)))
|
||||
|
||||
(define (expand-and->if clauses)
|
||||
(if (null? clauses)
|
||||
'false
|
||||
(if (or-and-last-clause? clauses)
|
||||
(car clauses) ; let's pretend a single clause OR or AND makes sense
|
||||
(make-if (car clauses)
|
||||
(expand-and->if (cdr clauses))
|
||||
'false)
|
||||
)))
|
||||
|
||||
(define (expand-or->if clauses)
|
||||
(if (null? clauses)
|
||||
'false
|
||||
(if (or-and-last-clause? clauses)
|
||||
(car clauses) ; let's pretend a single clause OR or AND makes sense
|
||||
(make-if (car clauses)
|
||||
'true
|
||||
(expand-or->if (cdr clauses)))
|
||||
)))
|
||||
|
||||
(define (or->if exp) (expand-or->if (cdr exp)))
|
||||
(define (and->if exp) (expand-and->if (cdr exp)))
|
||||
|
||||
;; Conditionals
|
||||
|
||||
(define (true? x)
|
||||
(not (eq? x #f)))
|
||||
|
||||
|
||||
(define (false? x)
|
||||
(eq? x #f))
|
||||
|
||||
;; Generic procedures
|
||||
|
||||
|
||||
(define (application? exp) (pair? exp))
|
||||
(define (operator exp) (car exp))
|
||||
(define (operands exp) (cdr exp))
|
||||
(define (no-operands? ops) (null? ops))
|
||||
(define (first-operand ops) (car ops))
|
||||
(define (rest-operands ops) (cdr ops))
|
||||
|
||||
|
||||
(define (make-procedure parameters body env)
|
||||
(list 'procedure parameters body env))
|
||||
|
||||
(define (compound-procedure? p) (tagged-list? p 'procedure))
|
||||
|
||||
(define (procedure-parameters p) (cadr p))
|
||||
|
||||
(define (procedure-body p) (caddr p))
|
||||
|
||||
(define (procedure-environment p) (cadddr p))
|
||||
|
||||
|
||||
;; Optable
|
||||
|
||||
(add-op let*-symbol (lambda (ex) (analyze (let*->lets ex))))
|
||||
(add-op let-symbol (lambda (ex) (analyze (let->combination ex))))
|
||||
(add-op and-symbol (lambda (ex) (analyze (and->if ex))))
|
||||
(add-op or-symbol (lambda (ex) (analyze (or->if ex))))
|
||||
(add-op cond-symbol (lambda (ex) (analyze (cond->if ex))))
|
||||
(add-op begin-symbol (lambda (ex) (analyze-sequence (begin-actions ex))))
|
||||
(add-op lambda-symbol analyze-lambda)
|
||||
(add-op if-symbol analyze-if)
|
||||
(add-op define-symbol analyze-definition)
|
||||
(add-op set-symbol analyze-assignment)
|
||||
(add-op 'quote analyze-quoted)
|
||||
|
||||
|
||||
(define primitive-procedures
|
||||
|
||||
(list (list 'car car)
|
||||
(list 'cdr cdr)
|
||||
(list 'cons cons)
|
||||
(list 'null? null?)
|
||||
(list 'eq? eq?)
|
||||
(list '+ +)
|
||||
(list '- -)
|
||||
(list '* *)
|
||||
(list '= =)
|
||||
))
|
||||
|
||||
|
||||
;; ENVIRONMENT
|
||||
|
||||
(define (enclosing-environment env) (cdr env))
|
||||
(define (first-frame env) (car env))
|
||||
(define the-empty-environment '())
|
||||
|
||||
(define (make-frame variables values)
|
||||
(cons variables values))
|
||||
|
||||
(define (frame-variables frame) (car frame))
|
||||
|
||||
(define (frame-values frame) (cdr frame))
|
||||
|
||||
(define (add-binding-to-frame! var val frame)
|
||||
(set-car! frame (cons var (car frame)))
|
||||
(set-cdr! frame (cons val (cdr frame))))
|
||||
|
||||
|
||||
(define (extend-environment vars vals base-env)
|
||||
(if (= (length vars) (length vals))
|
||||
(cons (make-frame vars vals) base-env)
|
||||
(if (< (length vars) (length vals))
|
||||
(display "Too many arguments supplied")
|
||||
(display "Too few arguments supplied"))))
|
||||
|
||||
|
||||
(define (lookup-variable-value var env)
|
||||
(define (env-loop env)
|
||||
(define (scan vars vals)
|
||||
(cond ((null? vars)
|
||||
(env-loop
|
||||
(enclosing-environment env)))
|
||||
((eq? var (car vars))
|
||||
(car vals))
|
||||
(else (scan (cdr vars)
|
||||
(cdr vals)))))
|
||||
(if (eq? env the-empty-environment)
|
||||
(begin (display "Unbound variable: ") (display var) (newline))
|
||||
(let ((frame (first-frame env)))
|
||||
(scan (frame-variables frame)
|
||||
(frame-values frame)))))
|
||||
(env-loop env))
|
||||
|
||||
(define (set-variable-value! var val env)
|
||||
(define (env-loop env)
|
||||
(define (scan vars vals)
|
||||
(cond ((null? vars)
|
||||
(env-loop
|
||||
(enclosing-environment env)))
|
||||
((eq? var (car vars))
|
||||
(set-car! vals val))
|
||||
(else (scan (cdr vars)
|
||||
(cdr vals)))))
|
||||
(if (eq? env the-empty-environment)
|
||||
(display "Unbound variable: SET!")
|
||||
(let ((frame (first-frame env)))
|
||||
(scan (frame-variables frame)
|
||||
(frame-values frame)))))
|
||||
(env-loop env))
|
||||
|
||||
(define (define-variable! var val env)
|
||||
(let ((frame (first-frame env)))
|
||||
(define (scan vars vals)
|
||||
(cond ((null? vars)
|
||||
(add-binding-to-frame!
|
||||
var val frame))
|
||||
((eq? var (car vars))
|
||||
(set-car! vals val))
|
||||
(else (scan (cdr vars)
|
||||
(cdr vals)))))
|
||||
(scan (frame-variables frame)
|
||||
(frame-values frame))))
|
||||
|
||||
;; ENV
|
||||
|
||||
(define (primitive-procedure-objects)
|
||||
(map (lambda (proc)
|
||||
(list 'primitive (cadr proc)))
|
||||
primitive-procedures))
|
||||
|
||||
|
||||
(define (primitive-procedure-names)
|
||||
(map car primitive-procedures))
|
||||
|
||||
(define (setup-environment)
|
||||
(let ((initial-env
|
||||
(extend-environment
|
||||
(primitive-procedure-names)
|
||||
(primitive-procedure-objects)
|
||||
the-empty-environment)))
|
||||
(define-variable! 'true #t initial-env)
|
||||
(define-variable! 'false #f initial-env)
|
||||
initial-env))
|
||||
|
||||
|
||||
(define the-global-environment
|
||||
(setup-environment))
|
||||
|
||||
(define (primitive-procedure? proc)
|
||||
(tagged-list? proc 'primitive))
|
||||
|
||||
|
||||
(define (primitive-implementation proc)
|
||||
(cadr proc))
|
||||
|
||||
|
||||
|
||||
(define (apply-primitive-procedure proc args)
|
||||
(apply-in-underlying-scheme
|
||||
(primitive-implementation proc) args))
|
||||
|
||||
|
||||
(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
|
||||
(eval input
|
||||
the-global-environment)))
|
||||
(announce-output output-prompt)
|
||||
(user-print output)))
|
||||
(driver-loop))
|
||||
|
||||
|
||||
|
||||
(define (prompt-for-input string)
|
||||
(newline) (newline)
|
||||
(display string) (newline))
|
||||
|
||||
|
||||
|
||||
(define (announce-output string)
|
||||
(newline) (display string) (newline))
|
||||
|
||||
|
||||
(define (user-print object)
|
||||
(if (compound-procedure? object)
|
||||
(display
|
||||
(list 'compound-procedure
|
||||
(procedure-parameters object)
|
||||
(procedure-body object)
|
||||
'<procedure-env>))
|
||||
(display object)))
|
||||
|
||||
|
||||
(define the-global-environment
|
||||
(setup-environment))
|
||||
|
||||
|
||||
(driver-loop)
|
||||
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
Alyssa's version of analyze sequence has still to do some syntactic analysis at runtime!
|
||||
In our version, analyze-sequence just returns one lambda expression, where env must be applied.
|
||||
In alyssa's version, we run that execute-sequence part recursively, which does syntax analysis. This is slower.
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
```
|
||||
(define (unless condition
|
||||
usual-value
|
||||
exceptional-value)
|
||||
(if condition
|
||||
exceptional-value
|
||||
usual-value))
|
||||
|
||||
(define (factorial n)
|
||||
(unless (= n 1)
|
||||
(* n (factorial (- n 1)))
|
||||
1))
|
||||
```
|
||||
|
||||
In an applicative-order language, the interpreter will try to evaluate all of the arguments of the procesude "unless", and they include a recursive call to the procedure factorial, which in turn includes a call to unless with factorial as argument... and this endless recursion would go on forever.
|
||||
|
||||
This is because, while being very similar to an if block, "unless", as we defined it, doesn't have the peculiar short-stopping propriety that if expressions have, since they are special forms.
|
||||
|
||||
In a normal-order language, this will work.
|
||||
|
|
@ -0,0 +1 @@
|
|||
If unless is implemented as a special form, it would not be possible to manipulate it as any other generic procedure. It can be in fact implemented in terms of an if expression, and they are in fact very similar.
|
||||
|
|
@ -0,0 +1,592 @@
|
|||
(define apply-in-underlying-scheme apply) ;; Saving this for later
|
||||
|
||||
|
||||
(define (make-table) ;; A quick table implementation.
|
||||
(define table '())
|
||||
|
||||
(define (assoc key current)
|
||||
(cond ((null? current) #f)
|
||||
((eq? (caar current) key) (car current))
|
||||
(else (assoc key (cdr current)))))
|
||||
|
||||
(define (lookup key)
|
||||
(let ((record (assoc key table)))
|
||||
(if record (cdr record) #f)))
|
||||
|
||||
(define (insert! key value)
|
||||
(let ((place (assoc key table)))
|
||||
(if place
|
||||
(set-cdr! place value)
|
||||
(set! table (cons (cons key value) table)))))
|
||||
|
||||
|
||||
(define (dispatch m)
|
||||
(cond ((eq? m 'lookup) lookup)
|
||||
((eq? m 'insert!) insert!)
|
||||
(else (display "f you"))
|
||||
))
|
||||
dispatch)
|
||||
|
||||
(define optable (make-table))
|
||||
(define (add-op op fun) ((optable 'insert!) op fun))
|
||||
(define (get-op op) ((optable 'lookup) op))
|
||||
|
||||
|
||||
(define (eval exp env) (display exp) (newline)
|
||||
((analyze exp) env))
|
||||
|
||||
|
||||
(define (analyze exp)
|
||||
(cond ((self-evaluating? exp) (analyze-self-evaluating exp))
|
||||
((variable? exp) (analyze-variable exp))
|
||||
((get-op (car exp)) ((get-op (car exp)) exp))
|
||||
((application? exp) (analyze-application exp))
|
||||
(else (display "FUCK IT!"))
|
||||
))
|
||||
|
||||
(define (assignment? exp) (tagged-list? exp 'set!))
|
||||
(define (definition? exp) (tagged-list? exp 'define))
|
||||
(define (if? exp) (tagged-list? exp 'if))
|
||||
(define (lambda? exp) (tagged-list? exp 'lambda ))
|
||||
(define (begin? exp) (tagged-list? exp 'begin))
|
||||
(define (cond? exp) (tagged-list? exp 'cond))
|
||||
|
||||
(define (analyze-self-evaluating exp) (lambda (en) exp))
|
||||
|
||||
(define (analyze-quoted exp)
|
||||
(let ((qval (text-of-quotation exp)))
|
||||
(lambda (en) qval)))
|
||||
|
||||
(define (analyze-variable exp)
|
||||
(lambda (en) (lookup-variable-value exp en)))
|
||||
|
||||
(define (analyze-assignment exp)
|
||||
(let ((var (assignment-variable exp))
|
||||
(vproc (analyze (assignment-value exp))))
|
||||
(lambda (en) (set-variable-value! var (vproc en) en)
|
||||
'ok)))
|
||||
|
||||
(define (analyze-definition exp)
|
||||
(let ((var (definition-variable exp))
|
||||
(vproc (analyze (definition-value exp))))
|
||||
(lambda (en) (define-variable! var (vproc en) en)
|
||||
'ok)))
|
||||
|
||||
(define (analyze-if exp)
|
||||
(let ((pproc (analyze (if-predicate exp)))
|
||||
(cproc (analyze (if-consequent exp)))
|
||||
(aproc (analyze (if-alternative exp))))
|
||||
(lambda (en)
|
||||
(if (true? (pproc en))
|
||||
(cproc en)
|
||||
(aproc en)))))
|
||||
|
||||
(define (analyze-lambda exp)
|
||||
(let ((vars (lambda-parameters exp))
|
||||
(bproc (analyze-sequence (lambda-body exp))))
|
||||
(lambda (en) (make-procedure vars bproc en))))
|
||||
|
||||
(define (analyze-sequence exps)
|
||||
(define (sequentially proc1 proc2)
|
||||
(lambda (env) (proc1 env) (proc2 env)))
|
||||
(define (loop first-proc rest-procs)
|
||||
(if (null? rest-procs)
|
||||
first-proc
|
||||
(loop (sequentially first-proc (car rest-procs))
|
||||
(cdr rest-procs))))
|
||||
(let ((procs (map analyze exps)))
|
||||
(if (null? procs)
|
||||
(display "Empty sequence: ANALYZE"))
|
||||
(loop (car procs) (cdr procs))))
|
||||
|
||||
(define (analyze-application exp)
|
||||
(let ((fproc (analyze (operator exp)))
|
||||
(aprocs (map analyze (operands exp))))
|
||||
(lambda (env)
|
||||
(execute-application
|
||||
(fproc env)
|
||||
(map (lambda (aproc) (aproc env))
|
||||
aprocs)))))
|
||||
|
||||
|
||||
(define (execute-application proc args)
|
||||
(cond ((primitive-procedure? proc)
|
||||
(apply-primitive-procedure proc args))
|
||||
((compound-procedure? proc)
|
||||
((procedure-body proc)
|
||||
(extend-environment (procedure-parameters proc) args
|
||||
(procedure-environment proc))))
|
||||
(else (display "Unknown procedure type:
|
||||
EXECUTE-APPLICATION"
|
||||
proc))))
|
||||
|
||||
|
||||
(define (list-of-values exps env)
|
||||
(if (no-operands? exps)
|
||||
'()
|
||||
(cons (eval (first-operand exps) env)
|
||||
(list-of-values (rest-operands exps) env))))
|
||||
|
||||
|
||||
(define (tagged-list? exp tag)
|
||||
(if (pair? exp)
|
||||
(eq? tag (car exp))
|
||||
#f))
|
||||
|
||||
|
||||
|
||||
(define (self-evaluating? exp)
|
||||
(cond ((string? exp) #t)
|
||||
((number? exp) #t)
|
||||
(else #f)))
|
||||
|
||||
(define (variable? exp) (symbol? exp))
|
||||
|
||||
;;; Quotations
|
||||
|
||||
;; 'quote <text-of-quotation>
|
||||
|
||||
(define (text-of-quotation exp) (cadr exp))
|
||||
|
||||
|
||||
;;; Assignment 'set!
|
||||
|
||||
;; 'set! <variable> <value>
|
||||
|
||||
(define set-symbol 'set!)
|
||||
(define (make-set variable value) (list set-symbol variable value))
|
||||
|
||||
(define (assignment-variable exp) (cadr exp))
|
||||
(define (assignment-value exp) (caddr exp))
|
||||
|
||||
|
||||
;;Definition 'define
|
||||
|
||||
;; 'define <variable> <value>
|
||||
;; or
|
||||
;; 'define (<procedure-name> <formal parameters>) <body>
|
||||
|
||||
(define define-symbol 'define)
|
||||
(define (make-define-variable variable value) (list define-symbol variable value))
|
||||
(define (make-define-fun proc-name parameters body) (append (list define-symbol (cons proc-name parameters)) body))
|
||||
|
||||
(define (definition-variable exp)
|
||||
(if (symbol? (cadr exp))
|
||||
(cadr exp)
|
||||
(caadr exp)))
|
||||
|
||||
(define (definition-value exp)
|
||||
(if (symbol? (cadr exp))
|
||||
(caddr exp)
|
||||
(make-lambda (cdadr exp) ;; Formal parameters
|
||||
(cddr exp)) ;; Body
|
||||
))
|
||||
|
||||
|
||||
;;Lambda expressions
|
||||
|
||||
;; 'lambda (<formal parameters>) <body>
|
||||
|
||||
(define lambda-symbol 'lambda)
|
||||
(define (make-lambda parameters body)
|
||||
(cons lambda-symbol (cons parameters body)))
|
||||
|
||||
(define (lambda-parameters exp) (cadr exp))
|
||||
|
||||
(define (lambda-body exp) (cddr exp))
|
||||
|
||||
|
||||
;;Let expressions
|
||||
|
||||
;; 'let ((<variable> <expression>)) <body>
|
||||
;; or
|
||||
;; 'let <variable> ((<variable> <expression>)) <body>
|
||||
|
||||
(define let-symbol 'let)
|
||||
(define (make-let bindings body) (append (list let-symbol bindings) body))
|
||||
(define (make-named-let var bindings body) (list let-symbol bindings body))
|
||||
|
||||
(define (named-let? exp) (symbol? (cadr exp)))
|
||||
(define (let-variables exp) (map car (if (named-let? exp) (caddr exp) (cadr exp))))
|
||||
(define (let-expressions exp) (map cadr (if (named-let? exp) (caddr exp) (cadr exp))))
|
||||
(define (let-body exp) (if (named-let? exp) (cdddr exp) (cddr exp)))
|
||||
(define (named-let-variable exp) (cadr exp))
|
||||
|
||||
(define (let->combination exp)
|
||||
(if (named-let? exp)
|
||||
(make-begin (list (make-define-fun (named-let-variable exp) (let-variables exp) (let-body exp))
|
||||
(cons (named-let-variable exp) (let-expressions exp))))
|
||||
(cons (make-lambda (let-variables exp) (let-body exp)) (let-expressions exp))))
|
||||
|
||||
;;Let* expression. Nice!
|
||||
|
||||
;; 'let* ((<variable> <expression)) <body>
|
||||
|
||||
(define let*-symbol 'let*)
|
||||
(define (make-let* bindings body) (append (list let-symbol bindings) body))
|
||||
|
||||
(define (let*-variables exp) (map car (cadr exp)))
|
||||
(define (let*-expressions exp) (map cadr (cadr exp)))
|
||||
(define (let*-body exp) (cddr exp))
|
||||
|
||||
(define (let*->lets exp)
|
||||
(expand-let* (let*-variables exp) (let*-expressions exp) (let*-body exp)))
|
||||
|
||||
|
||||
(define (expand-let* variables expressions body)
|
||||
(if (or (null? (cdr variables)) (null? (cdr expressions))) ;; these should always be the same anyway..
|
||||
(make-let (list (list (car variables) (car expressions)))
|
||||
body)
|
||||
(make-let (list (list (car variables) (car expressions)))
|
||||
(list (expand-let* (cdr variables) (cdr expressions) body)))
|
||||
))
|
||||
|
||||
;;Conditionals
|
||||
|
||||
;; 'if <condition> <consequent> <alternative>
|
||||
|
||||
(define if-symbol 'if)
|
||||
|
||||
(define (make-if predicate consequent alternative)
|
||||
(list if-symbol predicate consequent alternative))
|
||||
|
||||
(define (if-predicate exp) (cadr exp))
|
||||
(define (if-consequent exp) (caddr exp))
|
||||
(define (if-alternative exp) (cadddr exp)) ;; Should we support ifs with no alternative?
|
||||
|
||||
|
||||
;; 'unless <condition> <usual> <exception>
|
||||
|
||||
(define unless-symbol 'unless)
|
||||
|
||||
(define (make-unless condition usual exception)
|
||||
(list unless-symbol condition usual exception))
|
||||
|
||||
(define (unless-predicate exp) (cadr exp))
|
||||
(define (unless-usual exp) (caddr exp))
|
||||
(define (unless-alternative exp) (cadddr exp))
|
||||
|
||||
(define (unless->if exp)
|
||||
(make-if (unless-predicate exp) (unless-alternative exp) (unless-usual exp)))
|
||||
|
||||
;;Begin 'begin
|
||||
|
||||
;; 'begin <expressions>
|
||||
|
||||
(define begin-symbol 'begin)
|
||||
(define (make-begin seq) (cons begin-symbol seq))
|
||||
|
||||
(define (begin-actions exp) (cdr exp))
|
||||
(define (last-exp? seq) (null? (cdr seq)))
|
||||
(define (first-exp seq) (car seq))
|
||||
(define (rest-exps seq) (cdr seq))
|
||||
|
||||
|
||||
(define (sequence->exp seq)
|
||||
(cond ((null? seq) seq)
|
||||
((last-exp? seq) (first-exp seq))
|
||||
(else (make-begin seq))))
|
||||
|
||||
|
||||
|
||||
|
||||
;;Switch case, or cond 'cond
|
||||
|
||||
;; 'cond ((<condition> <consequent))
|
||||
;; or
|
||||
;; 'cond ((<condition> => <function>))
|
||||
;; or
|
||||
;; 'cond ((else <consequent>))
|
||||
|
||||
(define cond-symbol 'cond)
|
||||
(define else-symbol 'else)
|
||||
(define (make-cond clauses) (cons cond-symbol clauses))
|
||||
|
||||
(define (cond-clauses exp) (cdr exp))
|
||||
(define (cond-else-clause? clause) (eq? (cond-predicate clause) else-symbol))
|
||||
|
||||
(define (cond-predicate clause) (car clause))
|
||||
(define (cond-special-syntax? clause) (eq? (cadr clause) '=>))
|
||||
(define (cond-special-syntax-function clause) (caddr clause))
|
||||
(define (cond-actions clause) (cdr clause))
|
||||
|
||||
(define (cond->if exp)
|
||||
(expand-clauses (cond-clauses exp)))
|
||||
|
||||
(define (expand-clauses clauses)
|
||||
(if (null? clauses)
|
||||
'false ; no else clause
|
||||
(let ((first (car clauses))
|
||||
(rest (cdr clauses)))
|
||||
(if (cond-else-clause? first)
|
||||
(if (null? rest)
|
||||
(sequence->exp
|
||||
(cond-actions first))
|
||||
(display "ELSE clause isn't last: COND->IF"))
|
||||
(if (cond-special-syntax? first)
|
||||
(list (make-lambda (list 'x)
|
||||
(list (make-if 'x
|
||||
(list (cond-special-syntax-function first) 'x)
|
||||
(expand-clauses rest))))
|
||||
(cond-predicate first))
|
||||
(make-if (cond-predicate first)
|
||||
(sequence->exp
|
||||
(cond-actions first))
|
||||
(expand-clauses
|
||||
rest)))))))
|
||||
|
||||
;;Or and And
|
||||
|
||||
;; 'or <expressions> <expression> ..
|
||||
|
||||
;; 'and <expression> <expression> ..
|
||||
|
||||
(define or-symbol 'or)
|
||||
(define and-symbol 'and)
|
||||
(define (make-or expressions) (cons or-symbol expressions))
|
||||
(define (make-and expressions) cons and-symbol expressions)
|
||||
|
||||
(define (or-and-clauses exp) (cdr exp))
|
||||
(define (or-and-last-clause? seq) (null? (cdr seq)))
|
||||
|
||||
(define (expand-and->if clauses)
|
||||
(if (null? clauses)
|
||||
'false
|
||||
(if (or-and-last-clause? clauses)
|
||||
(car clauses) ; let's pretend a single clause OR or AND makes sense
|
||||
(make-if (car clauses)
|
||||
(expand-and->if (cdr clauses))
|
||||
'false)
|
||||
)))
|
||||
|
||||
(define (expand-or->if clauses)
|
||||
(if (null? clauses)
|
||||
'false
|
||||
(if (or-and-last-clause? clauses)
|
||||
(car clauses) ; let's pretend a single clause OR or AND makes sense
|
||||
(make-if (car clauses)
|
||||
'true
|
||||
(expand-or->if (cdr clauses)))
|
||||
)))
|
||||
|
||||
(define (or->if exp) (expand-or->if (cdr exp)))
|
||||
(define (and->if exp) (expand-and->if (cdr exp)))
|
||||
|
||||
;; Conditionals
|
||||
|
||||
(define (true? x)
|
||||
(not (eq? x #f)))
|
||||
|
||||
|
||||
(define (false? x)
|
||||
(eq? x #f))
|
||||
|
||||
;; Generic procedures
|
||||
|
||||
|
||||
(define (application? exp) (pair? exp))
|
||||
(define (operator exp) (car exp))
|
||||
(define (operands exp) (cdr exp))
|
||||
(define (no-operands? ops) (null? ops))
|
||||
(define (first-operand ops) (car ops))
|
||||
(define (rest-operands ops) (cdr ops))
|
||||
|
||||
|
||||
(define (make-procedure parameters body env)
|
||||
(list 'procedure parameters body env))
|
||||
|
||||
(define (compound-procedure? p) (tagged-list? p 'procedure))
|
||||
|
||||
(define (procedure-parameters p) (cadr p))
|
||||
|
||||
(define (procedure-body p) (caddr p))
|
||||
|
||||
(define (procedure-environment p) (cadddr p))
|
||||
|
||||
|
||||
;; Optable
|
||||
|
||||
(add-op let*-symbol (lambda (ex) (analyze (let*->lets ex))))
|
||||
(add-op let-symbol (lambda (ex) (analyze (let->combination ex))))
|
||||
(add-op and-symbol (lambda (ex) (analyze (and->if ex))))
|
||||
(add-op or-symbol (lambda (ex) (analyze (or->if ex))))
|
||||
(add-op cond-symbol (lambda (ex) (analyze (cond->if ex))))
|
||||
(add-op begin-symbol (lambda (ex) (analyze-sequence (begin-actions ex))))
|
||||
(add-op lambda-symbol analyze-lambda)
|
||||
(add-op if-symbol analyze-if)
|
||||
(add-op unless-symbol (lambda (ex) (analyze (unless->if ex))))
|
||||
(add-op define-symbol analyze-definition)
|
||||
(add-op set-symbol analyze-assignment)
|
||||
(add-op 'quote analyze-quoted)
|
||||
|
||||
|
||||
(define primitive-procedures
|
||||
|
||||
(list (list 'car car)
|
||||
(list 'cdr cdr)
|
||||
(list 'cons cons)
|
||||
(list 'null? null?)
|
||||
(list 'eq? eq?)
|
||||
(list '+ +)
|
||||
(list '- -)
|
||||
(list '* *)
|
||||
(list '= =)
|
||||
))
|
||||
|
||||
|
||||
;; ENVIRONMENT
|
||||
|
||||
(define (enclosing-environment env) (cdr env))
|
||||
(define (first-frame env) (car env))
|
||||
(define the-empty-environment '())
|
||||
|
||||
(define (make-frame variables values)
|
||||
(cons variables values))
|
||||
|
||||
(define (frame-variables frame) (car frame))
|
||||
|
||||
(define (frame-values frame) (cdr frame))
|
||||
|
||||
(define (add-binding-to-frame! var val frame)
|
||||
(set-car! frame (cons var (car frame)))
|
||||
(set-cdr! frame (cons val (cdr frame))))
|
||||
|
||||
|
||||
(define (extend-environment vars vals base-env)
|
||||
(if (= (length vars) (length vals))
|
||||
(cons (make-frame vars vals) base-env)
|
||||
(if (< (length vars) (length vals))
|
||||
(display "Too many arguments supplied")
|
||||
(display "Too few arguments supplied"))))
|
||||
|
||||
|
||||
(define (lookup-variable-value var env)
|
||||
(define (env-loop env)
|
||||
(define (scan vars vals)
|
||||
(cond ((null? vars)
|
||||
(env-loop
|
||||
(enclosing-environment env)))
|
||||
((eq? var (car vars))
|
||||
(car vals))
|
||||
(else (scan (cdr vars)
|
||||
(cdr vals)))))
|
||||
(if (eq? env the-empty-environment)
|
||||
(begin (display "Unbound variable: ") (display var) (newline))
|
||||
(let ((frame (first-frame env)))
|
||||
(scan (frame-variables frame)
|
||||
(frame-values frame)))))
|
||||
(env-loop env))
|
||||
|
||||
(define (set-variable-value! var val env)
|
||||
(define (env-loop env)
|
||||
(define (scan vars vals)
|
||||
(cond ((null? vars)
|
||||
(env-loop
|
||||
(enclosing-environment env)))
|
||||
((eq? var (car vars))
|
||||
(set-car! vals val))
|
||||
(else (scan (cdr vars)
|
||||
(cdr vals)))))
|
||||
(if (eq? env the-empty-environment)
|
||||
(display "Unbound variable: SET!")
|
||||
(let ((frame (first-frame env)))
|
||||
(scan (frame-variables frame)
|
||||
(frame-values frame)))))
|
||||
(env-loop env))
|
||||
|
||||
(define (define-variable! var val env)
|
||||
(let ((frame (first-frame env)))
|
||||
(define (scan vars vals)
|
||||
(cond ((null? vars)
|
||||
(add-binding-to-frame!
|
||||
var val frame))
|
||||
((eq? var (car vars))
|
||||
(set-car! vals val))
|
||||
(else (scan (cdr vars)
|
||||
(cdr vals)))))
|
||||
(scan (frame-variables frame)
|
||||
(frame-values frame))))
|
||||
|
||||
;; ENV
|
||||
|
||||
(define (primitive-procedure-objects)
|
||||
(map (lambda (proc)
|
||||
(list 'primitive (cadr proc)))
|
||||
primitive-procedures))
|
||||
|
||||
|
||||
(define (primitive-procedure-names)
|
||||
(map car primitive-procedures))
|
||||
|
||||
(define (setup-environment)
|
||||
(let ((initial-env
|
||||
(extend-environment
|
||||
(primitive-procedure-names)
|
||||
(primitive-procedure-objects)
|
||||
the-empty-environment)))
|
||||
(define-variable! 'true #t initial-env)
|
||||
(define-variable! 'false #f initial-env)
|
||||
initial-env))
|
||||
|
||||
|
||||
(define the-global-environment
|
||||
(setup-environment))
|
||||
|
||||
(define (primitive-procedure? proc)
|
||||
(tagged-list? proc 'primitive))
|
||||
|
||||
|
||||
(define (primitive-implementation proc)
|
||||
(cadr proc))
|
||||
|
||||
|
||||
|
||||
(define (apply-primitive-procedure proc args)
|
||||
(apply-in-underlying-scheme
|
||||
(primitive-implementation proc) args))
|
||||
|
||||
|
||||
(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
|
||||
(eval input
|
||||
the-global-environment)))
|
||||
(announce-output output-prompt)
|
||||
(user-print output)))
|
||||
(driver-loop))
|
||||
|
||||
|
||||
|
||||
(define (prompt-for-input string)
|
||||
(newline) (newline)
|
||||
(display string) (newline))
|
||||
|
||||
|
||||
|
||||
(define (announce-output string)
|
||||
(newline) (display string) (newline))
|
||||
|
||||
|
||||
(define (user-print object)
|
||||
(if (compound-procedure? object)
|
||||
(display
|
||||
(list 'compound-procedure
|
||||
(procedure-parameters object)
|
||||
(procedure-body object)
|
||||
'<procedure-env>))
|
||||
(display object)))
|
||||
|
||||
|
||||
(define the-global-environment
|
||||
(setup-environment))
|
||||
|
||||
|
||||
(driver-loop)
|
||||
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
define is strict, meaning that the first id will get evaluated, making count = 1 as we define w.
|
||||
At this point w is equal to a thunk of (id 10). Printing w would evaluate this thunk making count =2, and then memoize it. Thunk is not forever equal to 2.
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
```
|
||||
(define (square x) (* x x))
|
||||
|
||||
(square (id 10))
|
||||
|
||||
count
|
||||
```
|
||||
|
||||
With memoization, this is just 1. Without, (id 10) gets called twice inside (* x x), making count = 2
|
||||
|
|
@ -0,0 +1,536 @@
|
|||
(define apply-in-underlying-scheme apply) ;; Saving this for later
|
||||
|
||||
|
||||
(define (make-table) ;; A quick table implementation.
|
||||
(define table '())
|
||||
|
||||
(define (assoc key current)
|
||||
(cond ((null? current) #f)
|
||||
((eq? (caar current) key) (car current))
|
||||
(else (assoc key (cdr current)))))
|
||||
|
||||
(define (lookup key)
|
||||
(let ((record (assoc key table)))
|
||||
(if record (cdr record) #f)))
|
||||
|
||||
(define (insert! key value)
|
||||
(let ((place (assoc key table)))
|
||||
(if place
|
||||
(set-cdr! place value)
|
||||
(set! table (cons (cons key value) table)))))
|
||||
|
||||
|
||||
(define (dispatch m)
|
||||
(cond ((eq? m 'lookup) lookup)
|
||||
((eq? m 'insert!) insert!)
|
||||
(else (display "f you"))
|
||||
))
|
||||
dispatch)
|
||||
|
||||
(define optable (make-table))
|
||||
(define (add-op op fun) ((optable 'insert!) op fun))
|
||||
(define (get-op op) ((optable 'lookup) op))
|
||||
|
||||
|
||||
(define (eval exp env) (display exp) (newline)
|
||||
(cond ((self-evaluating? exp) exp)
|
||||
((variable? exp) (lookup-variable-value exp env))
|
||||
|
||||
((get-op (car exp)) ((get-op (car exp)) exp env))
|
||||
|
||||
((application? exp) (new-apply (eval (operator exp) env)
|
||||
(list-of-values (operands exp) env)))
|
||||
(else (display "FUCK IT ") (display exp) (newline))
|
||||
))
|
||||
|
||||
|
||||
(define (new-apply procedure arguments)
|
||||
(cond ((primitive-procedure? procedure) (apply-primitive-procedure procedure arguments))
|
||||
((compound-procedure? procedure)
|
||||
(eval-sequence (procedure-body procedure)
|
||||
(extend-environment (procedure-parameters procedure)
|
||||
arguments
|
||||
(procedure-environment procedure))))
|
||||
(else (display "FUCK IT!!!") (pretty-print procedure)
|
||||
)))
|
||||
|
||||
|
||||
|
||||
(define (list-of-values exps env)
|
||||
(if (no-operands? exps)
|
||||
'()
|
||||
(cons (eval (first-operand exps) env)
|
||||
(list-of-values (rest-operands exps) env))))
|
||||
|
||||
(define (eval-if exp env)
|
||||
(if (true? (eval (if-predicate exp) env))
|
||||
(eval (if-consequent exp) env)
|
||||
(eval (if-alternative exp) env)))
|
||||
|
||||
(define (eval-sequence exps env)
|
||||
(cond ((last-exp? exps) (eval (first-exp exps) env))
|
||||
(else (eval (first-exp exps) env)
|
||||
(eval-sequence (rest-exps exps) env))))
|
||||
|
||||
(define (eval-assignment exp env)
|
||||
(set-variable-value! (assignment-variable exp)
|
||||
(eval (definition-value exp) env)
|
||||
env)
|
||||
'ok)
|
||||
|
||||
(define (eval-definition exp env)
|
||||
(define-variable! (definition-variable exp)
|
||||
(eval (definition-value exp) env)
|
||||
env)
|
||||
'ok)
|
||||
|
||||
|
||||
(define (tagged-list? exp tag)
|
||||
(if (pair? exp)
|
||||
(eq? tag (car exp))
|
||||
#f))
|
||||
|
||||
|
||||
|
||||
(define (self-evaluating? exp)
|
||||
(cond ((string? exp) #t)
|
||||
((number? exp) #t)
|
||||
(else #f)))
|
||||
|
||||
(define (variable? exp) (symbol? exp))
|
||||
|
||||
;;; Quotations
|
||||
|
||||
;; 'quote <text-of-quotation>
|
||||
|
||||
(define (text-of-quotation exp) (cadr exp))
|
||||
|
||||
|
||||
|
||||
;;; Assignment 'set!
|
||||
|
||||
;; 'set! <variable> <value>
|
||||
|
||||
(define set-symbol 'set!)
|
||||
(define (make-set variable value) (list set-symbol variable value))
|
||||
|
||||
(define (assignment-variable exp) (cadr exp))
|
||||
(define (assignment-value exp) (caddr exp))
|
||||
|
||||
|
||||
;;Definition 'define
|
||||
|
||||
;; 'define <variable> <value>
|
||||
;; or
|
||||
;; 'define (<procedure-name> <formal parameters>) <body>
|
||||
|
||||
(define define-symbol 'define)
|
||||
(define (make-define-variable variable value) (list define-symbol variable value))
|
||||
(define (make-define-fun proc-name parameters body) (append (list define-symbol (cons proc-name parameters)) body))
|
||||
|
||||
(define (definition-variable exp)
|
||||
(if (symbol? (cadr exp))
|
||||
(cadr exp)
|
||||
(caadr exp)))
|
||||
|
||||
(define (definition-value exp)
|
||||
(if (symbol? (cadr exp))
|
||||
(caddr exp)
|
||||
(make-lambda (cdadr exp) ;; Formal parameters
|
||||
(cddr exp)) ;; Body
|
||||
))
|
||||
|
||||
|
||||
;;Lambda expressions
|
||||
|
||||
;; 'lambda (<formal parameters>) <body>
|
||||
|
||||
(define lambda-symbol 'lambda)
|
||||
(define (make-lambda parameters body)
|
||||
(cons lambda-symbol (cons parameters body)))
|
||||
|
||||
(define (lambda-parameters exp) (cadr exp))
|
||||
|
||||
(define (lambda-body exp) (cddr exp))
|
||||
|
||||
|
||||
;;Let expressions
|
||||
|
||||
;; 'let ((<variable> <expression>)) <body>
|
||||
;; or
|
||||
;; 'let <variable> ((<variable> <expression>)) <body>
|
||||
|
||||
(define let-symbol 'let)
|
||||
(define (make-let bindings body) (append (list let-symbol bindings) body))
|
||||
(define (make-named-let var bindings body) (list let-symbol bindings body))
|
||||
|
||||
(define (named-let? exp) (symbol? (cadr exp)))
|
||||
(define (let-variables exp) (map car (if (named-let? exp) (caddr exp) (cadr exp))))
|
||||
(define (let-expressions exp) (map cadr (if (named-let? exp) (caddr exp) (cadr exp))))
|
||||
(define (let-body exp) (if (named-let? exp) (cdddr exp) (cddr exp)))
|
||||
(define (named-let-variable exp) (cadr exp))
|
||||
|
||||
(define (let->combination exp)
|
||||
(if (named-let? exp)
|
||||
(make-begin (list (make-define-fun (named-let-variable exp) (let-variables exp) (let-body exp))
|
||||
(cons (named-let-variable exp) (let-expressions exp))))
|
||||
(cons (make-lambda (let-variables exp) (let-body exp)) (let-expressions exp))))
|
||||
|
||||
;;Let* expression. Nice!
|
||||
|
||||
;; 'let* ((<variable> <expression)) <body>
|
||||
|
||||
(define let*-symbol 'let*)
|
||||
(define (make-let* bindings body) (append (list let-symbol bindings) body))
|
||||
|
||||
(define (let*-variables exp) (map car (cadr exp)))
|
||||
(define (let*-expressions exp) (map cadr (cadr exp)))
|
||||
(define (let*-body exp) (cddr exp))
|
||||
|
||||
(define (let*->lets exp)
|
||||
(expand-let* (let*-variables exp) (let*-expressions exp) (let*-body exp)))
|
||||
|
||||
|
||||
(define (expand-let* variables expressions body)
|
||||
(if (or (null? (cdr variables)) (null? (cdr expressions))) ;; these should always be the same anyway..
|
||||
(make-let (list (list (car variables) (car expressions)))
|
||||
body)
|
||||
(make-let (list (list (car variables) (car expressions)))
|
||||
(list (expand-let* (cdr variables) (cdr expressions) body)))
|
||||
))
|
||||
|
||||
;;Conditionals
|
||||
|
||||
;; 'if <condition> <consequent> <alternative>
|
||||
|
||||
(define if-symbol 'if)
|
||||
|
||||
(define (make-if predicate consequent alternative)
|
||||
(list if-symbol predicate consequent alternative))
|
||||
|
||||
(define (if-predicate exp) (cadr exp))
|
||||
(define (if-consequent exp) (caddr exp))
|
||||
(define (if-alternative exp) (cadddr exp)) ;; Should we support ifs with no alternative?
|
||||
|
||||
|
||||
|
||||
;;Begin 'begin
|
||||
|
||||
;; 'begin <expressions>
|
||||
|
||||
(define begin-symbol 'begin)
|
||||
(define (make-begin seq) (cons begin-symbol seq))
|
||||
|
||||
(define (begin-actions exp) (cdr exp))
|
||||
(define (last-exp? seq) (null? (cdr seq)))
|
||||
(define (first-exp seq) (car seq))
|
||||
(define (rest-exps seq) (cdr seq))
|
||||
|
||||
|
||||
(define (sequence->exp seq)
|
||||
(cond ((null? seq) seq)
|
||||
((last-exp? seq) (first-exp seq))
|
||||
(else (make-begin seq))))
|
||||
|
||||
|
||||
|
||||
|
||||
;;Switch case, or cond 'cond
|
||||
|
||||
;; 'cond ((<condition> <consequent))
|
||||
;; or
|
||||
;; 'cond ((<condition> => <function>))
|
||||
;; or
|
||||
;; 'cond ((else <consequent>))
|
||||
|
||||
(define cond-symbol 'cond)
|
||||
(define else-symbol 'else)
|
||||
(define (make-cond clauses) (cons cond-symbol clauses))
|
||||
|
||||
(define (cond-clauses exp) (cdr exp))
|
||||
(define (cond-else-clause? clause) (eq? (cond-predicate clause) else-symbol))
|
||||
|
||||
(define (cond-predicate clause) (car clause))
|
||||
(define (cond-special-syntax? clause) (eq? (cadr clause) '=>))
|
||||
(define (cond-special-syntax-function clause) (caddr clause))
|
||||
(define (cond-actions clause) (cdr clause))
|
||||
|
||||
(define (cond->if exp)
|
||||
(expand-clauses (cond-clauses exp)))
|
||||
|
||||
(define (expand-clauses clauses)
|
||||
(if (null? clauses)
|
||||
'false ; no else clause
|
||||
(let ((first (car clauses))
|
||||
(rest (cdr clauses)))
|
||||
(if (cond-else-clause? first)
|
||||
(if (null? rest)
|
||||
(sequence->exp
|
||||
(cond-actions first))
|
||||
(display "ELSE clause isn't last: COND->IF"))
|
||||
(if (cond-special-syntax? first)
|
||||
(list (make-lambda (list 'x)
|
||||
(list (make-if 'x
|
||||
(list (cond-special-syntax-function first) 'x)
|
||||
(expand-clauses rest))))
|
||||
(cond-predicate first))
|
||||
(make-if (cond-predicate first)
|
||||
(sequence->exp
|
||||
(cond-actions first))
|
||||
(expand-clauses
|
||||
rest)))))))
|
||||
|
||||
;;Or and And
|
||||
|
||||
;; 'or <expressions> <expression> ..
|
||||
|
||||
;; 'and <expression> <expression> ..
|
||||
|
||||
(define or-symbol 'or)
|
||||
(define and-symbol 'and)
|
||||
(define (make-or expressions) (cons or-symbol expressions))
|
||||
(define (make-and expressions) cons and-symbol expressions)
|
||||
|
||||
(define (or-and-clauses exp) (cdr exp))
|
||||
(define (or-and-last-clause? seq) (null? (cdr seq)))
|
||||
|
||||
(define (expand-and->if clauses)
|
||||
(if (null? clauses)
|
||||
'false
|
||||
(if (or-and-last-clause? clauses)
|
||||
(car clauses) ; let's pretend a single clause OR or AND makes sense
|
||||
(make-if (car clauses)
|
||||
(expand-and->if (cdr clauses))
|
||||
'false)
|
||||
)))
|
||||
|
||||
(define (expand-or->if clauses)
|
||||
(if (null? clauses)
|
||||
'false
|
||||
(if (or-and-last-clause? clauses)
|
||||
(car clauses) ; let's pretend a single clause OR or AND makes sense
|
||||
(make-if (car clauses)
|
||||
'true
|
||||
(expand-or->if (cdr clauses)))
|
||||
)))
|
||||
|
||||
(define (or->if exp) (expand-or->if (cdr exp)))
|
||||
(define (and->if exp) (expand-and->if (cdr exp)))
|
||||
|
||||
;; Conditionals
|
||||
|
||||
(define (true? x)
|
||||
(not (eq? x #f)))
|
||||
|
||||
|
||||
(define (false? x)
|
||||
(eq? x #f))
|
||||
|
||||
;; Generic procedures
|
||||
|
||||
|
||||
(define (application? exp) (pair? exp))
|
||||
(define (operator exp) (car exp))
|
||||
(define (operands exp) (cdr exp))
|
||||
(define (no-operands? ops) (null? ops))
|
||||
(define (first-operand ops) (car ops))
|
||||
(define (rest-operands ops) (cdr ops))
|
||||
|
||||
|
||||
(define (make-procedure parameters body env)
|
||||
(list 'procedure parameters body env))
|
||||
|
||||
(define (compound-procedure? p) (tagged-list? p 'procedure))
|
||||
|
||||
(define (procedure-parameters p) (cadr p))
|
||||
|
||||
(define (procedure-body p) (caddr p))
|
||||
|
||||
(define (procedure-environment p) (cadddr p))
|
||||
|
||||
|
||||
;; Optable
|
||||
|
||||
(add-op let*-symbol (lambda (ex en) (eval (let*->lets ex) en)))
|
||||
(add-op let-symbol (lambda (ex en) (eval (let->combination ex) en)))
|
||||
(add-op and-symbol (lambda (ex en) (eval (and->if ex) en)))
|
||||
(add-op or-symbol (lambda (ex en) (eval (or->if ex) en)))
|
||||
(add-op cond-symbol (lambda (ex en) (eval (cond->if ex) en)))
|
||||
(add-op begin-symbol (lambda (ex en) (eval-sequence (begin-actions ex) en)))
|
||||
(add-op lambda-symbol (lambda (ex en) (make-procedure (lambda-parameters ex) (lambda-body ex) en)))
|
||||
(add-op if-symbol eval-if)
|
||||
(add-op define-symbol eval-definition)
|
||||
(add-op set-symbol eval-assignment)
|
||||
(add-op 'quote (lambda (ex en) (text-of-quotation ex)))
|
||||
|
||||
|
||||
(define primitive-procedures
|
||||
|
||||
(list (list 'car car)
|
||||
(list 'cdr cdr)
|
||||
(list 'cons cons)
|
||||
(list 'null? null?)
|
||||
(list 'eq? eq?)
|
||||
(list '+ +)
|
||||
(list '- -)
|
||||
(list '* *)
|
||||
(list '= =)
|
||||
))
|
||||
|
||||
|
||||
;; ENVIRONMENT
|
||||
|
||||
(define (enclosing-environment env) (cdr env))
|
||||
(define (first-frame env) (car env))
|
||||
(define the-empty-environment '())
|
||||
|
||||
(define (make-frame variables values)
|
||||
(cons variables values))
|
||||
|
||||
(define (frame-variables frame) (car frame))
|
||||
|
||||
(define (frame-values frame) (cdr frame))
|
||||
|
||||
(define (add-binding-to-frame! var val frame)
|
||||
(set-car! frame (cons var (car frame)))
|
||||
(set-cdr! frame (cons val (cdr frame))))
|
||||
|
||||
|
||||
(define (extend-environment vars vals base-env)
|
||||
(if (= (length vars) (length vals))
|
||||
(cons (make-frame vars vals) base-env)
|
||||
(if (< (length vars) (length vals))
|
||||
(display "Too many arguments supplied")
|
||||
(display "Too few arguments supplied"))))
|
||||
|
||||
|
||||
(define (lookup-variable-value var env)
|
||||
(define (env-loop env)
|
||||
(define (scan vars vals)
|
||||
(cond ((null? vars)
|
||||
(env-loop
|
||||
(enclosing-environment env)))
|
||||
((eq? var (car vars))
|
||||
(car vals))
|
||||
(else (scan (cdr vars)
|
||||
(cdr vals)))))
|
||||
(if (eq? env the-empty-environment)
|
||||
(begin (display "Unbound variable: ") (display var) (newline))
|
||||
(let ((frame (first-frame env)))
|
||||
(scan (frame-variables frame)
|
||||
(frame-values frame)))))
|
||||
(env-loop env))
|
||||
|
||||
(define (set-variable-value! var val env)
|
||||
(define (env-loop env)
|
||||
(define (scan vars vals)
|
||||
(cond ((null? vars)
|
||||
(env-loop
|
||||
(enclosing-environment env)))
|
||||
((eq? var (car vars))
|
||||
(set-car! vals val))
|
||||
(else (scan (cdr vars)
|
||||
(cdr vals)))))
|
||||
(if (eq? env the-empty-environment)
|
||||
(display "Unbound variable: SET!")
|
||||
(let ((frame (first-frame env)))
|
||||
(scan (frame-variables frame)
|
||||
(frame-values frame)))))
|
||||
(env-loop env))
|
||||
|
||||
(define (define-variable! var val env)
|
||||
(let ((frame (first-frame env)))
|
||||
(define (scan vars vals)
|
||||
(cond ((null? vars)
|
||||
(add-binding-to-frame!
|
||||
var val frame))
|
||||
((eq? var (car vars))
|
||||
(set-car! vals val))
|
||||
(else (scan (cdr vars)
|
||||
(cdr vals)))))
|
||||
(scan (frame-variables frame)
|
||||
(frame-values frame))))
|
||||
|
||||
;; ENV
|
||||
|
||||
(define (primitive-procedure-objects)
|
||||
(map (lambda (proc)
|
||||
(list 'primitive (cadr proc)))
|
||||
primitive-procedures))
|
||||
|
||||
|
||||
(define (primitive-procedure-names)
|
||||
(map car primitive-procedures))
|
||||
|
||||
(define (setup-environment)
|
||||
(let ((initial-env
|
||||
(extend-environment
|
||||
(primitive-procedure-names)
|
||||
(primitive-procedure-objects)
|
||||
the-empty-environment)))
|
||||
(define-variable! 'true #t initial-env)
|
||||
(define-variable! 'false #f initial-env)
|
||||
initial-env))
|
||||
|
||||
|
||||
(define the-global-environment
|
||||
(setup-environment))
|
||||
|
||||
(define (primitive-procedure? proc)
|
||||
(tagged-list? proc 'primitive))
|
||||
|
||||
|
||||
(define (primitive-implementation proc)
|
||||
(cadr proc))
|
||||
|
||||
|
||||
|
||||
(define (apply-primitive-procedure proc args)
|
||||
(apply-in-underlying-scheme
|
||||
(primitive-implementation proc) args))
|
||||
|
||||
|
||||
(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
|
||||
(eval input
|
||||
the-global-environment)))
|
||||
(announce-output output-prompt)
|
||||
(user-print output)))
|
||||
(driver-loop))
|
||||
|
||||
|
||||
|
||||
(define (prompt-for-input string)
|
||||
(newline) (newline)
|
||||
(display string) (newline))
|
||||
|
||||
|
||||
|
||||
(define (announce-output string)
|
||||
(newline) (display string) (newline))
|
||||
|
||||
|
||||
(define (user-print object)
|
||||
(if (compound-procedure? object)
|
||||
(display
|
||||
(list 'compound-procedure
|
||||
(procedure-parameters object)
|
||||
(procedure-body object)
|
||||
'<procedure-env>))
|
||||
(display object)))
|
||||
|
||||
|
||||
(define the-global-environment
|
||||
(setup-environment))
|
||||
|
||||
|
||||
(driver-loop)
|
||||
|
||||
|
|
@ -0,0 +1,703 @@
|
|||
(define debug-analyze #f)
|
||||
(define debug-lookup #f)
|
||||
(define debug-application #f)
|
||||
|
||||
(define apply-in-underlying-scheme apply) ;; Saving this for later
|
||||
|
||||
|
||||
(define (make-table) ;; A quick table implementation.
|
||||
(define table '())
|
||||
|
||||
(define (assoc key current)
|
||||
(cond ((null? current) #f)
|
||||
((eq? (caar current) key) (car current))
|
||||
(else (assoc key (cdr current)))))
|
||||
|
||||
(define (lookup key)
|
||||
(let ((record (assoc key table)))
|
||||
(if record (cdr record) #f)))
|
||||
|
||||
(define (insert! key value)
|
||||
(let ((place (assoc key table)))
|
||||
(if place
|
||||
(set-cdr! place value)
|
||||
(set! table (cons (cons key value) table)))))
|
||||
|
||||
|
||||
(define (dispatch m)
|
||||
(cond ((eq? m 'lookup) lookup)
|
||||
((eq? m 'insert!) insert!)
|
||||
(else (display "f you"))
|
||||
))
|
||||
dispatch)
|
||||
|
||||
(define optable (make-table))
|
||||
(define (add-op op fun) ((optable 'insert!) op fun))
|
||||
(define (get-op op) ((optable 'lookup) op))
|
||||
|
||||
|
||||
(define (eval exp env)
|
||||
((analyze exp) env))
|
||||
|
||||
;; analyze
|
||||
|
||||
(define (analyze exp) (cond (debug-analyze (display "ANALIZIN':") (display exp) (newline)))
|
||||
(cond ((self-evaluating? exp) (analyze-self-evaluating exp))
|
||||
((variable? exp) (analyze-variable exp))
|
||||
((get-op (car exp)) ((get-op (car exp)) exp))
|
||||
((application? exp) (analyze-application exp))
|
||||
(else (display "FUCK IT!"))
|
||||
))
|
||||
|
||||
(define (analyze-self-evaluating exp) (lambda (en) exp))
|
||||
|
||||
(define (analyze-quoted exp)
|
||||
(let ((qval (text-of-quotation exp)))
|
||||
(lambda (en) qval)))
|
||||
|
||||
(define (analyze-variable exp)
|
||||
(lambda (en) (lookup-variable-value exp en)))
|
||||
|
||||
(define (analyze-assignment exp)
|
||||
(let ((var (assignment-variable exp))
|
||||
(vproc (analyze (assignment-value exp))))
|
||||
(lambda (en) (set-variable-value! var (vproc en) en)
|
||||
'ok)))
|
||||
|
||||
(define (analyze-definition exp)
|
||||
(let ((var (definition-variable exp))
|
||||
(vproc (analyze (definition-value exp))))
|
||||
(lambda (en) (define-variable! var (vproc en) en)
|
||||
'ok)))
|
||||
|
||||
(define (analyze-if exp)
|
||||
(let ((pproc (analyze (if-predicate exp)))
|
||||
(cproc (analyze (if-consequent exp)))
|
||||
(aproc (analyze (if-alternative exp))))
|
||||
(lambda (en)
|
||||
(if (true? (actual-value pproc en))
|
||||
(cproc en)
|
||||
(aproc en)))))
|
||||
|
||||
(define (analyze-lambda exp)
|
||||
(let ((vars (lambda-parameters exp))
|
||||
(bproc (analyze-sequence (lambda-body exp))))
|
||||
(lambda (en) (make-procedure vars bproc en))))
|
||||
|
||||
(define (analyze-sequence exps)
|
||||
(define (sequentially proc1 proc2)
|
||||
(lambda (env) (proc1 env) (proc2 env)))
|
||||
(define (loop first-proc rest-procs)
|
||||
(if (null? rest-procs)
|
||||
first-proc
|
||||
(loop (sequentially first-proc (car rest-procs))
|
||||
(cdr rest-procs))))
|
||||
(let ((procs (map analyze exps)))
|
||||
(if (null? procs)
|
||||
(display "Empty sequence: ANALYZE"))
|
||||
(loop (car procs) (cdr procs))))
|
||||
|
||||
(define (analyze-pair exp)
|
||||
(let ((xproc (analyze (first-element exp)))
|
||||
(yproc (analyze (second-element exp))))
|
||||
(lambda (en) (make-pair (delay-it xproc en) (delay-it yproc en)))))
|
||||
|
||||
(define (analyze-car exp)
|
||||
(let ((pproc (analyze (car-pair exp))))
|
||||
(lambda (en) (first-force (force-it (pproc en))))))
|
||||
|
||||
(define (analyze-cdr exp)
|
||||
(let ((pproc (analyze (cdr-pair exp))))
|
||||
(lambda (en) (second-force (force-it (pproc en))))))
|
||||
|
||||
|
||||
(define (analyze-application exp)
|
||||
(let ((fproc (analyze (operator exp)))
|
||||
(aprocs (map analyze (operands exp))))
|
||||
(lambda (env)
|
||||
(execute-application
|
||||
(actual-value fproc env)
|
||||
aprocs env))))
|
||||
|
||||
|
||||
(define (execute-application proc arguments env)
|
||||
(cond (debug-application (display "proc:") (user-print proc) (newline)
|
||||
(display "args:") (user-print arguments) (newline)))
|
||||
(cond ((primitive-procedure? proc)
|
||||
(cond (debug-application (display "strict args:")
|
||||
(user-print (list-of-args-values arguments env)) (newline))) ;;debug
|
||||
(apply-primitive-procedure proc (list-of-args-values arguments env)))
|
||||
((compound-procedure? proc)
|
||||
(cond (debug-application (display "delayed args:")
|
||||
(user-print (list-of-delayed-args arguments env)) (newline))) ;;debug
|
||||
((procedure-body proc)
|
||||
(extend-environment (procedure-parameters proc) (list-of-delayed-args arguments env)
|
||||
(procedure-environment proc))))
|
||||
(else (display "Unknown procedure type:
|
||||
EXECUTE-APPLICATION"
|
||||
proc))))
|
||||
|
||||
|
||||
|
||||
;; lazy shit
|
||||
|
||||
(define (actual-value exp env)
|
||||
(force-it (exp env)))
|
||||
|
||||
(define (actual-value-input exp env)
|
||||
(force-it (eval exp env)))
|
||||
|
||||
(define (force-it obj)
|
||||
(cond ((thunk? obj)
|
||||
(let ((result
|
||||
(actual-value
|
||||
(thunk-exp obj)
|
||||
(thunk-env obj))))
|
||||
(set-car! obj 'evaluated-thunk)
|
||||
;; replace exp with its value:
|
||||
(set-car! (cdr obj) result)
|
||||
;; forget unneeded env:
|
||||
(set-cdr! (cdr obj) '())
|
||||
result))
|
||||
((evaluated-thunk? obj)
|
||||
(thunk-value obj))
|
||||
(else obj)))
|
||||
|
||||
(define (delay-it exp env)
|
||||
(list 'thunk exp env))
|
||||
(define (thunk? obj) (tagged-list? obj 'thunk))
|
||||
(define (thunk-exp thunk) (cadr thunk))
|
||||
(define (thunk-env thunk) (caddr thunk))
|
||||
|
||||
(define (evaluated-thunk? obj)
|
||||
(tagged-list? obj 'evaluated-thunk))
|
||||
|
||||
(define (thunk-value evaluated-thunk)
|
||||
(cadr evaluated-thunk))
|
||||
|
||||
|
||||
(define (list-of-args-values exps env)
|
||||
(if (no-operands? exps)
|
||||
'()
|
||||
(cons (actual-value (first-operand exps) env)
|
||||
(list-of-args-values (rest-operands exps) env))))
|
||||
|
||||
(define (list-of-delayed-args exps env)
|
||||
(if (no-operands? exps)
|
||||
'()
|
||||
(cons (delay-it (first-operand exps) env)
|
||||
(list-of-delayed-args (rest-operands exps) env))))
|
||||
|
||||
|
||||
(define (tagged-list? exp tag)
|
||||
(if (pair? exp)
|
||||
(eq? tag (car exp))
|
||||
#f))
|
||||
|
||||
|
||||
|
||||
(define (self-evaluating? exp)
|
||||
(cond ((string? exp) #t)
|
||||
((number? exp) #t)
|
||||
(else #f)))
|
||||
|
||||
(define (variable? exp) (symbol? exp))
|
||||
|
||||
|
||||
;;; Lazy Pairs
|
||||
|
||||
;; 'cons <x> <y>
|
||||
(define cons-symbol 'cons)
|
||||
(define (first-element pair) (cadr pair))
|
||||
(define (second-element pair) (caddr pair))
|
||||
|
||||
(define (first-force pair) (force-it (first-element pair)))
|
||||
(define (second-force pair) (force-it (second-element pair)))
|
||||
|
||||
(define (cons? exp) (tagged-list? exp cons-symbol))
|
||||
|
||||
(define (make-pair x y) (list cons-symbol x y))
|
||||
|
||||
;; 'car <pair>
|
||||
(define car-symbol 'car)
|
||||
(define (car-pair pair) (cadr pair))
|
||||
|
||||
(define (make-car pair) (list car-symbol pair))
|
||||
|
||||
;; 'cdr <pair>
|
||||
(define cdr-symbol 'cdr)
|
||||
(define (cdr-pair pair) (cadr pair))
|
||||
|
||||
(define (make-cdr pair) (list cdr-symbol pair))
|
||||
|
||||
|
||||
|
||||
;;; Quotations
|
||||
|
||||
;; 'quote <text-of-quotation>
|
||||
|
||||
(define (text-of-quotation exp) (cadr exp))
|
||||
|
||||
|
||||
;;; Assignment 'set!
|
||||
|
||||
;; 'set! <variable> <value>
|
||||
|
||||
(define set-symbol 'set!)
|
||||
(define (make-set variable value) (list set-symbol variable value))
|
||||
|
||||
(define (assignment-variable exp) (cadr exp))
|
||||
(define (assignment-value exp) (caddr exp))
|
||||
|
||||
|
||||
;;Definition 'define
|
||||
|
||||
;; 'define <variable> <value>
|
||||
;; or
|
||||
;; 'define (<procedure-name> <formal parameters>) <body>
|
||||
|
||||
(define define-symbol 'define)
|
||||
(define (make-define-variable variable value) (list define-symbol variable value))
|
||||
(define (make-define-fun proc-name parameters body) (append (list define-symbol (cons proc-name parameters)) body))
|
||||
|
||||
(define (definition-variable exp)
|
||||
(if (symbol? (cadr exp))
|
||||
(cadr exp)
|
||||
(caadr exp)))
|
||||
|
||||
(define (definition-value exp)
|
||||
(if (symbol? (cadr exp))
|
||||
(caddr exp)
|
||||
(make-lambda (cdadr exp) ;; Formal parameters
|
||||
(cddr exp)) ;; Body
|
||||
))
|
||||
|
||||
|
||||
;;Lambda expressions
|
||||
|
||||
;; 'lambda (<formal parameters>) <body>
|
||||
|
||||
(define lambda-symbol 'lambda)
|
||||
(define (make-lambda parameters body)
|
||||
(cons lambda-symbol (cons parameters body)))
|
||||
|
||||
(define (lambda-parameters exp) (cadr exp))
|
||||
|
||||
(define (lambda-body exp) (cddr exp))
|
||||
|
||||
|
||||
;;Let expressions
|
||||
|
||||
;; 'let ((<variable> <expression>)) <body>
|
||||
;; or
|
||||
;; 'let <variable> ((<variable> <expression>)) <body>
|
||||
|
||||
(define let-symbol 'let)
|
||||
(define (make-let bindings body) (append (list let-symbol bindings) body))
|
||||
(define (make-named-let var bindings body) (list let-symbol bindings body))
|
||||
|
||||
(define (named-let? exp) (symbol? (cadr exp)))
|
||||
(define (let-variables exp) (map car (if (named-let? exp) (caddr exp) (cadr exp))))
|
||||
(define (let-expressions exp) (map cadr (if (named-let? exp) (caddr exp) (cadr exp))))
|
||||
(define (let-body exp) (if (named-let? exp) (cdddr exp) (cddr exp)))
|
||||
(define (named-let-variable exp) (cadr exp))
|
||||
|
||||
(define (let->combination exp)
|
||||
(if (named-let? exp)
|
||||
(make-begin (list (make-define-fun (named-let-variable exp) (let-variables exp) (let-body exp))
|
||||
(cons (named-let-variable exp) (let-expressions exp))))
|
||||
(cons (make-lambda (let-variables exp) (let-body exp)) (let-expressions exp))))
|
||||
|
||||
;;Let* expression. Nice!
|
||||
|
||||
;; 'let* ((<variable> <expression)) <body>
|
||||
|
||||
(define let*-symbol 'let*)
|
||||
(define (make-let* bindings body) (append (list let-symbol bindings) body))
|
||||
|
||||
(define (let*-variables exp) (map car (cadr exp)))
|
||||
(define (let*-expressions exp) (map cadr (cadr exp)))
|
||||
(define (let*-body exp) (cddr exp))
|
||||
|
||||
(define (let*->lets exp)
|
||||
(expand-let* (let*-variables exp) (let*-expressions exp) (let*-body exp)))
|
||||
|
||||
|
||||
(define (expand-let* variables expressions body)
|
||||
(if (or (null? (cdr variables)) (null? (cdr expressions))) ;; these should always be the same anyway..
|
||||
(make-let (list (list (car variables) (car expressions)))
|
||||
body)
|
||||
(make-let (list (list (car variables) (car expressions)))
|
||||
(list (expand-let* (cdr variables) (cdr expressions) body)))
|
||||
))
|
||||
|
||||
;;Conditionals
|
||||
|
||||
;; 'if <condition> <consequent> <alternative>
|
||||
|
||||
(define if-symbol 'if)
|
||||
|
||||
(define (make-if predicate consequent alternative)
|
||||
(list if-symbol predicate consequent alternative))
|
||||
|
||||
(define (if-predicate exp) (cadr exp))
|
||||
(define (if-consequent exp) (caddr exp))
|
||||
(define (if-alternative exp) (cadddr exp)) ;; Should we support ifs with no alternative?
|
||||
|
||||
|
||||
;;Begin 'begin
|
||||
|
||||
;; 'begin <expressions>
|
||||
|
||||
(define begin-symbol 'begin)
|
||||
(define (make-begin seq) (cons begin-symbol seq))
|
||||
|
||||
(define (begin-actions exp) (cdr exp))
|
||||
(define (last-exp? seq) (null? (cdr seq)))
|
||||
(define (first-exp seq) (car seq))
|
||||
(define (rest-exps seq) (cdr seq))
|
||||
|
||||
|
||||
(define (sequence->exp seq)
|
||||
(cond ((null? seq) seq)
|
||||
((last-exp? seq) (first-exp seq))
|
||||
(else (make-begin seq))))
|
||||
|
||||
|
||||
;;Switch case, or cond 'cond
|
||||
|
||||
;; 'cond ((<condition> <consequent))
|
||||
;; or
|
||||
;; 'cond ((<condition> => <function>))
|
||||
;; or
|
||||
;; 'cond ((else <consequent>))
|
||||
|
||||
(define cond-symbol 'cond)
|
||||
(define else-symbol 'else)
|
||||
(define (make-cond clauses) (cons cond-symbol clauses))
|
||||
|
||||
(define (cond-clauses exp) (cdr exp))
|
||||
(define (cond-else-clause? clause) (eq? (cond-predicate clause) else-symbol))
|
||||
|
||||
(define (cond-predicate clause) (car clause))
|
||||
(define (cond-special-syntax? clause) (eq? (cadr clause) '=>))
|
||||
(define (cond-special-syntax-function clause) (caddr clause))
|
||||
(define (cond-actions clause) (cdr clause))
|
||||
|
||||
(define (cond->if exp)
|
||||
(expand-clauses (cond-clauses exp)))
|
||||
|
||||
(define (expand-clauses clauses)
|
||||
(if (null? clauses)
|
||||
'false ; no else clause
|
||||
(let ((first (car clauses))
|
||||
(rest (cdr clauses)))
|
||||
(if (cond-else-clause? first)
|
||||
(if (null? rest)
|
||||
(sequence->exp
|
||||
(cond-actions first))
|
||||
(display "ELSE clause isn't last: COND->IF"))
|
||||
(if (cond-special-syntax? first)
|
||||
(list (make-lambda (list 'x)
|
||||
(list (make-if 'x
|
||||
(list (cond-special-syntax-function first) 'x)
|
||||
(expand-clauses rest))))
|
||||
(cond-predicate first))
|
||||
(make-if (cond-predicate first)
|
||||
(sequence->exp
|
||||
(cond-actions first))
|
||||
(expand-clauses
|
||||
rest)))))))
|
||||
|
||||
;;Or and And
|
||||
|
||||
;; 'or <expressions> <expression> ..
|
||||
|
||||
;; 'and <expression> <expression> ..
|
||||
|
||||
(define or-symbol 'or)
|
||||
(define and-symbol 'and)
|
||||
(define (make-or expressions) (cons or-symbol expressions))
|
||||
(define (make-and expressions) cons and-symbol expressions)
|
||||
|
||||
(define (or-and-clauses exp) (cdr exp))
|
||||
(define (or-and-last-clause? seq) (null? (cdr seq)))
|
||||
|
||||
(define (expand-and->if clauses)
|
||||
(if (null? clauses)
|
||||
'false
|
||||
(if (or-and-last-clause? clauses)
|
||||
(car clauses) ; let's pretend a single clause OR or AND makes sense
|
||||
(make-if (car clauses)
|
||||
(expand-and->if (cdr clauses))
|
||||
'false)
|
||||
)))
|
||||
|
||||
(define (expand-or->if clauses)
|
||||
(if (null? clauses)
|
||||
'false
|
||||
(if (or-and-last-clause? clauses)
|
||||
(car clauses) ; let's pretend a single clause OR or AND makes sense
|
||||
(make-if (car clauses)
|
||||
'true
|
||||
(expand-or->if (cdr clauses)))
|
||||
)))
|
||||
|
||||
(define (or->if exp) (expand-or->if (cdr exp)))
|
||||
(define (and->if exp) (expand-and->if (cdr exp)))
|
||||
|
||||
;; Conditionals
|
||||
|
||||
(define (true? x)
|
||||
(not (eq? x #f)))
|
||||
|
||||
|
||||
(define (false? x)
|
||||
(eq? x #f))
|
||||
|
||||
;; Generic procedures
|
||||
|
||||
|
||||
(define (application? exp) (pair? exp))
|
||||
(define (operator exp) (car exp))
|
||||
(define (operands exp) (cdr exp))
|
||||
(define (no-operands? ops) (null? ops))
|
||||
(define (first-operand ops) (car ops))
|
||||
(define (rest-operands ops) (cdr ops))
|
||||
|
||||
|
||||
(define (make-procedure parameters body env)
|
||||
(list 'procedure parameters body env))
|
||||
|
||||
(define (compound-procedure? p) (tagged-list? p 'procedure))
|
||||
|
||||
(define (procedure-parameters p) (cadr p))
|
||||
|
||||
(define (procedure-body p) (caddr p))
|
||||
|
||||
(define (procedure-environment p) (cadddr p))
|
||||
|
||||
|
||||
;; Optable
|
||||
|
||||
(add-op car-symbol analyze-car)
|
||||
(add-op cdr-symbol analyze-cdr)
|
||||
(add-op cons-symbol analyze-pair)
|
||||
|
||||
|
||||
(add-op let*-symbol (lambda (ex) (analyze (let*->lets ex))))
|
||||
(add-op let-symbol (lambda (ex) (analyze (let->combination ex))))
|
||||
(add-op and-symbol (lambda (ex) (analyze (and->if ex))))
|
||||
(add-op or-symbol (lambda (ex) (analyze (or->if ex))))
|
||||
(add-op cond-symbol (lambda (ex) (analyze (cond->if ex))))
|
||||
(add-op begin-symbol (lambda (ex) (analyze-sequence (begin-actions ex))))
|
||||
(add-op lambda-symbol analyze-lambda)
|
||||
(add-op if-symbol analyze-if)
|
||||
(add-op define-symbol analyze-definition)
|
||||
(add-op set-symbol analyze-assignment)
|
||||
(add-op 'quote analyze-quoted)
|
||||
|
||||
|
||||
(define primitive-procedures
|
||||
|
||||
(list (list 'null? null?)
|
||||
(list 'eq? eq?)
|
||||
(list '+ +)
|
||||
(list '- -)
|
||||
(list '* *)
|
||||
(list '= =)
|
||||
))
|
||||
|
||||
|
||||
;; ENVIRONMENT
|
||||
|
||||
(define (enclosing-environment env) (cdr env))
|
||||
(define (first-frame env) (car env))
|
||||
(define the-empty-environment '())
|
||||
|
||||
(define (make-frame variables values)
|
||||
(cons variables values))
|
||||
|
||||
(define (frame-variables frame) (car frame))
|
||||
|
||||
(define (frame-values frame) (cdr frame))
|
||||
|
||||
(define (add-binding-to-frame! var val frame)
|
||||
(set-car! frame (cons var (car frame)))
|
||||
(set-cdr! frame (cons val (cdr frame))))
|
||||
|
||||
|
||||
(define (extend-environment vars vals base-env)
|
||||
(if (= (length vars) (length vals))
|
||||
(cons (make-frame vars vals) base-env)
|
||||
(if (< (length vars) (length vals))
|
||||
(display "Too many arguments supplied")
|
||||
(display "Too few arguments supplied"))))
|
||||
|
||||
|
||||
(define (lookup-variable-value var env)
|
||||
(define (env-loop env)
|
||||
(define (scan vars vals)
|
||||
(cond ((null? vars)
|
||||
(env-loop
|
||||
(enclosing-environment env)))
|
||||
((eq? var (car vars))
|
||||
;(cond (debug-lookup (display "LOOKUP: found: ") (user-print (car vals)) (newline)))
|
||||
(car vals))
|
||||
(else (scan (cdr vars)
|
||||
(cdr vals)))))
|
||||
(if (eq? env the-empty-environment)
|
||||
(begin (display "Unbound variable: ") (display var) (newline))
|
||||
(let ((frame (first-frame env)))
|
||||
(scan (frame-variables frame)
|
||||
(frame-values frame)))))
|
||||
(cond (debug-lookup (display "LOOKUP: looking up: ") (display var) (newline)))
|
||||
(env-loop env))
|
||||
|
||||
(define (set-variable-value! var val env)
|
||||
(define (env-loop env)
|
||||
(define (scan vars vals)
|
||||
(cond ((null? vars)
|
||||
(env-loop
|
||||
(enclosing-environment env)))
|
||||
((eq? var (car vars))
|
||||
(set-car! vals val))
|
||||
(else (scan (cdr vars)
|
||||
(cdr vals)))))
|
||||
(if (eq? env the-empty-environment)
|
||||
(display "Unbound variable: SET!")
|
||||
(let ((frame (first-frame env)))
|
||||
(scan (frame-variables frame)
|
||||
(frame-values frame)))))
|
||||
(env-loop env))
|
||||
|
||||
(define (define-variable! var val env)
|
||||
(let ((frame (first-frame env)))
|
||||
(define (scan vars vals)
|
||||
(cond ((null? vars)
|
||||
(add-binding-to-frame!
|
||||
var val frame))
|
||||
((eq? var (car vars))
|
||||
(set-car! vals val))
|
||||
(else (scan (cdr vars)
|
||||
(cdr vals)))))
|
||||
(scan (frame-variables frame)
|
||||
(frame-values frame))))
|
||||
|
||||
;; ENV
|
||||
|
||||
(define (primitive-procedure-objects)
|
||||
(map (lambda (proc)
|
||||
(list 'primitive (cadr proc)))
|
||||
primitive-procedures))
|
||||
|
||||
|
||||
(define (primitive-procedure-names)
|
||||
(map car primitive-procedures))
|
||||
|
||||
(define (setup-environment)
|
||||
(let ((initial-env
|
||||
(extend-environment
|
||||
(primitive-procedure-names)
|
||||
(primitive-procedure-objects)
|
||||
the-empty-environment)))
|
||||
(define-variable! 'true #t initial-env)
|
||||
(define-variable! 'false #f initial-env)
|
||||
initial-env))
|
||||
|
||||
|
||||
(define the-global-environment
|
||||
(setup-environment))
|
||||
|
||||
|
||||
(define (primitive-procedure? proc)
|
||||
(tagged-list? proc 'primitive))
|
||||
|
||||
|
||||
(define (primitive-implementation proc)
|
||||
(cadr proc))
|
||||
|
||||
|
||||
|
||||
(define (apply-primitive-procedure proc args)
|
||||
(apply-in-underlying-scheme
|
||||
(primitive-implementation proc) args))
|
||||
|
||||
|
||||
(define input-prompt ";;; L-Eval input:")
|
||||
|
||||
(define output-prompt ";;; L-Eval value:")
|
||||
|
||||
|
||||
|
||||
(define (driver-loop)
|
||||
(prompt-for-input input-prompt)
|
||||
(let ((input (read)))
|
||||
(let ((output
|
||||
(actual-value-input input
|
||||
the-global-environment)))
|
||||
(announce-output output-prompt)
|
||||
(user-print output)))
|
||||
(driver-loop))
|
||||
|
||||
|
||||
|
||||
(define (prompt-for-input string)
|
||||
(newline) (newline)
|
||||
(display string) (newline))
|
||||
|
||||
|
||||
|
||||
(define (announce-output string)
|
||||
(newline) (display string) (newline))
|
||||
|
||||
|
||||
(define (user-print object)
|
||||
(display (prettify object)))
|
||||
|
||||
(define (prettify obj)
|
||||
(cond ((compound-procedure? obj)
|
||||
(list 'compound-procedure
|
||||
(procedure-parameters obj)
|
||||
(procedure-body obj)
|
||||
'<procedure-env>))
|
||||
((thunk? obj)
|
||||
(display "thrunk:")(prettify (force-it obj)))
|
||||
((evaluated-thunk? obj)
|
||||
(display "thrunk:")(prettify (thunk-value obj)))
|
||||
((cons? obj)
|
||||
(list-transformer obj))
|
||||
;(list (prettify (first-element obj)) (prettify (second-element obj))))
|
||||
((list? obj) (map prettify obj))
|
||||
(else obj)))
|
||||
|
||||
(define (list-transformer l-list)
|
||||
(define count 100)
|
||||
(define (loop slow fast)
|
||||
(cond ((eq? count 0)
|
||||
'list-too-long)
|
||||
((not (cons? (second-element (force-it fast))))
|
||||
(cons (prettify (first-force (force-it fast)))
|
||||
(prettify (second-force (force-it fast)))))
|
||||
((eq? slow fast)
|
||||
(cons (prettify (first-force (force-it fast)))
|
||||
(cons (prettify (first-force (second-force (force-it fast))))
|
||||
'infinite-list)))
|
||||
(else (set! count (- count 1))
|
||||
(cons (first-force (force-it fast))
|
||||
(cons (first-force (second-force (force-it fast)))
|
||||
(loop (second-element slow) (second-element (second-force (force-it fast)))))))))
|
||||
(if (not (pair? (second-force l-list)))
|
||||
(cons (prettify (first-force l-list)) (prettify (second-force l-list)))
|
||||
(cons (prettify (first-force l-list)) (loop l-list (second-element l-list)))))
|
||||
|
||||
|
||||
;(cond ((null? l-list) '())
|
||||
; ((not (cons? l-list)) (prettify l-list))
|
||||
; (else (cons (prettify (first-element l-list))
|
||||
; (list-transformer (second-element l-list))))))
|
||||
|
||||
|
||||
(driver-loop)
|
||||
|
||||
|
||||
|
|
@ -1,3 +1,7 @@
|
|||
(define debug-analyze #f)
|
||||
(define debug-lookup #f)
|
||||
(define debug-application #f)
|
||||
|
||||
(define apply-in-underlying-scheme apply) ;; Saving this for later
|
||||
|
||||
|
||||
|
|
@ -32,57 +36,157 @@
|
|||
(define (get-op op) ((optable 'lookup) op))
|
||||
|
||||
|
||||
(define (eval exp env) (display exp) (newline)
|
||||
(cond ((self-evaluating? exp) exp)
|
||||
((variable? exp) (lookup-variable-value exp env))
|
||||
(define (eval exp env)
|
||||
((analyze exp) env))
|
||||
|
||||
((get-op (car exp)) ((get-op (car exp)) exp env))
|
||||
;; analyze
|
||||
|
||||
((application? exp) (new-apply (eval (operator exp) env)
|
||||
(list-of-values (operands exp) env)))
|
||||
(else (display "FUCK IT ") (display exp) (newline))
|
||||
(define (analyze exp) (cond (debug-analyze (display "ANALIZIN':") (display exp) (newline)))
|
||||
(cond ((self-evaluating? exp) (analyze-self-evaluating exp))
|
||||
((variable? exp) (analyze-variable exp))
|
||||
((get-op (car exp)) ((get-op (car exp)) exp))
|
||||
((application? exp) (analyze-application exp))
|
||||
(else (display "FUCK IT!"))
|
||||
))
|
||||
|
||||
(define (analyze-self-evaluating exp) (lambda (en) exp))
|
||||
|
||||
(define (new-apply procedure arguments)
|
||||
(cond ((primitive-procedure? procedure) (apply-primitive-procedure procedure arguments))
|
||||
((compound-procedure? procedure)
|
||||
(eval-sequence (procedure-body procedure)
|
||||
(extend-environment (procedure-parameters procedure)
|
||||
arguments
|
||||
(procedure-environment procedure))))
|
||||
(else (display "FUCK IT!!!") (pretty-print procedure)
|
||||
)))
|
||||
(define (analyze-quoted exp)
|
||||
(let ((qval (text-of-quotation exp)))
|
||||
(lambda (en) qval)))
|
||||
|
||||
(define (analyze-variable exp)
|
||||
(lambda (en) (lookup-variable-value exp en)))
|
||||
|
||||
(define (analyze-assignment exp)
|
||||
(let ((var (assignment-variable exp))
|
||||
(vproc (analyze (assignment-value exp))))
|
||||
(lambda (en) (set-variable-value! var (vproc en) en)
|
||||
'ok)))
|
||||
|
||||
(define (analyze-definition exp)
|
||||
(let ((var (definition-variable exp))
|
||||
(vproc (analyze (definition-value exp))))
|
||||
(lambda (en) (define-variable! var (vproc en) en)
|
||||
'ok)))
|
||||
|
||||
(define (analyze-if exp)
|
||||
(let ((pproc (analyze (if-predicate exp)))
|
||||
(cproc (analyze (if-consequent exp)))
|
||||
(aproc (analyze (if-alternative exp))))
|
||||
(lambda (en)
|
||||
(if (true? (actual-value pproc en))
|
||||
(cproc en)
|
||||
(aproc en)))))
|
||||
|
||||
(define (analyze-lambda exp)
|
||||
(let ((vars (lambda-parameters exp))
|
||||
(bproc (analyze-sequence (lambda-body exp))))
|
||||
(lambda (en) (make-procedure vars bproc en))))
|
||||
|
||||
(define (analyze-sequence exps)
|
||||
(define (sequentially proc1 proc2)
|
||||
(lambda (env) (proc1 env) (proc2 env)))
|
||||
(define (loop first-proc rest-procs)
|
||||
(if (null? rest-procs)
|
||||
first-proc
|
||||
(loop (sequentially first-proc (car rest-procs))
|
||||
(cdr rest-procs))))
|
||||
(let ((procs (map analyze exps)))
|
||||
(if (null? procs)
|
||||
(display "Empty sequence: ANALYZE"))
|
||||
(loop (car procs) (cdr procs))))
|
||||
|
||||
(define (analyze-pair exp)
|
||||
(let ((xproc (analyze (first-element exp)))
|
||||
(yproc (analyze (second-element exp))))
|
||||
(lambda (en) (make-pair (delay-it xproc en) (delay-it yproc en)))))
|
||||
|
||||
(define (analyze-car exp)
|
||||
(let ((pproc (analyze (car-pair exp))))
|
||||
(lambda (en) (first-force (force-it (pproc en))))))
|
||||
|
||||
(define (analyze-cdr exp)
|
||||
(let ((pproc (analyze (cdr-pair exp))))
|
||||
(lambda (en) (second-force (force-it (pproc en))))))
|
||||
|
||||
|
||||
(define (analyze-application exp)
|
||||
(let ((fproc (analyze (operator exp)))
|
||||
(aprocs (map analyze (operands exp))))
|
||||
(lambda (env)
|
||||
(execute-application
|
||||
(actual-value fproc env)
|
||||
aprocs env))))
|
||||
|
||||
|
||||
(define (execute-application proc arguments env)
|
||||
(cond (debug-application (display "proc:") (user-print proc) (newline)
|
||||
(display "args:") (user-print arguments) (newline)))
|
||||
(cond ((primitive-procedure? proc)
|
||||
(cond (debug-application (display "strict args:")
|
||||
(user-print (list-of-args-values arguments env)) (newline))) ;;debug
|
||||
(apply-primitive-procedure proc (list-of-args-values arguments env)))
|
||||
((compound-procedure? proc)
|
||||
(cond (debug-application (display "delayed args:")
|
||||
(user-print (list-of-delayed-args arguments env)) (newline))) ;;debug
|
||||
((procedure-body proc)
|
||||
(extend-environment (procedure-parameters proc) (list-of-delayed-args arguments env)
|
||||
(procedure-environment proc))))
|
||||
(else (display "Unknown procedure type:
|
||||
EXECUTE-APPLICATION"
|
||||
proc))))
|
||||
|
||||
|
||||
|
||||
(define (list-of-values exps env)
|
||||
;; lazy shit
|
||||
|
||||
(define (actual-value exp env)
|
||||
(force-it (exp env)))
|
||||
|
||||
(define (actual-value-input exp env)
|
||||
(force-it (eval exp env)))
|
||||
|
||||
(define (force-it obj)
|
||||
(cond ((thunk? obj)
|
||||
(let ((result
|
||||
(actual-value
|
||||
(thunk-exp obj)
|
||||
(thunk-env obj))))
|
||||
(set-car! obj 'evaluated-thunk)
|
||||
;; replace exp with its value:
|
||||
(set-car! (cdr obj) result)
|
||||
;; forget unneeded env:
|
||||
(set-cdr! (cdr obj) '())
|
||||
result))
|
||||
((evaluated-thunk? obj)
|
||||
(thunk-value obj))
|
||||
(else obj)))
|
||||
|
||||
(define (delay-it exp env)
|
||||
(list 'thunk exp env))
|
||||
(define (thunk? obj) (tagged-list? obj 'thunk))
|
||||
(define (thunk-exp thunk) (cadr thunk))
|
||||
(define (thunk-env thunk) (caddr thunk))
|
||||
|
||||
(define (evaluated-thunk? obj)
|
||||
(tagged-list? obj 'evaluated-thunk))
|
||||
|
||||
(define (thunk-value evaluated-thunk)
|
||||
(cadr evaluated-thunk))
|
||||
|
||||
|
||||
(define (list-of-args-values exps env)
|
||||
(if (no-operands? exps)
|
||||
'()
|
||||
(cons (eval (first-operand exps) env)
|
||||
(list-of-values (rest-operands exps) env))))
|
||||
(cons (actual-value (first-operand exps) env)
|
||||
(list-of-args-values (rest-operands exps) env))))
|
||||
|
||||
(define (eval-if exp env)
|
||||
(if (true? (eval (if-predicate exp) env))
|
||||
(eval (if-consequent exp) env)
|
||||
(eval (if-alternative exp) env)))
|
||||
|
||||
(define (eval-sequence exps env)
|
||||
(cond ((last-exp? exps) (eval (first-exp exps) env))
|
||||
(else (eval (first-exp exps) env)
|
||||
(eval-sequence (rest-exps exps) env))))
|
||||
|
||||
(define (eval-assignment exp env)
|
||||
(set-variable-value! (assignment-variable exp)
|
||||
(eval (definition-value exp) env)
|
||||
env)
|
||||
'ok)
|
||||
|
||||
(define (eval-definition exp env)
|
||||
(define-variable! (definition-variable exp)
|
||||
(eval (definition-value exp) env)
|
||||
env)
|
||||
'ok)
|
||||
(define (list-of-delayed-args exps env)
|
||||
(if (no-operands? exps)
|
||||
'()
|
||||
(cons (delay-it (first-operand exps) env)
|
||||
(list-of-delayed-args (rest-operands exps) env))))
|
||||
|
||||
|
||||
(define (tagged-list? exp tag)
|
||||
|
|
@ -99,6 +203,35 @@
|
|||
|
||||
(define (variable? exp) (symbol? exp))
|
||||
|
||||
|
||||
;;; Lazy Pairs
|
||||
|
||||
;; 'cons <x> <y>
|
||||
(define cons-symbol 'cons)
|
||||
(define (first-element pair) (cadr pair))
|
||||
(define (second-element pair) (caddr pair))
|
||||
|
||||
(define (first-force pair) (force-it (first-element pair)))
|
||||
(define (second-force pair) (force-it (second-element pair)))
|
||||
|
||||
(define (cons? exp) (tagged-list? exp cons-symbol))
|
||||
|
||||
(define (make-pair x y) (list cons-symbol x y))
|
||||
|
||||
;; 'car <pair>
|
||||
(define car-symbol 'car)
|
||||
(define (car-pair pair) (cadr pair))
|
||||
|
||||
(define (make-car pair) (list car-symbol pair))
|
||||
|
||||
;; 'cdr <pair>
|
||||
(define cdr-symbol 'cdr)
|
||||
(define (cdr-pair pair) (cadr pair))
|
||||
|
||||
(define (make-cdr pair) (list cdr-symbol pair))
|
||||
|
||||
|
||||
|
||||
;;; Quotations
|
||||
|
||||
;; 'quote <text-of-quotation>
|
||||
|
|
@ -106,7 +239,6 @@
|
|||
(define (text-of-quotation exp) (cadr exp))
|
||||
|
||||
|
||||
|
||||
;;; Assignment 'set!
|
||||
|
||||
;; 'set! <variable> <value>
|
||||
|
|
@ -213,7 +345,6 @@
|
|||
(define (if-alternative exp) (cadddr exp)) ;; Should we support ifs with no alternative?
|
||||
|
||||
|
||||
|
||||
;;Begin 'begin
|
||||
|
||||
;; 'begin <expressions>
|
||||
|
|
@ -233,8 +364,6 @@
|
|||
(else (make-begin seq))))
|
||||
|
||||
|
||||
|
||||
|
||||
;;Switch case, or cond 'cond
|
||||
|
||||
;; 'cond ((<condition> <consequent))
|
||||
|
|
@ -351,25 +480,27 @@
|
|||
|
||||
;; Optable
|
||||
|
||||
(add-op let*-symbol (lambda (ex en) (eval (let*->lets ex) en)))
|
||||
(add-op let-symbol (lambda (ex en) (eval (let->combination ex) en)))
|
||||
(add-op and-symbol (lambda (ex en) (eval (and->if ex) en)))
|
||||
(add-op or-symbol (lambda (ex en) (eval (or->if ex) en)))
|
||||
(add-op cond-symbol (lambda (ex en) (eval (cond->if ex) en)))
|
||||
(add-op begin-symbol (lambda (ex en) (eval-sequence (begin-actions ex) en)))
|
||||
(add-op lambda-symbol (lambda (ex en) (make-procedure (lambda-parameters ex) (lambda-body ex) en)))
|
||||
(add-op if-symbol eval-if)
|
||||
(add-op define-symbol eval-definition)
|
||||
(add-op set-symbol eval-assignment)
|
||||
(add-op 'quote (lambda (ex en) (text-of-quotation ex)))
|
||||
(add-op car-symbol analyze-car)
|
||||
(add-op cdr-symbol analyze-cdr)
|
||||
(add-op cons-symbol analyze-pair)
|
||||
|
||||
|
||||
(add-op let*-symbol (lambda (ex) (analyze (let*->lets ex))))
|
||||
(add-op let-symbol (lambda (ex) (analyze (let->combination ex))))
|
||||
(add-op and-symbol (lambda (ex) (analyze (and->if ex))))
|
||||
(add-op or-symbol (lambda (ex) (analyze (or->if ex))))
|
||||
(add-op cond-symbol (lambda (ex) (analyze (cond->if ex))))
|
||||
(add-op begin-symbol (lambda (ex) (analyze-sequence (begin-actions ex))))
|
||||
(add-op lambda-symbol analyze-lambda)
|
||||
(add-op if-symbol analyze-if)
|
||||
(add-op define-symbol analyze-definition)
|
||||
(add-op set-symbol analyze-assignment)
|
||||
(add-op 'quote analyze-quoted)
|
||||
|
||||
|
||||
(define primitive-procedures
|
||||
|
||||
(list (list 'car car)
|
||||
(list 'cdr cdr)
|
||||
(list 'cons cons)
|
||||
(list 'null? null?)
|
||||
(list (list 'null? null?)
|
||||
(list 'eq? eq?)
|
||||
(list '+ +)
|
||||
(list '- -)
|
||||
|
|
@ -411,6 +542,7 @@
|
|||
(env-loop
|
||||
(enclosing-environment env)))
|
||||
((eq? var (car vars))
|
||||
;(cond (debug-lookup (display "LOOKUP: found: ") (user-print (car vals)) (newline)))
|
||||
(car vals))
|
||||
(else (scan (cdr vars)
|
||||
(cdr vals)))))
|
||||
|
|
@ -419,6 +551,7 @@
|
|||
(let ((frame (first-frame env)))
|
||||
(scan (frame-variables frame)
|
||||
(frame-values frame)))))
|
||||
(cond (debug-lookup (display "LOOKUP: looking up: ") (display var) (newline)))
|
||||
(env-loop env))
|
||||
|
||||
(define (set-variable-value! var val env)
|
||||
|
|
@ -476,6 +609,7 @@
|
|||
(define the-global-environment
|
||||
(setup-environment))
|
||||
|
||||
|
||||
(define (primitive-procedure? proc)
|
||||
(tagged-list? proc 'primitive))
|
||||
|
||||
|
|
@ -490,9 +624,9 @@
|
|||
(primitive-implementation proc) args))
|
||||
|
||||
|
||||
(define input-prompt ";;; M-Eval input:")
|
||||
(define input-prompt ";;; L-Eval input:")
|
||||
|
||||
(define output-prompt ";;; M-Eval value:")
|
||||
(define output-prompt ";;; L-Eval value:")
|
||||
|
||||
|
||||
|
||||
|
|
@ -500,7 +634,7 @@
|
|||
(prompt-for-input input-prompt)
|
||||
(let ((input (read)))
|
||||
(let ((output
|
||||
(eval input
|
||||
(actual-value-input input
|
||||
the-global-environment)))
|
||||
(announce-output output-prompt)
|
||||
(user-print output)))
|
||||
|
|
@ -519,18 +653,52 @@
|
|||
|
||||
|
||||
(define (user-print object)
|
||||
(if (compound-procedure? object)
|
||||
(display
|
||||
(list 'compound-procedure
|
||||
(procedure-parameters object)
|
||||
(procedure-body object)
|
||||
'<procedure-env>))
|
||||
(display object)))
|
||||
(display (prettify object)))
|
||||
|
||||
(define (prettify obj)
|
||||
(cond ((compound-procedure? obj)
|
||||
(list 'compounu-ud-procedure
|
||||
(procedure-parameters obj)
|
||||
(procedure-body obj)
|
||||
'<procedure-env>))
|
||||
((thunk? obj)
|
||||
(display "thrunk:")(prettify (force-it obj)))
|
||||
((evaluated-thunk? obj)
|
||||
(display "thrunk:")(prettify (thunk-value obj)))
|
||||
((cons? obj)
|
||||
(list-transformer obj))
|
||||
;(list (prettify (first-element obj)) (prettify (second-element obj))))
|
||||
((list? obj) (map prettify obj))
|
||||
(else obj)))
|
||||
|
||||
(define (list-transformer l-list)
|
||||
(define count 100)
|
||||
(define (loop slow fast)
|
||||
(let ((value (force-it fast)))
|
||||
(cond ((eq? count 0)
|
||||
'list-too-long)
|
||||
((not (and (list? (force-it (second-element value))) (cons? (force-it (second-element value)))))
|
||||
(cons (first-force value)
|
||||
(second-force value)))
|
||||
((eq? slow fast)
|
||||
(cons (first-force value)
|
||||
(cons (first-force (second-force value))
|
||||
'infinite-list)))
|
||||
(else (set! count (- count 1)) (display count) (newline)
|
||||
(cons (first-force value)
|
||||
(cons (first-force (second-force value))
|
||||
(loop (second-element slow) (second-element (second-force value)))))))))
|
||||
(if (not (pair? (second-force l-list)))
|
||||
(cons (first-force l-list) (second-force l-list))
|
||||
(cons (first-force l-list) (loop l-list (second-element l-list)))))
|
||||
|
||||
|
||||
(define the-global-environment
|
||||
(setup-environment))
|
||||
;(cond ((null? l-list) '())
|
||||
; ((not (cons? l-list)) (prettify l-list))
|
||||
; (else (cons (prettify (first-element l-list))
|
||||
; (list-transformer (second-element l-list))))))
|
||||
|
||||
|
||||
(driver-loop)
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue