toy scheme

a_scheme.scm

; racket
(#%require srfi/69 srfi/23)
; chicken
;(require-extension (srfi 69))

(define raise-user-error error)
(define apply-scm apply)

(define (new-eval exp env)
  ((analyze exp) env))

(define (analyze exp)
  (cond ((self-evaluating? exp)
         (analyze-self-evaluating exp))
        ((quoted? exp) (analyze-quoted exp))
        ((variable? exp) (analyze-variable exp))
        ((get-stx (car exp)) => (lambda (f) (f exp)))
        ((application? exp) (analyze-application exp))
        (else (raise-user-error 'analyze "Unknown expression type:" exp))))
(define (analyze-self-evaluating exp)
  (lambda (env) exp))
(define (analyze-quoted exp)
  (let ((qval (text-of-quotation exp)))
    (lambda (env) qval)))
(define (analyze-variable exp)
  (lambda (env) (lookup-variable-value exp env)))
(define (analyze-assignment exp)
  (let ((var (assignment-variable exp))
        (vproc (analyze (assignment-value exp))))
    (lambda (env) (set-variable-value! var (vproc env) env)
       (*void*))))
(define (analyze-if exp)
  (let ((pproc (analyze (if-predicate exp)))
        (cproc (analyze (if-consequent exp)))
        (aproc (analyze (if-alternative exp))))
    (lambda (env)
      (if (true? (pproc env))
          (cproc env)
          (aproc env)))))
(define (analyze-cond exp)
  (analyze (cond->if exp)))
(define (analyze-begin exp)
  (analyze-sequence (begin-actions exp)))
(define (analyze-definition exp)
  (let ((var (definition-variable exp))
        (vproc (analyze (definition-value exp))))
    (lambda (env) (define-variable! var (vproc env) env)
       (*void*))))
(define (analyze-lambda exp)
  (let ((vars (lambda-parameters exp))
        (bproc (analyze-sequence (lambda-body exp))))
    (lambda (env) (make-procedure vars bproc env))))
(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)
        (raise-user-error 'analyze "empty sequence"))
    (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 (analyze-let exp)
  (analyze (let->combination exp)))
(define (analyze-let* exp)
  (analyze (let*->let exp)))
(define (analyze-letrec exp)
  (analyze (transform-letrec exp)))
(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 (raise-user-error 'execute-application "unknown procedure type" proc))))

;; booleans
;; false is false, everything else is truthy.
(define (sc-boolean? exp)
  (or (eq? exp 'true)
      (eq? exp 'false)))
(define (true? exp)
  (not (false? exp)))
(define (false? exp)
  (eq? exp 'false))

;; undefined is used in the expansion of some macros
(define (*undefined*) '*undefined*)
;; void is used when a value should not be returned
(define (*void*) '*void*)
(define (void? exp)
  (or (eq? exp (*void*))
      (tagged-list? exp (*void*))))
(define (undefined? exp) (eq? exp (*undefined*)))
(define syntaxes (make-hash-table))
(define (get-stx id) (hash-table-ref syntaxes id (lambda () #f)))
(define (put-stx! id exp) (hash-table-set! syntaxes id exp))

(define (initialize-stx)
  (begin
    (put-stx! 'quote  analyze-quoted)
    (put-stx! 'lambda analyze-lambda)
    (put-stx! 'cond   analyze-cond)
    (put-stx! 'begin  analyze-begin)
    (put-stx! 'set!   analyze-assignment)
    (put-stx! 'define analyze-definition)
    (put-stx! 'if     analyze-if)
    (put-stx! 'and    analyze-and)
    (put-stx! 'or     analyze-or)
    (put-stx! 'let    analyze-let)
    (put-stx! 'let*   analyze-let*)
    (put-stx! 'letrec analyze-letrec)))

(define (self-evaluating? exp)
  (cond ((void? exp)    #t)
        ((number? exp)  #t)
        ((string? exp)  #t)
        ((sc-boolean? exp) #t)
        (else #f)))
(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)
      #f))
(define (assignment? exp)
  (tagged-list? exp 'set!))
(define (make-assignment var binding) `(set! ,var ,binding))
(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 (make-definition var binding)
  `(define ,var ,binding))

(define (definition-value exp)
  (if (symbol? (cadr exp))
      (caddr exp)
      (make-lambda (cdadr exp)   ; formal parameters
                   (cddr exp)))) ; body

(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)
      (*void*)))

(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-predicate clause)
  (car clause))
(define (cond-actions clause)
  (cdr clause))

(define (cond-else-clause? clause)
  (eq? (cond-predicate clause) 'else))

(define (cond->if exp)
  (expand-clauses (cond-clauses exp)))

(define (cond-arrow-clause? exp)
  (and (list? exp)
       (not (null? (cdr exp)))
       (eq? (cadr exp) '=>)))

(define (cond-arrow-test exp) (car exp))

(define (cond-arrow-recipient exp) (caddr exp))

(define (expand-clauses clauses)
  (if (null? clauses) 'false
      (let ((first (car clauses))
            (rest (cdr clauses)))
        (if (cond-arrow-clause? first)
            (make-if (cond-predicate first)
                     (list (cond-arrow-recipient first)
                           (cond-arrow-test first))
                     (expand-clauses rest))
            (if (cond-else-clause? first)
                (if (null? rest)
                    (sequence->exp (cond-actions first))
                    (raise-user-error 'cond "ELSE clause isn't last ~a" clauses))
                (make-if (cond-predicate first)
                         (sequence->exp (cond-actions first))
                         (expand-clauses rest)))))))
; and/or

(define (analyze-and exp)
  (analyze (expand-and exp)))
(define (expand-and exp)
  (letrec ((expand-loop
            (lambda (preds)
              (if (null? preds)
                  'true
                  (make-if (car preds)
                           (expand-loop (cdr preds))
                           'false)))))
    (if (null? (cdr exp))
        'false
        (expand-loop (cdr exp)))))
(define (analyze-or exp)
  (analyze (expand-or exp)))
(define (expand-or exp)
  (letrec ((expand-loop
            (lambda (preds)
              (if (null? preds)
                  'false
                  (make-if (car preds)
                           'true
                           (expand-loop (cdr preds)))))))
    (if (null? (cdr exp))
        'true
        (expand-loop (cdr exp)))))



(define (let-bindings exp)
  (cadr exp))

(define (let-body exp)
  (caddr exp))

;; todo: make more of the code use the function below.
(define (make-let bindings body)
  `(let ,bindings ,body))


(define (let-get-vars/exprs f)
  (lambda (exp)
    (define (rec-let-get-vars/exprs binding-list acc-list)
      (cond ((null? binding-list) (reverse acc-list))
            ((not (pair? (car binding-list)))
             (raise-user-error 'let "Not a variable-expression pair in let-clause ~a" exp))
            (else (rec-let-get-vars/exprs (cdr binding-list) (cons (f (car binding-list)) acc-list)))))
    (rec-let-get-vars/exprs (let-bindings exp) '())))

(define let-exprs (let-get-vars/exprs cadr))

(define let-vars (let-get-vars/exprs car))

(define (let*? exp) (tagged-list? exp 'let*))
(define (let*->let exp)
  (if (<= (length (let-bindings exp)) 1)
      `(let ,(let-bindings exp) ,(let-body exp))
      `(let (,(car (let-bindings exp)))
         ,(let*->let `(let* ,(cdr (let-bindings exp)) ,(let-body exp))))))

(define (named-let? exp)
  (and (eq? (car exp) 'let)
       (symbol? (cadr exp))))

; named-let
(define (named-let-body exp) (cadddr exp))

(define (named-let-bindings exp) (caddr exp))

(define (named-let-name exp) (cadr exp))

(define (named-let-vars exp)
  (map car (named-let-bindings exp)))

(define (named-let-inits exp)
  (map cadr (named-let-bindings exp)))

(define (expand-named-let exp)
  (sequence->exp
   `((define (,(named-let-name exp) ,@(named-let-vars exp)) ,(named-let-body exp))
     (,(named-let-name exp) ,@(named-let-inits exp)))))

(define (let->combination exp)
  (if (named-let? exp)
      (expand-named-let exp)
      (if (null? (let-body exp))
          (raise-user-error 'let "Body of let clause must not be empty ~a" exp)
          (cons (make-lambda (let-vars exp) (list (let-body exp)))
                (let-exprs exp)))))
(define (letrec? exp)
  (tagged-list? exp 'letrec))
(define (letrec-bindings expr)
  (cadr expr))
(define (letrec-body expr)
  (cddr expr))

(define (transform-letrec exp)
  (make-let
   (map (lambda (binding)
          (list (car binding) `(quote ,(*undefined*))))
        (letrec-bindings exp))
   (make-begin
    (append
     (map (lambda (binding)
            (make-assignment
             (car binding)
             (cadr binding)))
          (letrec-bindings exp))
     (letrec-body exp)))))

(define (scan-out-defines exp-body)
  (let* ((defs+other
           (let scan 
             ((exp   exp-body)
              (defs  '())
              (other '()))
             (if (null? exp)
                 (cons (reverse defs) (reverse other))
                 (if (definition? (car exp))
                     (scan (cdr exp)
                           (cons (car exp) defs)
                           other)
                     (scan (cdr exp)
                           defs
                           (cons (car exp) other))))))
         (defs (car defs+other))
         (other (cdr defs+other)))
    (if (null? defs) exp-body
        (begin (display defs) (newline)
         (list
          (make-let (map (lambda (def)
                           `(,(definition-variable def)
                             (quote ,(*undefined*))))
                         defs)
                    (make-begin
                     (append
                      (map (lambda (def)
                             (make-assignment
                              (definition-variable def)
                              (definition-value def)))
                           defs)
                      other))))))))

; procedures

(define (make-procedure parameters body env)
  (list 'procedure parameters body env ;(scan-out-defines 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))

;; environment and env. frames

(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 (find-binding-in-frame frame var)
  (let scan ((vars (frame-variables frame))
             (vals (frame-values frame)))
    (cond ((null? vars)
           (cons #f '()))
          ((eq? var (car vars))
           (cons #t (car vals)))
          (else (scan (cdr vars) (cdr vals))))))

(define (set-binding-in-frame! frame var val)
  (let scan ((vars (frame-variables frame))
             (vals (frame-values frame)))
    (cond ((null? vars) #f)
          ((eq? var (car vars))
           (set-car! vals val) #t)
          (else (scan (cdr vars) (cdr vals))))))

(define (add-binding-to-frame! frame var val)
  (set-car! frame (cons var (car frame)))
  (set-cdr! frame (cons val (cdr frame))))

(define (lookup-variable-value var env) 
      (let env-loop ((cenv env))
        (if (eq? cenv the-empty-environment)
            (raise-user-error "Unbound variable!" var)
            (let ((result (find-binding-in-frame (first-frame cenv) var)))
              (if (car result)
                  (if (eq? (cdr result) (*undefined*))
                      (raise-user-error "Variable is not yet defined: " var)
                      (cdr result))
                  (env-loop (enclosing-environment cenv)))))))

(define (set-variable-value! var val env)
  (let env-loop ((cenv env))
    (if (eq? cenv the-empty-environment)
        (raise-user-error "Unbound Variable!" var)
        (if (set-binding-in-frame! (first-frame cenv) var val)
            (*void*)
            (env-loop (enclosing-environment cenv))))))

(define (define-variable! var val env)
  (let ((frame (first-frame env)))
    (if (set-binding-in-frame! frame var val)
        (*void*)
        (add-binding-to-frame! frame var val))))
(define (extend-environment vars vals base-env)
  (cond ((= (length vars) (length vals))
         (cons (make-frame vars vals) base-env))
        (else
         (raise-user-error 
          'extend-environment 
          "Binding expression unbalanced! ~nvars: ~a~nexpressions: ~a"
          vars vals))))
; primitives
(define (primitive-procedure? proc)
  (tagged-list? proc 'primitive))
(define (primitive-implementation proc)
  (cadr proc))
(define (make-boolean-expr test) 
  (lambda args (if (apply-scm test args) 'true 'false)))
(define primitive-procedures
  `((car            ,car)
    (cdr            ,cdr)
    (cons           ,cons)
    (null?          ,(make-boolean-expr null?))
    (list?          ,(make-boolean-expr list?))
    (list           ,list)
    (+              ,+)
    (-              ,-)
    (/              ,/)
    (*              ,*)
    (=              ,(make-boolean-expr =))
    (>              ,(make-boolean-expr >))
    (<              ,(make-boolean-expr <))
    (eq?            ,(make-boolean-expr eq?))
    (<=             ,(make-boolean-expr <=))
    (not            ,(lambda (x) (if (eq? x 'false) 'true 'false)))
    (>=             ,(make-boolean-expr >=))
    (floor          ,floor)
    (ceiling        ,ceiling)
    (truncate       ,truncate)
    (round          ,round)
    (exact->inexact ,exact->inexact)
    (inexact->exact ,inexact->exact)
    (exp            ,exp)
    (log            ,log)
    (sin            ,sin)
    (cos            ,cos)
    (tan            ,tan)
    (expt           ,expt)
    (asin           ,asin)
    (acos           ,acos)
    (atan           ,atan)
    (number->string ,number->string)
    (string->number ,string->number)))
(define (primitive-procedure-names)
  (map car primitive-procedures))
(define (primitive-procedure-objects)
  (map 
   (lambda (proc) (list 'primitive (cadr proc))) 
   primitive-procedures))

;; setup

(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)
    (define-variable! '#t    'true initial-env)
    (define-variable! '#f    'false initial-env)
    initial-env))

(define the-global-environment (setup-environment))

(define (apply-primitive-procedure proc args)
  (apply-scm (primitive-implementation proc) args))


(initialize-stx)

;; finally, input for the interpreter

(define input-prompt  "~> ")

(define (interpret exp) (new-eval exp the-global-environment))

(define (driver-loop)
  (prompt-for-input input-prompt)
  (let ((input (read)))
    (cond ((and (not (eof-object? input))
                (not (eq? input 'exit))) 
              (let ((evaled (interpret input)))
                (user-print evaled)
                (driver-loop)))
           (else
            (newline)
            (display "GOODBYE.")
            (newline)))))
(define (prompt-for-input str)
  (begin
    (display str)))
(define (user-print object)
  (cond ((void? object) (if #f #f))
        ((compound-procedure? object)
         (display (list 'compound-procedure
                        (procedure-parameters object)
                        (procedure-body object)
                        '<procedure-env>))
         (newline))
        (else (display object)
              (newline))))

(define (start)
    (display "WELCOME TO SCHEME.")
    (newline)
    (driver-loop))
(start)