learning-sicp

My embarrassing half assed SICP run.
git clone https://kaka.farm/~git/learning-sicp
Log | Files | Refs

exercise-3.scm (4074B)

      1 (define-library (sicp chapter-4 exercise-3)
      2   (import
      3    (scheme base)
      4    (scheme process-context)
      5    (scheme write)
      6 
      7    (srfi :1)
      8    (srfi :64)
      9 
     10    (ice-9 format)
     11    (ice-9 match)
     12    (ice-9 pretty-print)
     13 
     14    (sicp utils))
     15 
     16   (begin
     17     (define *forms-table* '())
     18 
     19     '((define-record-type <compound-procedure>
     20         (make-compound-procedure parameters body env)
     21         compound-procedure?
     22         (parameters compound-procedure-parameters)
     23         (body compound-procedure-body)
     24         (env compound-procedure-env))
     25 
     26       (define (put-form form-type form-handler)
     27         (set! *forms-table*
     28               (alist-cons form-type
     29                           form-handler
     30                           (alist-delete form-type *forms-table*))))
     31 
     32       (define (get-form form-type)
     33         (match (assoc form-type *forms-table*)
     34           (`(,form-type . ,form-handler)
     35            form-handler)
     36           (_ #f)))
     37 
     38       (define (get-variable variable-name env)
     39         (match (assoc variable-name env)
     40           (`(,variable-name . ,variable-value)
     41            variable-value)
     42           (_ (error "Unknown variable:" variable-name))))
     43 
     44       (define (form-symbol exp) (car exp))
     45 
     46       (define host-eval eval)
     47 
     48       (define (eval exp env)
     49         (pretty-print (list 'eval exp))
     50         (match exp
     51           ((? self-evaluating?) exp)
     52           ((? variable?) (lookup-variable-value exp env))
     53           (_
     54            (match (get-form (form-symbol exp))
     55              ((our-form-symbol . our-form-handler)
     56               (our-form-handler
     57                (form-parameters exp)
     58                env))
     59              (_
     60               (match exp
     61                 ((? application? exp)
     62                  (apply (eval (operator exp) env)
     63                         (list-of-values (operands exp) env)))
     64                 (_
     65                  (pretty-print (list "uknown express -- EVAL" exp))
     66                  (error "Unknown expression type -- EVAL" exp))))))))
     67 
     68       (define (form-parameters exp) (cdr exp))
     69 
     70       (define (operator exp) (car exp))
     71       (define (operands exp) (cdr exp))
     72 
     73       (define (application? exp) (pair? exp))
     74 
     75       (define (apply-in-underlying-scheme proc arguments)
     76         (apply proc arguments))
     77 
     78       (define (apply procedure arguments)
     79         (cond ((primitive-procedure? procedure)
     80                (apply-primitive-procedure procedure arguments))
     81               ((compound-procedure? procedure)
     82                (eval-sequence
     83                 (procedure-body procedure)
     84                 (extend-environment
     85                  (procedure-parameters procedure)
     86                  arguments
     87                  (procedure-environment procedure))))
     88               (else
     89                (pretty-print (list "Unknown procedure type -- APPLY" procedure))
     90                (error
     91                 "Unknown procedure type -- APPLY" procedure))))
     92 
     93       (define (primitive-implementation proc) (cadr proc))
     94 
     95       (define (apply-primitive-procedure procedure arguments)
     96         (apply-in-underlying-scheme
     97          (primitive-implementation proc)
     98          arguments))
     99 
    100       (define (primitive-procedure? procedure) (symbol? procedure))
    101 
    102       (define (list-of-values exps env)
    103         (if (no-operands? exps)
    104             '()
    105             (cons (eval (first-operand exps)
    106                         env)
    107                   (list-of-values (rest-operands exps)
    108                                   env))))
    109       (define (first-operand exps) (car exps))
    110       (define (rest-operands exps) (cdr exps))
    111       (define (no-operands? exp) (null? (cdr exp)))
    112 
    113       (define (println-handler exp env)
    114         (display exp) (newline)
    115         (values '() env))
    116 
    117       (define (self-evaluating? exp)
    118         (or (string? exp)
    119             (number? exp)
    120             (null? exp)
    121             (vector? exp)
    122             (symbol? exp)))
    123 
    124       (define (variable? exp) (symbol? exp))
    125 
    126       (define (quote-handler exp env) (cadr exp))
    127 
    128       (put-form 'quote quote-handler)
    129       ((get-form 'quote) '(quote 1) '())
    130 
    131       (eval (quote 1) '())
    132       (eval (list 'quote 1) '())
    133       (eval '(quote a) `())
    134       )))