Tosh

Tosh

Toshと言います。

• マクロ大好き。
• オブジェクト指向大好き。
• 動的型大好き。
• でも実はMLの型推論にかなーり感動。

そんなわけでマクロで遊んでみた結果が下。

Pattern match

MLのパターンマッチをGaucheで。 プロトタイプなのでパターンの解析を実行時にやってたりします。

• Shiro: をを、かっこいい。パターンマッチに関しては、Andrew Wrightの実装 (SLIBについて来ます)みたいなのをGaucheでも持とうか、という話が 以前gauche-develで出ました。何か欲しいですよね。 Biglooにはパターンをばりばりコンパイルしてくれる抹茶^H^Hmatcherが 付いているみたいですが… (2002/09/17 12:46:43 PDT)

• Tosh: SLIBにパターンマッチがついてくるとは知りませんでした。今までなんと なくインストールしてなかったのですが、今度見てみます。しかし、こんなもの まで処理系のサポートがなくてもマクロがあれば、自分でしかも結構簡単に実装 できてしまうというのは予想以上に強力そうですね。 2002/09/18 09:24:49 PDT

例

  gosh> (define (tail l)
        (match l
               ((_ . xs) => xs)))
  tail
  gosh> (tail '(1 2 3))
  (2 3)
  gosh> (define (head l)
        (match l
               ('() => #f)
               ((x . _) => x)))
  head
  gosh> (head '(1 2 3))
  1
  gosh> (use srfi-9)
  (#<module srfi-9> #<module gauche.interactive>)
  gosh> (define-record-type pare
        (kons x y) pare?
        (x kar set-kar!)
        (y kdr))
  #f
  gosh> (match (kons 1 2)
             ((obj (x 1) (y y)) => y))
  2

コード

  (use srfi-1)
  
  (define-macro (match target . body)
    (let ((tsym (gensym))
        (sym (gensym)))
      `(let ((,tsym ,target)
           (,sym #f))
         (cond
         ,@(map (cut parse-clause <> tsym sym) body)))))
  
  (define (parse-clause clause target sym)
    (cond
     ((and (eq? (second clause) 'when) (eq? (fourth clause) '=>))
      (parse-clause-with-guard (first clause) (third clause) (fifth clause)
                             target sym))
     ((eq? (second clause) '=>)
      (parse-clause-not-guard (first clause) (third clause) target sym))
     (else
      (error "Syntax error!"))))
  
  (define (parse-clause-with-guard pat grd expr target sym)
    (let ((vars (vars-in-pattern pat)))
      `((begin (set! ,sym (try-match ',pat ,target))
             (and ,sym
                  ,(let-vars-in-pattern vars sym grd)))
        ,(let-vars-in-pattern vars sym expr))))
  
  (define (parse-clause-not-guard pat expr target sym)
    (let ((vars (vars-in-pattern pat)))
    `((begin (set! ,sym (try-match ',pat ,target)) ,sym)
      ,(let-vars-in-pattern vars sym expr))))
  
  (define (try-match pat target)
    (cond
     ((eq? pat '_)
      '())
     ((pattern-variable? pat) 
      (list (cons pat target)))
     ((not-pair? pat) ; constant
      (if (equal? pat target) '() #f))
     ((and (eq? (car pat) 'as) (pattern-variable? (second pat))) ; as
      (append-when-list (try-match (third pat) target)
                      (list (cons (second pat) target))))
     ((eq? (car pat) 'or)
      (any (cut try-match <> target) (cdr pat)))
     ((eq? (car pat) 'obj)
      (apply append-when-list
           (map (cut try-match-obj-slot <> target)
                (cdr pat))))
     (else ; list
      (if (pair? target)
        (append-when-list (try-match (car pat) (car target))
                          (try-match (cdr pat) (cdr target)))
        #f))))
  
  (define (try-match-obj-slot pat target)
    (let ((slot (car pat))
        (spat (second pat)))
      (if (slot-exists? target slot)
        (try-match spat (slot-ref target slot))
        #f)))
  
  (define (append-when-list . lists)
    (if (every list? lists)
        (apply append lists)
        #f))
  
  (define (let-vars-in-pattern vars bounds expr)
    (if (null? vars)
        expr
        `(let ((,(car vars) (value-for-var ,bounds ',(car vars))))
         ,(let-vars-in-pattern (cdr vars) bounds expr))))
  
  (define (vars-in-pattern pat)
    (cond 
     ((pair? pat)
      (append (vars-in-pattern (car pat))
            (vars-in-pattern (cdr pat))))
     ((pattern-variable? pat) (cons pat '()))
     (else '())))
  
  (define (pattern-variable? sym)
    (and (symbol? sym) (not (eq? sym '_))))
  
  (define (value-for-var bounds var)
    (let ((m (assq var bounds)))
      (if m
        (cdr m))))
 numero rio