path: root/main.scm

(add-to-load-path ".")
(add-to-load-path "util/")
(add-to-load-path "prelude/")

(use-modules (environment))
(use-modules (prelude/primitives))
(use-modules (util/alist))

(define (tagged? expr tag)
  (if (pair? expr)
      (eq? (car expr) tag)
      #f))

;;; self-evaluating
(define (self-evaluating? expr)
  (or (number? expr)
      (string? expr)
      (bool? expr)))

(define variable? symbol?)

;;; if-else
(define (make-if predicate consequent alternative)
  (list 'if predicate consequent alternative))
(define (if-else? expr) (tagged? expr 'if))
(define (if-predicate expr) (cadr expr))
(define (if-consequent expr) (caddr expr))
(define (if-alternative expr) 
  (if (not (null? (cdddr expr)))
      (cadddr expr)
      'false))

;;; cond forms
(define (cond-form? expr) (tagged? expr 'cond))
(define (cond-clauses expr) (cdr expr))
(define (cond-predicate clause) (car clause))
(define (cond-consequent clause) (cadr clause))
(define (cond-else? clause) (tagged? clause 'else))
(define (last-clause? clauses) (null? (cdr clauses)))
(define (make-cond clauses) (cons 'cond clauses))
(define (cond->if expr)
  (let ([clauses (cond-clauses expr)])
    (cond
      [(cond-else? (car clauses)) (cond-consequent (car clauses))]
      [(last-clause? clauses) (make-if (cond-predicate (car clauses))
                                       (cond-consequent (car clauses))
                                       'false)]
      [else (make-if (cond-predicate (car clauses))
                     (cond-consequent (car clauses))
                     (cond->if (make-cond (cdr clauses))))])))


;;; function application
(define (function-application? expr) (pair? expr))
(define (operator expr) (car expr))
(define (operands expr) (cdr expr))
(define (no-operands? expr) (null? expr))
(define (list-of-values ls env)
  (map (lambda (l) (eval-expr l env)) ls))

;;; quoted expressions
(define (quote-form? expr) (tagged? expr 'quote))
(define (quotation-text expr) (cadr expr))

;;; assignment
(define (assignment? expr) (tagged? expr 'set!))
(define (assignment-name expr) (cadr expr))
(define (assignment-value expr) (caddr expr))

;;; definition
(define (definition? expr) (tagged? expr 'define))
(define (definition-name expr) (cadr expr))
(define (definition-value expr) (caddr expr))
(define (definition-lambda? expr) (pair? (definition-name expr)))
(define (definition-lambda-name expr) (caadr expr))
(define (definition-lambda-params expr) (cdadr expr))
(define (definition-lambda-body expr) (cddr expr))
(define (make-definition name value) (list 'define name value))
(define (definition->lambda expr)
  (let ([name (definition-lambda-name expr)]
        [params (definition-lambda-params expr)]
        [body (definition-lambda-body expr)])
    (make-definition name
                     (make-lambda params body))))

;;; lambda
(define (lambda-form? expr) (tagged? expr 'lambda))
(define (lambda-params expr) (cadr expr))
(define (lambda-body expr) (cddr expr))
(define (make-lambda params body) 
  (cons 'lambda
        (cons params (scan-out-defines body))))

;;; begin
(define (begin-form? expr) (tagged? expr 'begin))
(define (begin-actions begin-form) (cdr begin-form))
(define (last-action? actions) (null? (cdr actions)))
(define (make-begin actions) (cons 'begin actions))
(define (sequence->expr actions)
  (cond
    [(null? actions) '()]
    [(last-action? actions) (car actions)]
    [else (make-begin actions)]))

;;; let
(define (let-form? expr) (tagged? expr 'let))
(define (let*-form? expr) (tagged? expr 'let*))
(define (named-let-variable expr) (cadr expr))
(define (named-let-form? expr) (and (tagged? expr 'let)
                                    (variable? (named-let-variable expr))))
(define (named-let-bindings expr) (caddr expr))
(define (named-let-body expr) (cdddr expr))
(define (let-bindings expr) (cadr expr))
(define (last-binding? bindings) (null? (cdr bindings)))
(define (let-body expr) (cddr expr))
(define (let-binding-variables bindings) (map car bindings))
(define (let-binding-values bindings) (map cadr bindings))
(define (make-let bindings body) (list 'let bindings body))
(define (make-let* bindings body) (list 'let* bindings body))
(define (let->lambda expr)
  (let ([bindings (let-bindings expr)])
    (make-lambda (let-binding-variables bindings)
                 (let-body expr))))
(define (let*->let expr)
  (let ([bindings (let-bindings expr)]
        [body (sequence->expr (let-body expr))])
    (cond
      [(last-binding? bindings) (make-let bindings body)]
      [else (make-let (list (car bindings))
                      (let*->let (make-let* (cdr bindings) body)))])))
(define (named-let->let expr)
  (let ([name (named-let-variable expr)]
        [body (sequence->expr (named-let-body expr))]
        [bindings (named-let-bindings expr)])
    (let ([new-binding (make-lambda (let-binding-variables bindings)
                                     body)])
      (make-let (cons (list name new-binding)
                      bindings)
                body))))

;;; handle internal definitions
(define (define->set statements)
  (map (lambda (d)
         (cons 'set! (cdr d)))
       statements))
(define (make-unassigned-bindings internal-defines)
  (map (lambda (d)
         (list (definition-name d) ''*unassigned*)) internal-defines))
(define (scan-out-defines body)
  (let ([internal-defines (filter definition? body)]
        [rest (filter (lambda (n) (not (definition? n))) body)])
    (cond 
      [(null? internal-defines) body]
      [else 
        (let ([variables (make-unassigned-bindings internal-defines)])
          (let ([new-bindings (define->set internal-defines)])
            (list (cons 'let (cons variables (append new-bindings rest))))))])))


(define (eval-expr expr env)
  (cond
    [(self-evaluating? expr) expr]
    [(variable? expr) (lookup-variable-value expr env)]
    [(assignment? expr) (eval-assignment expr env)]
    [(definition? expr) (eval-definition expr env)]
    [(quote-form? expr) (quotation-text expr)]
    [(if-else? expr) (eval-if expr env)]
    [(begin-form? expr) (eval-sequence (begin-actions expr) env)]
    [(lambda-form? expr) (make-lambda (lambda-params expr)
                                      (lambda-body expr))]
    [(named-let-form? expr) 'false]
    [(let-form? expr) (eval-let expr env)]
    [(let*-form? expr) (eval-let* expr env)]
    [(cond-form? expr) (eval-cond expr env)]
    [(function-application? expr) (eval-function-application expr env)]))

(define (eval-if expr env)
  (if (true? (eval-expr (if-predicate expr) env))
      (eval-expr (if-consequent expr) env)
      (eval-expr (if-alternative expr) env)))

(define (eval-cond expr env)
  (eval-expr (cond->if expr) env))

(define (eval-sequence exprs env)
  (cond
    [(last-action? exprs) (eval-expr (car exprs) env)]
    [else (begin
            (eval-expr (car exprs) env)
            (eval-sequence (cdr exprs) env))]))

(define (eval-named-let expr env)
  (eval-let (named-let->let expr) env))

(define (eval-let expr env)
  (eval-function-application 
    (cons (let->lambda expr)
          (let-binding-values (let-bindings expr)))
    env))

(define (eval-let* expr env)
  (eval-expr (let*->let expr) env))

(define (eval-assignment expr env)
  (set-variable-value!
    (assignment-name expr)
    (eval-expr (assignment-value expr) env)
    env))

(define (eval-definition expr env)
  (cond
    [(definition-lambda? expr) (eval-expr (definition->lambda expr) env)]
    [else (define-variable! 
            (definition-name expr)
            (eval-expr (definition-value expr) env)
            env)]))

(define (eval-function-application expr env)
  (let ([proc (operator expr)]
        [args (list-of-values (operands expr) env)])
    (cond
      [(primitive? proc) (apply-primitive-proc proc args)]
      [else
        (let ([compound-proc (eval-expr proc env)])
          (eval-sequence
            (lambda-body compound-proc)
            (extend-env (lambda-params compound-proc)
                        args
                        env)))])))

(define (primitive? proc)
  (is-elem-assoc-list proc primitives))

(define (apply-primitive-proc proc args)
  (let ([p (lookup-assoc-list proc primitives)])
    (apply p args)))

(define (apply-expr proc args)
  (cond
    [(primitive? proc) (apply-primitive-proc proc args)]
    [else 'false]))

(define the-global-env (setup-environment))
(define input-prompt ";;; CIRCLE INPUT ")
(define output-prompt ";;; CIRCLE OUTPUT ")
(define (driver-loop)
  (begin
    (newline)
    (display input-prompt)
    (newline)
  (let ([input (read)])
    (let ([output (eval-expr input the-global-env)])
      (begin
        (display output-prompt)
        (newline)
        (show-lisp-expr output)
        (newline)
        (driver-loop))))))

(define (show-lisp-expr object)
  (cond
    [(tagged? object 'lambda)
     (display "#<procedure ")
     (display (lambda-params object))
     (display ">")]
    [else (display object)]))