SICP問題3.7

3.3で定義したパスワードつきのmake-accountの定義。passwordが同じ時だけmake-jointで共同口座を作れるようにパスワードが正しいかチェックする振る舞いを追加。

(define (make-account balance password)
  (define (withdraw amount)
    (if (>= balance amount)
        (begin (set! balance (- balance amount))
               balance)
        "Insufficient funds"))
  (define (deposit amount)
    (set! balance (+ balance amount))
    balance)
  (define (correct-password? input-password)
    (eq? input-password password))
  (define (dispatch p m)
    (if (correct-password? p)
        (cond ((eq? m 'withdraw) withdraw)
              ((eq? m 'deposit) deposit)
              ((eq? m 'can-joint?) #t)
              (else (error "Unknown request -- MAKE-ACCOUNT"
                           p m)))
        ; 修正
        (if (eq? m 'can-joint?)
            #f
            (error "Incorrect password" p m))))
  dispatch)

make-jointの定義

(define (make-joint source-account source-password dist-password)
  (define (correct-password? input-password)
    (eq? input-password dist-password))
  (define (dispatch p m)
    (if (correct-password? p)
        (cond ((eq? m 'withdraw) (source-account source-password 'withdraw))
              ((eq? m 'deposit) (source-account source-password 'desposit))
              (else (error "Unknown request -- MAKE-ACCOUNT"
                           p m)))
        (error "Incorrect password" p)))
  (if (source-account source-password 'can-joint?)
      dispatch
      (error "Incorrect Source Password" source-password)))

テスト

(define peter-acc (make-account 100 'open-sesami))
; peter-acc
(define paul-acc (make-joint peter-acc 'open-sesami 'rosebud))
; paul-acc
((peter-acc 'open-sesami 'withdraw) 10)
; 90
((paul-acc 'rosebud 'withdraw) 10)
; 80
((paul-acc 'rosebudd 'withdraw) 10)
; *** ERROR: Incorrect password rosebudd
; Stack Trace:
; _______________________________________
;   0  (paul-acc 'rosebudd 'withdraw)
;         At line 22 of "(stdin)"
(define paul-acc-2 (make-joint peter-acc 'open-sesami2 'rosebud))
; *** ERROR: Incorrect Source Password open-sesami2
; Stack Trace:
; _______________________________________
;   0  (make-joint peter-acc 'open-sesami2 'rosebud)
;         At line 28 of "(stdin)"