レガシーコード生産ガイド

私に教えられることなら

オリジナル記法・PicoLisp風命名規則・簡単なオブジェクトシステムをScheme(Gauche)で

らくがきです。

なんとなくコードを書き散らしたくなったので、オリジナル記法とPicoLisp風命名規則を使い、オブジェクトシステムをScheme(Gauche)で書いてみた。

ネストが苦手

(昔この日記に書いた事を再度書く)

集中力が無いのか、脳のワーキングメモリが少ないのか、理由はわからないけどとにかくネストした式が苦手だ。letを多用して中間の値にどんどん名前をつけていかないと頭がおかしくなりそうになる。インデントも苦手で、どんどん右斜め下に流れていくコードを見ていると気が狂いそうになる。

さらに複雑な条件を把握するのも苦手なので、簡単な「除外する」条件で処理を減らしていく早期リターンも多用する。

letと早期リターンが絡むと、例えば次のようなコードの見た目になってやる気がゼロになる。

(defn foo [Bar]
  (let* ([X (baz Bar)]
         [Y (baz X)])
    (if (not (hoge? X))
        Y
        (let* ([Z (if (fuga? (baz Y)) Y (hoge Y))])
          (begin
            (if (null? Z) (print Z))
            (if (fuga? Z)
                Z
                (fuga Z)))))))

で、以前自作したブラウザ上のLisp環境「DenLisp」では、次のように書けるようにした。

(defn foo [Bar]
  let X (baz Bar)
  let Y (baz X)
  if not (hoge? X) Y
  let Y if not (fuga? (baz Y)) (hoge Y)
  do if (null? Y) (print Y)
  if (fuga? Y) Y
  (fuga Y))

S式大好きなのでS式から外れたりはしていない。専用の構文解析を行ってるわけではなく、単に関数の本体を1つのリストとして、前から順番にマクロで展開している。

ただ、この書き方が自分にとって本当に良いのかは疑問に思い始めている。コードを読み返す時にちょっと辛い。行あたりの情報密度が高すぎて疲れるのかもしれない。次のようにインデントするとちょっと楽に読めるからだ。

(defn foo [Bar]
  let X
    (baz Bar)
  let Y
    (baz X)
  if not (hoge? X)
    Y
  let Y if not (fuga? (baz Y))
    (hoge Y)
  do if (null? Y)
    (print Y)
  if (fuga? Y)
    Y
  (fuga Y))

この記事の最後のコード全体に、Gaucheで使えるマクロ定義も書いてある。

PicoLisp

いろいろあって、やっぱりWorse Is Betterかもなあと強く思うようになったので、それを感じるPicoLispを最近眺めている。(PicoLispがWorseと言ってることになるけど、Betterとも言ってるので許してください)

リストとシンボル(interned/transition)と数値しかない・関数もリスト・動的束縛・fexpr系とかなりオモシレッオモシレッな処理系なんだけど、やっぱりLexicalな束縛とmacroexpand可能なマクロの方が楽だし好きなので、Scheme(Gauche)で命名規則とオブジェクトシステムを真似して書いてみることにした。

真似したとこ

  • defineはde、define-methodはdmなどの短縮
  • メソッド内のSelf(他言語のthis)は勝手に束縛する
  • 関数名は普通にfoo、ローカル変数はFooBarグローバル変数*FooBar、クラス名は+Fooという命名規則。特にローカル変数は、慣れると余計に名前を考えなくて良くなって良い
  • (class +Foo)以降でdmするとそのクラスへのメソッド追加になる。インデントが1つ減って良い

真似しなかったとこ

  • オブジェクトに複数のクラスを指定できるのはあんまり好きじゃないのでなし
  • メタオブジェクトもなし

次のコードが動く。

(class +Pokemonsta/Type)

(dm init [Name]
  (set> Name))

(dm name []
  (get> Name))

(de *TypeNormal (new +Pokemonsta/Type "ノーマル"))
(de *TypeDenki (new +Pokemonsta/Type "でんき"))



(class +Pokemonsta)

(dm init [Name Type]
  (set> Name)
  (set> Type))

(dm name []
  (get> Name))

(dm type []
  (get> Type))

(dm info []
  `((Name ,(name Self))
    (Type ,(name (type Self)))))


(de (normal-pokemonsta Name)
  (new +Pokemonsta Name *TypeNormal))

(de (denki-pokemonsta Name)
  (new +Pokemonsta Name *TypeDenki))


(yaa
 let PaikaChu (denki-pokemonsta "パイカテフ")
 (print (info PaikaChu))
 (print (inspect PaikaChu)))

実行結果

$ gosh pico.scm
((Name パイカテフ) (Type でんき))
((Class +Pokemonsta) (Ancestors (+Object +Nil)) (InstVars (Type Name)))

実行を意味するdobeginシンタックスとして使われているので、九州(たぶん福岡佐賀長崎)の小学生で実行を意味する「ヤー!」を使った。

コード全体

(use srfi-1)

'(; emacs用
  (put 'de 'scheme-indent-hook 'defun)
  (put 'dm 'scheme-indent-hook 'defun)
  (put 'when 'scheme-indent-hook 1)
  (put 'unless 'scheme-indent-hook 1)
  (put 'loop 'scheme-indent-hook 'defun)
  )

(define-syntax yaa
  (syntax-rules (if not let do)
    ;; if
    [(_ if not Test Then Else ...)
     (if (not Test) Then (yaa Else ...))]
    [(_ if Test Then Else ...)
     (if Test Then (yaa Else ...))]
    ;; let
    [(_ let Var if not Test Expr Then ...)
     (let ([Var (if (not Test) Expr Var)]) (yaa Then ...))]
    [(_ let Var if Test Expr Then ...)
     (let ([Var (if Test Expr Var)]) (yaa Then ...))]
    [(_ let Var Val Then ...)
     (let ([Var Val]) (yaa Then ...))]
    ;; do
    [(_ do if Test Expr Then ...)
     (begin (if Test Expr) (yaa Then ...))]
    [(_ do Expr Then ...)
     (begin Expr (yaa Then ...))]
    ;; then...
    [(_ Then ...)
     (begin Then ...)]))

(define-syntax fn
  (syntax-rules ()
    [(_ Args Body ...)
     (lambda Args (yaa Body ...))]))

;; de: define
(define-syntax de
  (syntax-rules ()
    [(_ Var Val)
     (define Var Val)]
    [(_ (Var . Args) Body ...)
     (define Var (fn Args Body ...))]))

;; (let loop ...) だとyaaを挟むことになるので
(define-macro (loop Inits . Body)
  `(let recur ,Inits (yaa ,@Body)))

(de *ClassTable (make-hash-table))
(de *GenericTable (make-hash-table))

(de (make-cls-body Name Parent)
  let MethodTable (make-hash-table)
  (list MethodTable Name Parent))

(de (method-table Cls) (first Cls))
(de (cls-name Cls) (second Cls))
(de (cls-parent Cls) (third Cls))

(de (register-cls Name Cls)
  (hash-table-put! *ClassTable Name Cls))

(de (make-cls Name Parent)
  let Cls (make-cls-body Name Parent)
  (register-cls Name Cls)
  Cls)

(de +Nil (make-cls '+Nil ()))
(de +Object (make-cls '+Object +Nil))
(de *Class +Object)

(de (set-current-cls! Name)
  if not (hash-table-exists? *ClassTable Name) #f
  (set! *Class (hash-table-get *ClassTable Name))
  #t)

(de (new Cls . Args)
  let InstVars (make-hash-table)
  let Obj (list Cls InstVars)
  do if (pair? Args) (apply init Obj Args)
  Obj)

(de (obj-class Obj) (first Obj))
(de (obj-inst-vars Obj) (second Obj))

(de (lookup-method Obj Mes)
  (loop ([Cls (obj-class Obj)])
    if (null? Cls) (error (format #f "ない: ~A" Mes))
    let MT (method-table Cls)
    if (hash-table-exists? MT Mes) (hash-table-get MT Mes)
    (recur (cls-parent Cls))))

(de (invoke-method Obj Mes Args)
  let f (lookup-method Obj Mes)
  (apply f Obj Args))

(de (add-method Mes Meth)
  let Cls *Class
  let MT (method-table Cls)
  (hash-table-put! MT Mes Meth))

;; dm: define-method
(define-macro (dm Mes Args . Body)
  `(begin
     (when (not (hash-table-exists? *GenericTable ',Mes))
       (de (,Mes Obj . MethArgs)
         (invoke-method Obj ',Mes MethArgs))
       (hash-table-put! *GenericTable ,Mes #t))
     (let* ([Meth (lambda (Self ,@Args) ,@Body)])
       (add-method ',Mes Meth))))

(define-syntax class
  (syntax-rules ()
    [(_ Name) (class Name +Object)]
    [(_ Name Parent)
     (unless (set-current-cls! 'Name)
       (de Name (make-cls 'Name Parent))
       (set-current-cls! 'Name))]))


(de Nil (new +Nil))

(class +Object)

(dm init [])

(dm get-inst-var [Name]
  (hash-table-get (obj-inst-vars Self) Name))

(dm set-inst-var [Name Val]
  (hash-table-put! (obj-inst-vars Self) Name Val))

(define-macro (get> Name)
  `(get-inst-var Self ',Name))

(define-macro (set> Name :optional Val)
  `(set-inst-var Self ',Name ,(if (undefined? Val) Name Val)))

(dm ancestors []
  (loop ([Cls (cls-parent (obj-class Self))]
         [Acc ()])
    if (null? Cls) (reverse Acc)
    (recur (cls-parent Cls) (cons Cls Acc))))

(dm inspect []
  `((Class ,(cls-name (obj-class Self)))
    (Ancestors ,(map cls-name (ancestors Self)))
    (InstVars ,(hash-table-keys (obj-inst-vars Self)))))

;; Example
;; =============================================================================

(class +Pokemonsta/Type)

(dm init [Name]
  (set> Name))

(dm name []
  (get> Name))

(de *TypeNormal (new +Pokemonsta/Type "ノーマル"))
(de *TypeDenki (new +Pokemonsta/Type "でんき"))



(class +Pokemonsta)

(dm init [Name Type]
  (set> Name)
  (set> Type))

(dm name []
  (get> Name))

(dm type []
  (get> Type))

(dm info []
  `((Name ,(name Self))
    (Type ,(name (type Self)))))


(de (normal-pokemonsta Name)
  (new +Pokemonsta Name *TypeNormal))

(de (denki-pokemonsta Name)
  (new +Pokemonsta Name *TypeDenki))


(yaa
 let PaikaChu (denki-pokemonsta "パイカテフ")
 (print (info PaikaChu))
 (print (inspect PaikaChu)))
広告を非表示にする