Gauche:devtree

Gauche:devtree

NetBSD用

dmesgから認識しているデバイスの木構造を表示する。 あまりちゃんと内容確認してないんで例によってバグは愛嬌。
vm-evalをよりそれらしく変更。cut-sea:2006/03/27 04:08:39 PST

そうか。vm-evalがデフォルトで色々やりすぎるのは自由度を奪うのだ。 本来レジスタを用意したらプログラム側でいじれるべきで、 それはここでは、いじろうといじるまいとvaluesで全部返させることと同義だね。 それを色々いじると出力をもっと変えることも出来るハズ。 逆に自由度を犠牲にして全部裏方でやってやれば汎用性はなくなるが、 簡単なプログラムで機能を実現できると。実に当たり前ですが。
どっちに振るかだけど、今のコードからcont(続きのcode)も解放すれば、 自分で制御できるようになるワケだ。
逆に前バージョンでは意味もなくstackレジスタだけ解放してたけど、 これだけだと意味はない。そこまでやるならスタックも裏で処理させるのがいい。 それなりにレジスタを解放するか、ほとんど全く解放しないかですな。cut-sea:2006/03/28 07:44:27 PST

devtree.scm 

#! /usr/bin/env gosh
(use srfi-1)
(use gauche.process)

(define-syntax where
  (syntax-rules ()
    ((_ (proc v1 ...) e1 ...)
     (letrec ((v1 e1) ...) (proc v1 ...)))))

(define (analysis-dmesg)
  ;; utility
  (define (racons asc a d)
    (append asc (list (cons a d))))
  (define (rcons lst item)
    (append lst (list item)))
  ;; special utility
  (define (branch stack rest)
    (define (end? p)
      (if (assoc p rest) #f #t))
    (cons #t
          (fold (lambda (p s)
                  (cons (end? p) s)) '() stack)))
  (define (indent n dev br)
    (if (= n 0)
        (format #t (if (car br) "`-- ~a~%" "|-- ~a~%") dev)
        (begin
          (format #t (if (car br) "    " "|   "))
          (indent (- n 1) dev (cdr br)))))
  ;; hierarchic sort
  (define (hierarchic-sort pairs)
    (define (sort pairs)
      (define (insert item sorted)
        (receive (prev rest)
            (span (lambda (p)
                    (not (equal? (cdr p) (car item))))
                  sorted)
          (receive (same post)
              (span (lambda (p)
                      (equal? (cdr p) (car item)))
                    rest)
            (append prev same (list item) post))))
      (fold (lambda (elm sorted) (insert elm sorted)) '() pairs))
    (sort (sort pairs)))
  ;; virtual machine
  (define (vm-eval proc parent child flag stack code)
    (or (null? code)
        (let1 cont (cdr code)
          (receive (pa ch flg st)
              (where (proc p c flg s b eb)
                     (caar code) (cdar code)
                     (member p stack) (or flg '())
                     (branch s cont) (branch (cons p s) cont))
            (vm-eval proc pa ch flg st cont)))))
  ;; dmesg string lines to parent&child assoc list
  (define (dmesg->pairs)
    (define (depend-pair ln seed)
      (cond ((#/^(\w+):?[ \t]+at[ \t](\w+):?/ ln)
             => (lambda (m) (racons seed (m 2) (m 1))))
            (else seed)))
    (fold depend-pair '() (process-output->string-list "/sbin/dmesg")))
  ;; main eval loop
  ;; you can use parent/child/flag/stack register in lambda program.
  ;; but branch/extrabranch register is read only.
  (vm-eval (lambda (p c flg st br eb)
             (if flg
                 (begin
                   (indent (length st) c br)
                   (values p c flg (cons c st)))
                 (begin
                   (indent 0 p br) (indent 1 c eb)
                   (values p c flg (list c p)))))
           #f #f #f '() (hierarchic-sort (dmesg->pairs))))

(define (main . args)
  (analysis-dmesg))

実行結果

Last modified : 2012/02/23 03:40:20 UTC