;;--------------------------------------------------------------------------
;; AriNET Project in Informatics IA by Dominique Guinard
;; dominique.guinard@unifr.ch
;;--------------------------------------------------------------------------
;; my-eval
;;--------------------------------------------------------------------------
; ------------------------------------------------------------
; ABSTRACT:
; *********
; This file contains the functions charged of the
; command evaluation within AriNET.
; It also contains a list of the underlying Scheme
; functions available in AriNET.
; It was partly taken form the book: Structure of Computer
; Programs by Abelson Sussmann. (MIT Press).
; ------------------------------------------------------------
;(load "environment.scm")
;(load "errormsg.scm")
;(load "arinet.scm")
;(load "infix_to_prefix.scm")
;(load "prefix_to_arinet.scm")
(define apply-in-underlying-scheme apply)
(define (my-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) (my-eval (cond->if exp) env))
;added-scheme-functions
((let? exp) (eval-let exp env))
((let*? exp) (eval-let* exp env))
((and? exp) (eval-and exp env))
((or? exp) (eval-or exp env))
;added arinet functions
((defvariable? exp) (eval-defvariable exp env))
((defconstant? exp) (eval-defconstant exp env))
((defconstraint? exp) (eval-defconstraint exp env))
((defmodule? exp) (eval-defmodule exp env))
;end of arinet added functions
((application? exp)
(my-apply (my-eval (operator exp) env)
(list-of-values (operands exp) env)))
(else
(errormsg "Unknown expression type -- EVAL" 'code))))
(define (my-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
(errormsg
"Unknown procedure type -- APPLY" 'code))))
(define (list-of-values exps env)
(if (no-operands? exps)
'()
(cons (my-eval (first-operand exps) env)
(list-of-values (rest-operands exps) env))))
; ------------------------------------------------------------
; evals
; ------------------------------------------------------------
(define (eval-if exp env)
(if (true? (my-eval (if-predicate exp) env))
(my-eval (if-consequent exp) env)
(my-eval (if-alternative exp) env)))
(define (eval-sequence exps env)
(cond ((last-exp? exps) (my-eval (first-exp exps) env))
(else (my-eval (first-exp exps) env)
(eval-sequence (rest-exps exps) env))))
(define (eval-assignment exp env)
(set-variable-value! (assignment-variable exp)
(my-eval (assignment-value exp) env)
env)
"DONE -- Eval Assignement")
(define (eval-definition exp env)
(define-variable! (definition-variable exp)
(my-eval (definition-value exp) env)
env)
"DONE -- Eval Definition")
; eval-let see under "let"
; ------------------------------------------------------------
; predicates
; ------------------------------------------------------------
(define (and? exp)
(tagged-list? exp 'and))
(define (or? exp)
(tagged-list? exp 'or))
(define (let? exp)
(tagged-list? exp 'let))
(define (let*? exp)
(tagged-list? exp 'let*))
(define (defvariable? exp)
(tagged-list? exp 'defvariable))
(define (defconstant? exp)
(tagged-list? exp 'defconstant))
(define (defconstraint? exp)
(tagged-list? exp 'defconstraint))
(define (defmodule? exp)
(tagged-list? exp 'defmodule))
(define (self-evaluating? exp)
(cond ((number? exp) true)
((string? exp) true)
((equal? #f exp) true)
((equal? #t exp) true)
(else false)))
(define true #t)
(define false #f)
(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 (variable? exp) (symbol? exp))
(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)
(cddr exp))))
(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)))
; ------------------------------------------------------------
; let
; ------------------------------------------------------------
(define (let-variables-values expr)
(car (cdr expr)))
(define (let-variables variables-values)
(if (null? variables-values)
'()
(cons (caar variables-values)
(let-variables (cdr variables-values)))))
(define (my-let-values variables-values)
(if (null? variables-values)
'()
(cons (cadar variables-values)
(my-let-values (cdr variables-values)))))
(define (make-lambda-from-let variables body values)
(cons (cons 'lambda (cons variables body)) values))
(define (eval-let exp env)
(my-eval
(make-lambda-from-let (let-variables (let-variables-values exp))
(let-body exp)
(my-let-values (let-variables-values exp)))
env))
(define (let-body expr)
(lambda-body expr))
; ------------------------------------------------------------
; end of let
; ------------------------------------------------------------
; ------------------------------------------------------------
; let*
; ------------------------------------------------------------
(define (make-let variables body)
(cons 'let (cons variables body)))
(define (make-let* variables body)
(cons 'let* (cons variables body)))
(define (let*-variables expr)
(if (null? (cdr expr))
'()
(car (cdr expr))))
(define (let-variables-from-let* expr)
(list (car (car (cdr expr)))))
(define (let*-body expr)
(cdr (cdr expr)))
(define (eval-let* expr env)
(define (convert-for-eval expr)
(if (null? (let*-variables expr))
;variables affectation is done so let's evaluate the body of the let*
(cons 'begin (let*-body expr))
;else convert let* to lets
(make-let (let-variables-from-let* expr)
;making a list to be evaluated by my-eval
(list (convert-for-eval
(make-let* (cdr (let*-variables expr))
(let*-body expr)))))))
(my-eval (convert-for-eval expr) env))
; ------------------------------------------------------------
; end of let*
; ------------------------------------------------------------
; ------------------------------------------------------------
; and
; ------------------------------------------------------------
(define (and-clauses exp)
(cdr exp))
(define (eval-and-clauses clauses env)
(if (null? clauses)
#t
(if (null? (cdr clauses))
(my-eval (car clauses) env)
(if (my-eval (car clauses) env)
(eval-and-clauses (cdr clauses) env)
#f))))
(define (eval-and exp env)
(eval-and-clauses (and-clauses exp)
env))
; ------------------------------------------------------------
; end of and
; ------------------------------------------------------------
; ------------------------------------------------------------
; or
; ------------------------------------------------------------
(define (or-clauses exp)
(cdr exp))
(define (eval-or-clauses clauses env)
(if (null? clauses)
#f
(let ((x (my-eval (car clauses) env)))
(if x
x
(eval-or-clauses (cdr clauses) env)))))
(define (eval-or exp env)
(eval-or-clauses (or-clauses exp)
env))
; ------------------------------------------------------------
; end of or
; ------------------------------------------------------------
; ------------------------------------------------------------
; Arinet end-user functions
; ------------------------------------------------------------
; ------------------------------------------------------------
; defvariable
; ------------------------------------------------------------
(define (defvariable-variables exp)
(cdr exp))
(define (make-definevariable!-from-defvariable variables env)
(if (null? variables)
"DONE -- Defvariable"
;if the variable is already in the list, then overwrite it (like the underlying
;Scheme does but do not add it to the *VARIABLES* again
(begin
(define-variable! (car variables)
(make-variable)
env)
(if (not (member (car variables) *VARIABLES*))
(set! *VARIABLES* (cons (car variables)
*VARIABLES*)))
(make-definevariable!-from-defvariable (cdr variables)
env))))
(define (eval-defvariable exp env)
(make-definevariable!-from-defvariable (defvariable-variables exp) env))
; ------------------------------------------------------------
; end of defvariable
; ------------------------------------------------------------
; ------------------------------------------------------------
; defconstant
; ------------------------------------------------------------
(define (defconstant-variable exp)
(car (cdr exp)))
(define (defconstant-value exp)
(car (cdr (cdr exp))))
(define (eval-defconstant exp env)
(define-variable! (defconstant-variable exp)
(make-variable)
env)
(if (not (member (defconstant-variable exp) *VARIABLES*))
(set! *VARIABLES* (cons (defconstant-variable exp)
*VARIABLES*)))
(my-eval (list
'constant
(defconstant-value exp)
(defconstant-variable exp))
env)
"DONE -- Defconstant")
; ------------------------------------------------------------
; end of defconstant
; ------------------------------------------------------------
; ------------------------------------------------------------
; defconstraint
; ------------------------------------------------------------
(define (defconstraint-constraint exp)
(cdr exp))
(define (eval-defconstraint exp env)
(prefix->arinet (infix->prefix (defconstraint-constraint exp)) env))
; ------------------------------------------------------------
; end of defconstraint
; ------------------------------------------------------------
; ------------------------------------------------------------
; defmodule
; ------------------------------------------------------------
(define (defmodule-name exp)
(car (cdr exp)))
(define (defmodule-parameters exp)
(car (cdr (cdr exp))))
(define (defmodule-body exp)
(cdr (cdr (cdr exp))))
(define (eval-defmodule exp env)
(my-eval (cons 'define
(cons (cons (defmodule-name exp)
(defmodule-parameters exp))
(defmodule-body exp)))
env)
(set! *MODULES* (cons (defmodule-name exp)
*MODULES*)))
; ------------------------------------------------------------
; end of defmodule
; ------------------------------------------------------------
(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))
(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))
(errormsg "ELSE clause is not 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))
(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 (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))
;[do later] (define the-global-environment (setup-environment))
; ------------------------------------------------------------
; my-display
; ------------------------------------------------------------
(define (my-display x)
(print-to-transcript x))
(define (my-newline)
(print-to-transcript " "))
; ------------------------------------------------------------
; end of my-display
; ------------------------------------------------------------
; ------------------------------------------------------------
; primitives
; ------------------------------------------------------------
(define (primitive-procedure? proc)
(tagged-list? proc 'primitive))
(define (primitive-implementation proc) (cadr proc))
(define primitive-procedures
;scheme primitives
(list (list 'car car)
(list 'cdr cdr)
(list 'set-car! set-car!)
(list 'set-cdr! set-cdr!)
(list 'cons cons)
(list 'pair? pair?)
(list 'list list)
(list 'append append)
(list 'null? null?)
(list 'not not)
(list 'newline my-newline)
(list 'display my-display)
(list 'eq? eq?)
(list 'eqv? eqv?)
(list 'equal? equal?)
(list 'odd? odd?)
(list 'even? even?)
(list 'car car)
(list 'cdr cdr)
(list 'cddr cddr)
(list 'caar caar)
(list 'cadr cadr)
(list 'cdar cdar)
(list 'cdddr cdddr)
(list 'caaar caaar)
(list 'caddr caddr)
(list 'caadr caadr)
(list 'cddar cddar)
(list 'cdaar cdaar)
(list 'cdadr cdadr)
(list 'cadar cadar)
(list 'cdaaar cdaaar)
(list 'cdaadr cdaadr)
(list 'cdadar cdadar)
(list 'cdaddr cdaddr)
(list 'cddaar cddaar)
(list 'cddadr cddadr)
(list 'cdddar cdddar)
(list 'cddddr cddddr)
(list 'caaaar caaaar)
(list 'caaadr caaadr)
(list 'caadar caadar)
(list 'caaddr caaddr)
(list 'cadaar cadaar)
(list 'cadadr cadadr)
(list 'caddar caddar)
(list 'cadddr cadddr)
(list 'remainder remainder)
(list 'cons cons)
(list 'null? null?)
(list 'pair? pair?)
(list 'set-car! set-car!)
(list 'set-cdr! set-cdr!)
(list 'length length)
(list 'list-tail list-tail)
(list 'list-ref list-ref)
(list 'memq memq)
(list 'memv memv)
(list 'member member)
(list 'assq assq)
(list 'assv assv)
(list 'assoc assoc)
;prime ops
(list '* *)
(list '+ +)
(list '- -)
(list '/ /)
(list '< <)
(list '<= <=)
(list '= =)
(list '> >)
(list '>= >=)
(list 'abs abs)
(list 'acos acos)
(list 'add1 add1)
(list 'angle angle)
(list 'asin asin)
(list 'atan atan)
(list 'ceiling ceiling)
(list 'complex? complex?)
(list 'cos cos)
(list 'current-seconds current-seconds)
(list 'denominator denominator)
(list 'even? even?)
(list 'exact->inexact exact->inexact)
(list 'exact? exact?)
(list 'exp exp)
(list 'expt expt)
(list 'floor floor)
(list 'gcd gcd)
(list 'imag-part imag-part)
(list 'inexact->exact inexact->exact)
(list 'inexact? inexact?)
(list 'integer->char integer->char)
(list 'integer? integer?)
(list 'lcm lcm)
(list 'log log)
(list 'magnitude magnitude)
(list 'make-polar make-polar)
(list 'max max)
(list 'min min)
(list 'modulo modulo)
(list 'number->string number->string)
(list 'number? number?)
(list 'numerator numerator)
(list 'odd? odd?)
(list 'pi pi)
(list 'quotient quotient)
(list 'random random)
(list 'real-part real-part)
(list 'real? real?)
(list 'remainder remainder)
(list 'round round)
(list 'sin sin)
(list 'sqr sqr)
(list 'sqrt sqrt)
(list 'sub1 sub1)
(list 'tan tan)
(list 'zero? zero?)
;symbols
(list 'symbol? symbol?)
;AriNet primitives
(list 'set-value! set-value!)
(list 'get-value get-value)
(list 'forget-value! forget-value!)
(list 'probe probe)
(list 'has-value? has-value?)
(list 'reset my-reset)
;AriNet Objects
(list 'constant constant)
))
(define (primitive-procedure-names)
(map car
primitive-procedures))
(define (primitive-procedure-objects)
(map (lambda (proc) (list 'primitive (cadr proc)))
primitive-procedures))
;[moved to start of file] (define apply-in-underlying-scheme apply)
(define (apply-primitive-procedure proc args)
(apply-in-underlying-scheme
(primitive-implementation proc) args))
; ------------------------------------------------------------
; end of primitives
; ------------------------------------------------------------
(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 (my-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)))
; ------------------------------------------------------------
; enable driver loop
; ------------------------------------------------------------
;;;Following are commented out so as not to be evaluated when
;;; the file is loaded.
;(define the-global-environment (setup-environment))
;(define ge the-global-environment)
;(driver-loop)
; ------------------------------------------------------------
; end of enable driver loop
; ------------------------------------------------------------
; ------------------------------------------------------------
; end of my-eval
; ------------------------------------------------------------
; ------------------------------------------------------------
; command test zone
; ------------------------------------------------------------
;tests
;(my-eval '(defvariable a b c) ge)
;(my-eval '(defconstraint ((exp a) = b * 2)) ge)
;(my-eval '(defconstraint (b + 2 = 4)) ge)
;(my-eval '(defmodule anne (x y z) (q * p = 5)) ge)
;(my-eval '(defmodule jean (x y z) (q * w = 7)) ge)
;(my-eval '(defmodule dom (x y z w) (q * h = 7 + 1)) ge)
;(define test '(defmodule anne x (q * p = 5)))
;(define t-mod '(defmodule sum (x y)
; (defconstraint (x + y))))
; ------------------------------------------------------------
; end of command test zone
; ------------------------------------------------------------