問題4.14

  • はてなDiaryの一日の文字数制限なのか、途中できられていたので書き直す。
;;;
;;; util
;;;

(define (tagged-list? exp tag)
  (if (pair? exp)
      (eq? (car exp) tag)
      #f))

;;;
;;; environment
;;;

;basic-proc
(define the-empty-environment '())
(define enclosing-environment cdr)
(define first-frame car)

;frame-proc
(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))))

;env-proc
(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 -- EXTEND_ENVIRONMENT " vars vals)
          (error "Too few arguments supplied -- EXTEND_ENVIRONMENT " vars vals))))

(define (env-loop null-proc find-proc name var env)
  (define (scan vars vals)
    (cond ((null? vars) (null-proc env))
          ((eq? var (car vars)) (find-proc vals))
          (else (scan (cdr vars) (cdr vals)))))
  (if (eq? env the-empty-environment)
      (error "Unbound variable. -- " name " " var)
      (let ((frame (first-frame env)))
        (scan (frame-variables frame)
              (frame-values frame)))))

(define (lookup-variable-value var env)
  (define (null-proc env)
    (env-loop null-proc find-proc "LOOKUP_VARIABLE_VALUE" var (enclosing-environment env)))
  (define (find-proc vals) (car vals))
  (env-loop null-proc find-proc "LOOKUP_VARIABLE_VALUE" var env))

(define (set-variable-value! var val env)
  (define (null-proc env)
    (env-loop null-proc find-proc "SET_VARIABLE_VALUE!" var (enclosing-environment env)))
  (define (find-proc vals) (set-car! vals val))
  (env-loop null-proc find-proc "SET_VARIABLE_VALUE!" var env))

(define (define-variable! var val env)
  (define (null-proc env) (add-binding-to-frame! var val (first-frame env)))
  (define (find-proc vals) (set-car! vals val))
  (env-loop null-proc find-proc "DEFINE_VARIABLE!" var env))

(define (make-unbound-variable! var env)
  (define (env-loop env)
    (define (scan prev-vars vars prev-vals vals)
      (cond ((null? vars)
             (env-loop (enclosing-envrionment env)))
            ((eq? var (car vars))
             (set-cdr! prev-vars (cdr vars))
             (set-cdr! prev-vals (cdr vals)))
            (else (scan (cdr prev-vars) (cdr vars)
                        (cdr prev-vals) (cdr vals)))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable. -- MAKE_UNBOUND_VARIABLE! " var)
        (let ((frame (first-frame env)))
          (if (eq? var (car (frame-variables frame)))
              (begin
                (set-car! frame (cdr (frame-variables frame)))
                (set-cdr! frame (cdr (frame-values frame))))
              (scan (frame-variables frame) (cdr (frame-variables frame))
                    (frame-values frame) (cdr (frame-values frame)))))))
  (env-loop env))


;;;
;;; procedures
;;;

(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 (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? (lambda (x) (if (null? x) 'true 'false)))))

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


;;;
;;; table
;;;

(define (make-table)
  (let ((local-table (list '*table*)))
    (define (lookup key-1 key-2)
      (let ((subtable (assoc key-1 (cdr local-table))))
        (if subtable
            (let ((record (assoc key-2 (cdr subtable))))
              (if record
                  (cdr record)
                  #f))
            #f)))
    (define (insert! key-1 key-2 value)
      (let ((subtable (assoc key-1 (cdr local-table))))
        (if subtable
            (let ((record (assoc key-2 (cdr subtable))))
              (if record
                  (set-cdr! record value)
                  (set-cdr! subtable
                            (cons (cons key-2 value)
                                  (cdr subtable)))))
            (set-cdr! local-table
                      (cons (list key-1
                                  (cons key-2 value))

                            (cdr local-table)))))
      'ok)
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            (else (error "Unknown operation -- TABLE" m))))
    dispatch))

(define the-table (make-table))
(define get (the-table 'lookup-proc))
(define put (the-table 'insert-proc!))

;;;
;;; eval
;;;

(define (self-evaluating? exp)
  (cond ((number? exp) #t)
        ((string? exp) #t)
        (else #f)))
(define variable? symbol?)
(define application? pair?)
(define operator car)
(define operands cdr)
(define first-operand car)
(define rest-operands cdr)
(define no-operands? null?)
(define (list-of-values exps env)
  (if (no-operands? exps)
      '()
      (cons (aeval (first-operand exps) env)
            (list-of-values (rest-operands exps) env))))

(define (aeval exp env)
  (cond ((self-evaluating? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        (else
         (let ((proc (get 'eval (car exp))))
           (if proc
               (proc exp env)
               (if (application? exp)
                   (aapply (aeval (operator exp) env)
                           (list-of-values (operands exp) env))
                   (error "Unknown expression type -- EVAL " exp)))))))

(define (install-eval-package)
  ;; quote
  (define (text-of-quotation exp env) (cadr exp))

  ;; set!
  (define (assignment-variable exp) (cadr exp))
  (define (assignment-value exp) (caddr exp))
  (define (eval-assignment exp env)
    (set-variable-value! (assignment-variable exp)
                         (aeval (assignment-value exp) env)
                         env))

  ;; unbind!
  (define (unbind-variable exp) (cadr exp))
  (define (eval-unbind exp env)
    (make-unbound-variable! (unbind-variable exp) env))

  ;; define
  (define (make-lambda parameters body) (cons 'lambda (cons parameters body)))
  (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 (eval-definition exp env)
    (define-variable! (definition-variable exp)
                      (aeval (definition-value exp) env)
                      env)
    'ok)

  ;; util
  (define (first-exp seq) (car seq))
  (define (rest-exps seq) (cdr seq))
  (define (last-exp? seq) (null? (cdr seq)))

  ;; eval-if
  (define (if-predicate exp) (cadr exp))
  (define (if-consequent exp) (caddr exp))
  (define (if-alternative exp)
    (if (not (null? (cdddr exp)))
        (cadddr exp)
        #f))
  (define (eval-if exp env)
    (if (true? (aeval (if-predicate exp) env))
        (begin
          (display "true pass\n")
          (aeval (if-consequent exp) env))
        (begin
          (display "false pass\n")
          (aeval (if-alternative exp) env))))

  ;; lambda
  (define (lambda-parameters exp) (cadr exp))
  (define (lambda-body exp) (cddr exp))
  (define (eval-lambda exp env)
    (make-procedure (lambda-parameters exp)
                    (lambda-body exp)
                    env))

  ;; begin
  (define (eval-sequence exps env)
    (cond ((last-exp? exps) (aeval (first-exp exps) env))
          (else (aeval (first-exp exps) env)
                (eval-sequence (rest-exps exps) env))))
  (define (begin-actions exp) (cdr exp))
  (define (eval-begin exp env)
    (eval-sequence (begin-actions exp) env))

  ;; 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 (make-begin seq) (cons 'begin seq))
  (define (sequence->exp seq)
    (cond ((null? seq) seq)
          ((last-exp? seq) (first-exp seq))
          (else (make-begin seq))))

  (define (expand-clauses clauses)
    (if (null? clauses)
        'false
        (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))
              (if (eq? (cadr first) '=>)
                  (let ((sym (gensym)))
                    (list 'let (list (list sym (cond-predicate first)))
                          (list 'if
                                sym
                                (list (caddr first) sym)
                                (expand-clauses rest))))
                  (make-if (cond-predicate first)
                           (sequence->exp action)
                           (expand-clauses rest)))))))

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

  (define (eval-cond exp env)
    (aeval (cond->if exp) env))

  ;; and
  (define (eval-and-sequence exps env)
    (if (null? exps)
        'true
        (if (true? (aeval (first-exp exps) env))
            (eval-and-sequence (rest-exps exps) env)
            'false)))
  (define (eval-and exp env)
    (eval-and-sequence (cdr exp) env))

  ;; or
  (define (eval-or-sequence exps env)
    (if (null? exps)
        'false
        (if (true? (aeval (first-exp exps) env))
            'true
            (eval-and-sequence (rest-exps exps) env))))
  (define (eval-or exp env)
    (eval-or-sequence (cdr exp) env))

  ;; let
  (define (let->combination exp)
    (let ((second (cadr exp)))
      (let ((named? (symbol? second)))
        (let ((bindings (if named? (caddr exp) second))
              (body (if named? (cdddr exp) (cddr exp))))
          (let ((vars (map car bindings))
                (exps (map cadr bindings)))
            (if named?
                (list 'let bindings
                      (append (list 'define (append (list second) vars))
                              body)
                      (append (list second) vars))
                (append (list (append (list 'lambda vars) (cddr exp))) exps)))))))

  (define (eval-let exp env)
    (aeval (let->combination exp) env))

  ;; let*
  (define (let*->nested-lets exp)
    (let ((bindings (cadr exp)))
      (let binds->lets ((binds bindings))
        (if (null? (cdr binds))
            (append (list 'let (list (car binds))) (cddr exp))
            (list 'let (list (car binds))
                  (binds->lets (cdr binds)))))))

  (define (eval-let* exp env) (aeval (let*->nested-lets exp) env))

  ;; do
  (define (do->named-let exp)
    (let ((binds (cadr exp))
          (predicate (caaddr exp))
          (value (car (cdaddr exp)))
          (body (cdddr exp)))
      (let ((var-inits (map (lambda (bind) (list (car bind) (cadr bind))) binds))
            (updates (map caddr binds))
            (iter-name (gensym)))
        `(let ,iter-name ,var-inits
              (if ,predicate
                  ,value
                  (begin
                    ,@body
                    (,iter-name ,@updates)))))))

  (define (eval-do exp env)
    (aeval (do->named-let exp) env))

  (put 'eval 'quote text-of-quotation)
  (put 'eval 'set! eval-assignment)
  (put 'eval 'unbind! eval-unbind)
  (put 'eval 'define eval-definition)
  (put 'eval 'if eval-if)
  (put 'eval 'lambda eval-lambda)
  (put 'eval 'begin eval-begin)
  (put 'eval 'and eval-and)
  (put 'eval 'or eval-or)

  ;; jast a macro
  (put 'eval 'cond eval-cond)
  (put 'eval 'let eval-let)
  (put 'eval 'let* eval-let*)
  (put 'eval 'do eval-do)
)
(install-eval-package)

;;;
;;; apply
;;;

(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))
(define (last-exp? seq) (null? (cdr seq)))
(define (eval-sequence exps env)
    (cond ((last-exp? exps) (aeval (first-exp exps) env))
          (else (aeval (first-exp exps) env)
                (eval-sequence (rest-exps exps) env))))

(define (aapply 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))))

;;;
;;; true? false?
;;;


(define (true? x) (not (eq? x 'false)))
(define (false? x) (eq? x 'false))

;;;
;;; make
;;;

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

;;;
;;; repl
;;;

(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 (aeval 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)))



;;;
;;; running !!
;;;

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

(driver-loop)

(define (append x y) (if (null? x) y (cons (car x) (append (cdr x) y))))

(append (quote (a b c)) (quote (d e f)))


;;; 4.14
;; 定義版
(define (map fn lis)
  (if (null? lis)
      '()
      (cons (fn (car lis)) (map fn (cdr lis)))))

(map car (quote ((1 2) (3 4))))
;-> (1 3)

;; プリミティブ版
;; 一度Replを止める。

gosh> (define (map2 fn lis)
        (if (null? lis)
            '()
            (cons (fn (car lis)) (map2 fn (cdr lis)))))

gosh> (define primitive-procedures
        (list (list 'car car)
              (list 'cdr cdr)
              (list 'cons cons)
              (list 'null? (lambda (x) (if (null? x) 'true 'false)))
              (list 'map map2)))

gosh> (define the-global-environment (setup-environment))
gosh> (driver-loop)

;;; M-Eval input:
(map car (quote ((1 2) (3 4))))
*** ERROR: invalid application: ((primitive #<subr car>) (1 2))
Stack Trace:
_______________________________________
  0  fn

  1  (aeval input the-global-environment)
        At line 443 of "(stdin)"


;; mapに渡されてくるのはメタschemeのデータなので、内部でメタschemeのapplyをしてやらねばならない。