From: Tim Vaughan Date: Sun, 2 Apr 2017 00:51:18 +0000 (+1200) Subject: Started porting metacircular evaluator from SICP. X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=5c256a740ae9bf1f774e202cbdaf66d8e33f37e7;p=scheme.forth.jl.git Started porting metacircular evaluator from SICP. --- diff --git a/examples/metacirc.scm b/examples/metacirc.scm new file mode 100644 index 0000000..4778591 --- /dev/null +++ b/examples/metacirc.scm @@ -0,0 +1,384 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Mandatory SICP Metacircular Evaluator ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define apply-in-underlying-scheme apply) + +;; Verbatim code from SICP + +(display "eval and apply\n") + +(define (eval exp env) + (cond ((self-evaluating? exp) + exp) + ((variable? exp) + (lookup-variable-value exp env)) + ((quoted? exp) + (text-of-quotation exp)) + ((assignment? exp) + (eval-assignment exp env)) + ((definition? exp) + (eval-definition exp env)) + ((if? exp) + (eval-if exp env)) + ((lambda? exp) + (make-procedure + (lambda-parameters exp) + (lambda-body exp) + env)) + ((begin? exp) + (eval-sequence + (begin-actions exp) + env)) + ((cond? exp) + (eval (cond->if exp) env)) + ((application? exp) + (apply (eval (operator exp) env) + (list-of-values + (operands exp) + env))) + (else + (error "Unknown expression type: EVAL" exp)))) + +(define (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 + (error "Unknown procedure type: APPLY" + 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 (assignment-value exp) env) + env) + 'ok) + +(define (self-evaluating? exp) + (cond ((number? exp) true) + ((string? exp) true) + (else false))) + +(define (variable? exp) (symbol? exp)) + +(define (quoted? exp) + (tagged-list? exp 'quote)) + +(define (text-of-quotation exp) + (cadr exp)) + +(define (tagged-list? exp tag) + (if (pair? exp) + (eq? (car exp) tag) + false)) + +(define (assignment? exp) + (tagged-list? exp 'set!)) + +(define (assignment-variable exp) + (cadr exp)) + +(define (assignment-value exp) (caddr exp)) + +(define (definition? exp) + (tagged-list? exp 'define)) + +(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 + + +(display "lambda... \n") + +(define (lambda? exp) + (tagged-list? exp 'lambda)) +(define (lambda-parameters exp) (cadr exp)) +(define (lambda-body exp) (cddr exp)) + +(define (make-lambda parameters body) + (cons 'lambda (cons parameters body))) + +(define (if? exp) (tagged-list? exp 'if)) +(define (if-predicate exp) (cadr exp)) +(define (if-consequent exp) (caddr exp)) +(define (if-alternative exp) + (if (not (null? (cdddr exp))) + (cadddr exp) + 'false)) + +(define (make-if predicate + consequent + alternative) + (list 'if + predicate + consequent + alternative)) + +(define (begin? exp) + (tagged-list? exp 'begin)) +(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)))) + +(define (make-begin seq) (cons 'begin seq)) + +(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)) + + +(display "cond... \n") + +(define (cond? exp) + (tagged-list? exp 'cond)) +(define (cond-clauses exp) (cdr exp)) +(define (cond-else-clause? clause) + (eq? (cond-predicate clause) 'else)) +(define (cond-predicate clause) + (car 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)) + (error "ELSE clause isn't last: COND->IF" + clauses)) + (make-if (cond-predicate first) + (sequence->exp + (cond-actions first)) + (expand-clauses + rest)))))) + + +(define (true? x) + (not (eq? x false))) + +(define (false? x) + (eq? x false)) + + +(display "make-procedure...\n") + + +(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)) + +(define (enclosing-environment env) (cdr env)) +(define (first-frame env) (car env)) +(define the-empty-environment '()) + + +(display "make-frame\n") + +(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)))) + +(display "extend-environment\n") + +(define (extend-environment vars vals base-env) + (if (= (length vars) (length vals)) + (cons (make-frame vars vals) base-env) + (if (< (length vars) (length vals)) + (error "Too many arguments supplied" + vars + vals) + (error "Too few arguments supplied" + vars + vals)))) + +(display "lookup-variable\n") + +(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) + (error "Unbound variable" var) + (let ((frame (first-frame env))) + (scan (frame-variables frame) + (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) + (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) + (error "Unbound variable: SET!" var) + (let ((frame (first-frame env))) + (scan (frame-variables frame) + (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) + (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)))) + +(display "setup-environment...\n") + +(define (setup-environment) + (let ((initial-env + (extend-environment + (primitive-procedure-names) + (primitive-procedure-objects) + the-empty-environment))) + (define-variable! 'true true initial-env) + (define-variable! 'false false initial-env) + initial-env)) + +(define (primitive-procedure? proc) + (tagged-list? proc 'primitive)) + +(define (primitive-implementation proc) + (cadr proc)) + +(define primitive-procedures + (list (list 'car car) + (list 'cdr cdr) + (list 'cons cons) + (list 'null? null?) + (list '+ +) + (list '- -) + (list '* *))) + +(define (primitive-procedure-names) + (map car primitive-procedures)) + +(define (primitive-procedure-objects) + (map (lambda (proc) + (list 'primitive (cadr proc))) + primitive-procedures)) + + + +(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:") + + +(display "driver-loop...\n") + + +(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) + ')) + (display object))) + +(define the-global-environment + (setup-environment)) diff --git a/src/scheme-library.scm b/src/scheme-library.scm index 14aa6f8..cd26932 100644 --- a/src/scheme-library.scm +++ b/src/scheme-library.scm @@ -13,7 +13,27 @@ (define (cdar l) (cdr (car l))) (define (cddr l) (cdr (cdr l))) (define (cadar l) (car (cdr (car l)))) +(define (caddr l) (car (cdr (cdr l)))) +(define (cadddr l) (car (cdr (cdr (cdr l))))) +;; FUNCTIONAL PROGRAMMING + +(define (fold-left proc init l) + (if (null? l) + init + (fold-left proc (proc init (car l)) (cdr l)))) + +(define (reduce-left proc init l) + (if (null? l) + init + (if (null? (cdr l)) + (car l) + (fold-left proc (proc (car l) (car (cdr l))) (cdr (cdr l)))))) + +(define (map proc l) + (if (null? l) + '() + (cons (proc (car l)) (map proc (cdr l))))) ;; NUMBERS @@ -118,18 +138,6 @@ (define (null? arg) (eq? arg '())) -(define (fold-left proc init l) - (if (null? l) - init - (fold-left proc (proc init (car l)) (cdr l)))) - -(define (reduce-left proc init l) - (if (null? l) - init - (if (null? (cdr l)) - (car l) - (fold-left proc (proc (car l) (car (cdr l))) (cdr (cdr l)))))) - (define (+ . args) (fold-left pair+ 0 args))