emacs-muleで保存されたファイルの文字コードを変更するelisp

時々emacs-muleでファイルが保存されていることがあって、そのたびに手作業で修正するのが面倒だったので作ってみました。
とりあえず、いつもの修正方法は以下のような感じです

• revert-buffer-with-coding-systemでemacs-muleを選択
• bufferの内容をcopy
• てきとーな名前のファイルを開く
• そこにyank
• 修正したいファイルとbufferを削除
• 新しいファイルを作成して、そこにyank

code

(defun revert-broken-file (&optional tmp-name) (interactive)
  (let ((tmp-name (if tmp-name tmp-name "a.tmp")))
    (let* ((file (buffer-file-name))
	   (tmp (concat (file-name-directory file) tmp-name))
	   (kill (lambda (str) 
		 (when (file-exists-p str)
		     (delete-file str))
		 (let ((fname (file-name-nondirectory str)))
		   (when (member fname (mapcar #'buffer-name (buffer-list)))
		     (kill-buffer fname))))))
      (save-excursion
	(revert-buffer-with-coding-system 'emacs-mule)
	(dolist (e (list tmp file)) 
	  (copy-region-as-kill (point-min) (point-max))
	  (funcall kill e)
	  (find-file e)
	  (yank))
	(save-buffer)))))

こういう時は、文字コードの設定も書いておくべきかもしれない。

文字コードの設定

;;enable utf-8
(set-language-environment "Japanese")
(setq default-terminal-coding-system 'utf-8)
(setq default-keyboard-coding-system 'utf-8)
(setq buffer-file-coding-system 'utf-8)
(setq default-buffer-file-coding-system 'utf-8)
(prefer-coding-system 'utf-8)
(setq default-coding-systems 'utf-8)
(custom-set-variables
  ;; custom-set-variables was added by Custom.
  ;; If you edit it by hand, you could mess it up, so be careful.
  ;; Your init file should contain only one such instance.
  ;; If there is more than one, they won't work right.
 '(default-input-method "japanese-anthy-uim"))
(custom-set-faces )

;;一部の文字の文字化け解消
  (utf-translate-cjk-set-unicode-range
   '((#x00a2 . #x00a3) ; ¢, £
     (#x00a7 . #x00a8) ; §, ¨
     (#x00ac . #x00ac) ; ¬
     (#x00b0 . #x00b1) ; °, ±
     (#x00b4 . #x00b4) ; ´
     (#x00b6 . #x00b6) ; ¶
     (#x00d7 . #x00d7) ; ×
     (#X00f7 . #x00f7) ; ÷
     (#x0370 . #x03ff) ; Greek and Coptic
     (#x0400 . #x04FF) ; Cyrillic
     (#x2000 . #x206F) ; General Punctuation
     (#x2100 . #x214F) ; Letterlike Symbols
     (#x2190 . #x21FF) ; Arrows
     (#x2200 . #x22FF) ; Mathematical Operators
     (#x2300 . #x23FF) ; Miscellaneous Technical
     (#x2500 . #x257F) ; Box Drawing
     (#x25A0 . #x25FF) ; Geometric Shapes
     (#x2600 . #x26FF) ; Miscellaneous Symbols
     (#x2e80 . #xd7a3) (#xff00 . #xffef)))
(provide 'myencoding-config)

[sicp](sicp47)m4.1~m4.2

明日から問題を解こう。

;;eval/applyは元の関数を覆い隠さない様に@をつけよう
(define (@eval exp env)
  (cond ((self-evaluating? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        ((quoted? exp) (text-of-quotation exp))
        ((assignment? exp) (eval-assignment exp env))
        ((definition? exp) (eval-definition exp env))
        ((if? exp) (eval-if exp env))
        ((lambda? exp)
         (make-procedure (lambda-parameters exp)
                         (lambda-body exp)
                         env))
        ((begin? exp) 
         (eval-sequence (begin-actions exp) env))
        ((cond? exp) (@eval (cond->if exp) env))
        ((application? exp)
         (@apply (@eval (operator exp) env)
                (list-of-values (operands exp) env)))
        (else
         (error "Unknown expression type -- EVAL" exp))))

(define (@apply procedure arguments)
  (cond ((primitive-procedure? procedure)
         (apply-primitive-procedure procedure arguments))
        ((compound-procedure? procedure)
         (eval-sequence
           (procedure-body procedure)
           (extend-environment
             (procedure-parameters procedure)
             arguments
             (procedure-environment procedure))))
        (else
         (error
          "Unknown procedure type -- APPLY" procedure))))

(define (list-of-values exps env)
  (if (no-operands? exps)
      '()
      (cons (@eval (first-operand exps) env)
            (list-of-values (rest-operands exps) env))))

;;4.1
;;letを使って先に計算すればいい。
(define (list-of-values-from-right exps env)
  (if (no-operands? exps)
      '()
      (let1 rest (list-of-values-from-right (rest-operands exps) env)
        (cons (@eval (first-operand exps) env) rest))))

(define (list-of-values-from-left exps env)
  (if (no-operands? exps)
      '()
      (let1 first (@eval (first-operand exps) env)
        (cons (first (list-of-values-from-left (rest-operands exps) env))))))


(define (true? condition)
  (eq? condition 'true))

;;(@eval (anything ... ) exp env)ってmacroにできるような気がする。

(define (eval-sequence exps env)
  (cond ((last-exp? exps) (@eval (first-exp exps) env))
        (else (@eval (first-exp exps) env)
              (eval-sequence (rest-exps exps) env))))

(define (eval-if exp env)
  (if (true? (@eval (if-predicate exp) env))
      (@eval (if-consequent exp) env)
      (@eval (if-alternative exp) env)))

(define (eval-assignment exp env)
  (set-variable-value! (assignment-variable exp)
                       (@eval (assignment-value exp) env)
                       env)
  'ok)

(define (eval-definition exp env)
  (define-variable! (definition-variable exp)
                    (@eval (definition-value exp) env)
                    env)
  'ok)

(define (self-evaluating? exp)
  (cond ((number? exp) true)
        ((string? exp) true)
        (else false)))

(define (variable? exp) (symbol? exp))

(define (quoted? exp)
  (tagged-list? exp 'quote))

(define (tagged-list? exp tag)
  (if (pair? exp)
      (eq? (car exp) tag)
      false))

;;--assignment--
(define (assignment exp)
  (tagged-list? exp 'set!))

(define (assignment-variable exp)  (cadr exp))
(define (assignment-value exp) (caddr exp))

;;--definition--
(define (definition? exp) (tagged-list? exp 'define))
	;; (define (definition? exp)  (tagged-list? exp 'define))
	;;   (define (<var> <parameter1> ... <parametern>)
	;;   <body>)
	;; (define <var>
	;;   (lambda (<parameter1> ... <parametern>)
	;;     <body>))
(define (definition-variable exp)
  (if (symbol? (cadr exp))
      (cadr exp)
      (caddr exp)))

(define (definition-value exp)
  (if (symbol? (cadr exp))
      (caddr exp)
      (make-lambda (caddr exp) 
                   (cddr exp))))
;;--lambda--
(define (lambda? exp) (tagged-list? exp 'lambda))
;;(lambda (par1 par2 ..) body)
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))

(define (make-lambda paramators body)
  (cons 'lambda (cons paramators body)))


;;--if--
(define (if? exp) (tagged-list? exp 'if))
;;(if predicate consequent alternative)
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
  (if (not (null? (cdddr exp)))
      (cadddr exp)
      'false))

(define (make-if predicate consequent alternative)
  (list 'if predicate consequent alternative))

;;--begin--
(define (begin? exp) (tagged-list? exp 'begin))
(define (begin-actioin seq) (cdr seq))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exp seq) (cdr seq))

(define (sequence->exp seq)
  (cond ((null? seq) seq)
        ((last-exp? seq) (first-exp seq))
        (else (make-begin seq))))
(define (make-begin seq) (cons 'begin seq))

;;--application--
(define (application? exp) (pair? exp))
(define (operator exp) (car exp))
(define (operand exp) (cdr exp))
(define (no-operands? ops) (null? ops))
(define (first-operand ops) (car ops))
(define (rest-operands ops) (cdr ops))

;;--cond (cond->if)--
(define (cond? exp) (tagged-list? exp 'cond))
;;cond = (cond clauses)
;;clauses = (list clause1 clause2 ...)
(define (cond-clauses exp) (cdr exp))
;;clause = (predicate action)
(define (cond-else-clause? clause)
  (eq? (cond-predicate clause) 'else))
(define (cond-predicate clause) (car clause))
(define (cond-actions clause) (cdr clause))
(define (cond->if exp)
  (expand-clauses (cond-clauses exp)))

;; (cond (p1 action1)
;;       (p2 action2-1 action2-2)
;;       (else last-action))

;; (if p1
;;     action1
;;     (if p2
;;         (begin action2-1 action2-2)
;;         last-action)))
;;(when p ac) = (if p ac false)

(define (expand-clauses clauses)
  (if (null? clause)
      'false
      (let ((first (car clauses))
            (rest (cdr clauses)))
        (if (cond-else-clause? first)
            (if (null? rest)
                (sequence->exp (cond-actions first))
                (error "ELSE clause isn't last -- COND->IF"
                       clauses))
            (make-if (cond-predicate first)
                     (sequence->exp (cond-actions first))
                     (expand-clauses rest))))))


;; 4.2
;;a.
application? procedure's function is just checking whether pair?. so, some of the case it return true.
when with the expression (define x 3), it trys to apply "define" procedure.

;;b.
(define (application? exp) (tagged-list? exp 'call))
(define (operator exp) (cadr exp))
(define (operand exp) (caddr exp))