Scheme - Land of Scheme - LISP は対称なり - より進んだデータ型とジェネリックプログラミング(データをジェネリックに扱う、型述語を使って自分でジェネリック関数を作る, defmethod)

Land of Lisp
(オライリージャパン)
M.D. Conrad Barski (著) 川合 史朗 (翻訳)
原書: Land of LISP
Learn to Program in Lisp, One Game at a Time!

開発環境

• OS X El Capitan - Apple (OS)
• Emacs(Text Editor)
• Scheme (プログラミング言語)
• kscheme (github), Gauche, MIT/GNU Scheme, GNU Guile (処理系)

Land of Lisp (M.D. Conrad Barski (著)、川合 史朗 (翻訳)、オライリージャパン)の第2部(LISP は対称なり)、9章(より進んだデータ型とジェネリックプログラミング)、9.4(データをジェネリックに扱う、型述語を使って自分でジェネリック関数を作る)を Scheme で取り組んでみる。

9.4(データをジェネリックに扱う、型述語を使って自分でジェネリック関数を作る)

コード(Emacs)

(begin
  (define print (lambda (obj) (write obj) (newline)))
  (define (assoc obj alist . compare)
    (define (iter alist cmp)
      (cond ((null? alist) #f)
            ((not (pair? (car alist)))
             (display "Wrong type argument -- "))
            ((cmp obj (caar alist))
             (car alist))
            (else (iter (cdr alist) cmp))))
    (if (list? alist)
        (cond ((null? compare)
               (iter alist equal?))
              ((null? (cdr compare))
               (iter alist (car compare)))
              (else (display "Wrong number of arguments to ")
                    (display assoc)
                    (newline)))
        (begin (display "Wrong type argument -- ")
               (display alist))))

  (define (add a b)
    (cond ((and (number? a) (number? b))
           (+ a b))
          ((and (list? a) (list? a))
           (append a b))
          (else '())))

  (print (add 3 4))
  (print (add '(a b) '(c d)))

  ;; 全ての型への対応コードが一つの大きな関数に固まっている
  ;; 新しい型のサポートを追加するのが大変
  ;; 理解しにくい
  ;; 性能
  ;; Scheme には Common Lisp の defmethod はない。
  ;; 上記の問題を解決する一つの方法
  (define (attach-tag  type-tag contents) (cons type-tag contents))
  (define (type-tag datum)
    (if (pair? datum)
        (car datum)
        (begin (write "Bad tagged datum -- TYPE-TAG ")
               (print datum))))
  (define (contents datum)
    (if (pair? datum)
        (cdr datum)
        (begin (write "Bad tagged datum -- CONTENTS ")
               (print datum))))
  (define (print-datum x) (print (contents x)))
  
  (define (make-table)
    (let ((local-table (list '*table*)))
      (define (lookup key1 key2)
        (let ((subtable (assoc key1 (cdr local-table))))
          (if subtable
              (let ((record (assoc key2 (cdr subtable))))
                (if record
                    (cdr record)
                    #f))
              #f)))
      (define (insert! key1 key2 value)
        (let ((subtable (assoc key1 (cdr local-table))))
          (if subtable
              (let ((record (assoc key2 (cdr subtable))))
                (if record
                    (set-cdr! record value)
                    (set-cdr! subtable
                              (cons (cons key2 value)
                                    (cdr subtable)))))
              (set-cdr! local-table
                        (cons (list key1
                                    (cons key2 value))
                              (cdr local-table))))))
      (define (dispatch m)
        (cond ((eq? m 'lookup-proc) lookup)
              ((eq? m 'insert-proc!) insert!)
              (else (begin (write "Unknown operation -- TABLE ")
                           (print m)))))
      dispatch))

  (define (apply-generic op . args)
    (apply (get op (map type-tag args))
           (map contents args)))
  
  (define (add x y) (apply-generic 'add x y))
  
  (define operation-table (make-table))
  (define put (operation-table 'insert-proc!))
  (define get (operation-table 'lookup-proc))  

  (define (install-number-package)
    (define (add x y) (+ x y))
    
    (define (tag x) (attach-tag 'number x))
    (put 'add '(number number)
         (lambda (x y) (tag (add x y))))
    (put 'make 'number
         (lambda (x) (tag x)))
    'installed-number-package)
  
  (define (make-number n) ((get 'make 'number) n))
  
  (define (install-list-package)
    (define (add x y) (append x y))
    
    (define (tag x) (attach-tag 'list x))
    (put 'add '(list list)
         (lambda (x y) (tag (add x y))))
    (put 'make 'list
         (lambda (x) (tag x)))
    'installed-list-package)

  (define (make-list x) ((get 'make 'list) x))

  (install-number-package)
  (install-list-package)
  (print (add (make-number 3) (make-number 4)))
  (print (add (make-list '(a b)) (make-list '(c d))))
  (print-datum (add (make-number 3) (make-number 4)))
  (print-datum (add (make-list '(a b)) (make-list '(c d))))  
  )

入出力結果(Terminal(kscheme), REPL(Read, Eval, Print, Loop))

$ ./kscheme sample4_4.scm
7
(a b c d)
kscheme(6333,0x7fff74c95000) malloc: *** error for object 0x7f8e7b708990: pointer being freed was not allocated
*** set a breakpoint in malloc_error_break to debug
Abort trap: 6
$ gosh sample4_4.scm
7
(a b c d)
(number . 7)
(list a b c d)
7
(a b c d)
$ guile --no-auto-compile sample4_4.scm
7
(a b c d)
(number . 7)
(list a b c d)
7
(a b c d)
$ # kscheme のメモリ管理に問題があるみたい。