2010/06/30

fib, tail-call-fib, lazy-fib

一般的な fib, 末尾再帰 fib, 遅延評価 fib ということで。(なんか途中に nlet が紛れ込んでますが)
遅延評価については、Gauche には util.stream というのがあるようです。馴染みがないです。
;; fib
(define (fib n)
(cond ((zero? n) 0)
((= 1 n) 1)
(else (+ (fib (- n 1))
(fib (- n 2))))))
(fib 10)
;; 55
(use srfi-1)
(map fib (iota 10))
;; (0 1 1 2 3 5 8 13 21 34 55 89 144 233 377)
;; tail call fib
(define (fib n)
(let loop ((cur 0)(next 1)(n n))
(if (zero? n)
cur
(loop next (+ cur next)(- n 1)))))
(fib 10)
;; 55
(map fib (iota 15))
;; (0 1 1 2 3 5 8 13 21 34 55 89 144 233 377)
(define-syntax nlet
(syntax-rules ()
((_ tag ((var val) ...) body ...)
(letrec ((tag (lambda (var ...)
body ...)))
(tag val ...)))))
(define (fib n)
(macroexpand '(nlet loop ((cur 0)(next 1)(n n))
(if (zero? n)
cur
(loop next (+ cur next)(- n 1))))))
(fib 10)
;; (#<identifier user#letrec>
;; ((loop
;; (#<identifier user#lambda> (cur next n)
;; (if (zero? n)
;; cur
;; (loop next (+ cur next) (- n 1))))))
;; (loop 0 1 n))
;; lazy fib
;; ストリーム - karetta.jp http://karetta.jp/book-node/gauche-hacks/014529
;; Gauche ユーザリファレンス: 11.53 util.stream - ストリームライブラリ http://practical-scheme.net/gauche/man/gauche-refj_170.html
(use util.stream)
(define fib (stream-cons 0 (stream-cons 1 (stream-map + fib (stream-cdr fib)))))
(stream->list (stream-take fib 10))
;; (0 1 1 2 3 5 8 13 21 34)
(stream-ref fib 10000)
;; 336447648764317832666216120...
(stream->list (stream-take-while (pa$ > 1000) fib))
;; (0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987)
(define (fib)
(letrec ((recur (lambda (a b)
(let ((n (+ a b)))
(stream-delay
(stream-cons n (recur b n)))))))
(stream-cons 0 (stream-cons 1 (recur 0 1)))))
(stream->list (stream-take (fib) 10))
;; (0 1 1 2 3 5 8 13 21 34)
(stream-ref (fib) 10)
;; 55
(stream-ref (fib) 1000)
;; 43466557686937456435688527675040625802564660517371780402481729089536555417949051890403879840079255169295922593080322634775209689623239873322471161642996440906533187938298969649928516003704476137795166849228875
(stream->list (stream-take (stream-filter odd? (fib)) 15))
;; (1 1 3 5 13 21 55 89 233 377 987 1597 4181 6765 17711)
view raw fib.scm hosted with ❤ by GitHub


プログラミングClojureプログラミングGauche

2010/06/29

syntax-rules: ext-let

CL とか Clojure の destructuring-bind があればそれで済みそうですが、Gauche にはどうやらなさげ?

syntax-rules だとこんな感じでしょうか。。
;; http://d.hatena.ne.jp/Shinnya/20100628/1277733558
(define-syntax ext-let
(syntax-rules ()
((_ (var ...)(val ...) body ...)
(let ((var val) ...)
body ...))))
(ext-let (a b)(1 2)
(print a)
(print b))
(ext-let (a b)()
(print a)
(print b))
(ext-let ()()
(print 'a))
(ext-let (a b)(1)
(print a)
(print b))
(ext-let (a b)(1 2 3)
(print a)
(print b))
(ext-let (a b c d e f g)
(1 2 3 4 5 6 7)
(print a b c d e f g))
view raw ext-let.scm hosted with ❤ by GitHub

これだと、(ext-let (a b)(1)(print a)) などでも動きます。(var ...) と (val ...) が同じ長さでない場合エラーにしたいって時はどうしたら良いのでしょうか。

追記

なんとなく希望に近い動きしてるように見えますが・・・。うーん・・・頭痛くなりますね。補助マクロとして切り出せば少しはマシに見えるのかもしれませんね。
(define-syntax ext-let
(syntax-rules ()
((_ "sub" ((var1 val1) ...)(var2 var3 ...)(val2 val3 ...) body ...)
(ext-let "sub" ((var1 val1) ... (var2 val2))(var3 ...)(val3 ...) body ...))
((_ "sub" ((var val) ...)()() body ...)
(let ((var val) ...)
body ...))
((_ ()() body ...)
(ext-let "sub" ()()() body ...))
((_ (var1 var2 ...)(val1 val2 ...) body ...)
(ext-let "sub" ((var1 val1))(var2 ...)(val2 ...) body ...))))
view raw ext-let2.scm hosted with ❤ by GitHub


追記2

こんな感じ?ヘルパー。
(define-syntax ext-let
(syntax-rules ()
((_ ()() body ...)
(ext-let-helper ()()() body ...))
((_ (var1 var2 ...)(val1 val2 ...) body ...)
(ext-let-helper ((var1 val1))(var2 ...)(val2 ...) body ...))))
(define-syntax ext-let-helper
(syntax-rules ()
((_ ((var1 val1) ...)(var2 var3 ...)(val2 val3 ...) body ...)
(ext-let-helper ((var2 val2)(var1 val1) ... )(var3 ...)(val3 ...) body ...))
((ext-let-helper ((var val) ...)()() body ...)
(let ((var val) ...)
body ...))))
view raw ext-let3.scm hosted with ❤ by GitHub


プログラミングGauche

Re: Clojure カッコイイ!

そういえば先日、@shunsuk さんから「Clojure を使うメリットって何?」と聞かれました。困りました。
  1. S式で Java が書ける
  2. Java の経験があって Lisp が好きな人はうれしい
この二つしか思い浮かびませんでした・・・。結局、両方とも同じ意味ですよね。。個人的にはこれくらいしかメリットが思い浮かびませんでした。Clojure の特徴はいろいろあると思うのですが、「Clojure でないと困る」とか「こういう時は Clojure が最適!」っていうケースがあるのか正直わかりませんし知りません。

私自身も、これから Clojure をメインで使いたいとか、プログラミングClojure を読み終えてからさらに勉強してみたいとも思えませんし・・・。

プログラミングClojure を読み終わったらもう一度考えてみたいと思います。っていうか、教えてエロい人!

追記

やっぱり、JVM で走って Java と仲の良い Lisp だからってことで FA?

プログラミングClojure

Clojure カッコイイ!

おもしろいページがあったのでメモ。

以下余談

遅ればせながら、プログラミングClojure を読んでいます。頂いてから随分経ってしまいました。。Clojure カッコイイですねぇ。おもしろいです。
今5章まで読んだところですが、5章(関数型プログラミング)とてもおもしろいです。
ここまでで良いなーと思った点は
  • 関数定義のコメント
  • doc 関数
  • 同名の関数で引数の数ごとに処理を記述できる(オーバーロードとか syntax-rules っぽいなーなどと)
  • 型ヒント
  • なんでもシーケンス
  • なんでも遅延シーケンス
  • Java の呼び出しが自然 (「S式で書ける Java」といった印象)
そういえば、多値とか継続はないっぽい?

やっぱり気になる。。といった点は
  1. 引数ベクタで[]しか使えない
  2. cond や let の括弧が少ない
両方とも好みの問題だと思います。1 は見る分には慣れてきました。書く時はやはり()で書けた方が好きです。2 は相変わらず見づらいです。でも両方とも大して気になりません。


プログラミングClojure

2010/06/24

syntax-rules: across (Clojure の .. ぽいもの)

プログラミングClojure P.62~ 「Clojure から Java を使う」より。
(.getLocation (.getCodeSource (.getProtectionDomain (.getClass '(1 2)))))

(.. '(1 2) getClass getProtectionDomain getCodeSource getLocation)
と書けますよーということのようです。

Java だと
'(1 2).getClass().getProtectionDomain().getCodeSourse().getLocation();
みたいなイメージで良いんでしょうかね。


scheme (gauche) の syntax-rules で書くと下記のような感じでしょうか。
良い名前が思いつきませんでした。当初は chain にしてましたが、なんとなく across に変えました。。

書いてみたコードは以下のようなもの。
;; across
;; (across)
;; #f
;; (across 3)
;; 3
;; 3
;; (across 3 (pa$ * 10))
;; ((pa$ * 10) 3)
;; 30
;; (across 3 (cut * <> 2) (cut + 10 <>))
;; (across ((cut * <> 2) 3) (cut + 10 <>))
;; (across ((cut + 10 <>) ((cut * <> 2) 3)))
;; ((cut + 10 <>) ((cut * <> 2) 3))
;; 16
;; (across 3 (cut * <> 2) (cut + 10 <>) x->string)
;; (across ((cut * <> 2) 3) (cut + 10 <>) x->string)
;; (across ((cut + 10 <>) (cut * <> 2) 3) x->string)
;; (across (x->string ((cut + 10 <>) (cut * <> 2) 3)))
;; (x->string ((cut + 10 <>) ((cut * <> 2) 3)))
;; "16"
(define-syntax across
(syntax-rules ()
((_) #f)
((_ exp) exp)
((_ exp1 exp2)
(exp2 exp1))
((_ exp1 exp2 exp3 ...)
(let1 val (across exp1 exp2)
(across val exp3 ...)))
))
(across)
;; #f
(across 3)
;; 3
(across 3 (pa$ * 10))
;; 30
(across 3 (cut * <> 2) (cut + 10 <>))
;; 16
(across 3 (cut * <> 2) (cut + 10 <>) x->string)
;; "16"
(across (+ 1 2 3)
odd?)
;; #f
(across '(1 2 3 4 5)
length
odd?)
;; #t
(use srfi-1)
(across (iota 10)
(cut filter even? <>)
(cut fold + 0 <>))
;; 20
(define-syntax across
(syntax-rules ()
((_ exp) exp)
((_ exp1 exp2)
(exp2 exp1))
((_ exp1 exp2 exp3 ...)
(let1 val (across exp1 exp2)
(across val exp3 ...)))
))
(define-syntax across-right
(syntax-rules ()
((_ exp) exp)
((_ exp1 exp2)
(exp1 exp2))
((_ exp1 exp2 exp3 ...)
(exp1 (across-right exp2 exp3 ...)))))
(across-right x->string
(cut + 10 <>)
(cut * <> 2)
3)
;; "16"
view raw across.scm hosted with ❤ by GitHub


追記

本家ソースはこれかな。

追記2

コメント欄で教えていただきました!名前が良いなぁ。
let1 要らないですね。。
(define-syntax across
(syntax-rules ()
((_ exp) exp)
((_ exp1 exp2)
(exp2 exp1))
((_ exp1 exp2 exp3 ...)
(across (exp2 exp1) exp3 ...))))
view raw across2.scm hosted with ❤ by GitHub

プログラミングClojure

2010/06/20

なんで Lisp/Scheme の変数名は長いの?

そういえば。さっきの記事を書き終わって思い出しました。shiro さんがこんなことを仰っていた。
Lisp/Schemeの変数名が長くなりがちなのは、変数名にしか読者への情報を乗せられないということもあるな。静的型なら型名に情報を乗せて、変数名自体は一文字でもけっこういける。
だが型情報だけが乗せたい情報というわけでもない。とすれば一般的にメタ情報を乗せる仕組みをつくればいいか?
Clojureのmetaはそういう仕組みではあるな。
なるほどー。

ところで Clojure の meta ってなんだろ。プログラミングClojure P.54 の「メタデータ」のところのことかな。せっかく頂いたのにまだ読んでいない・・・。

追記

長いシンボルを補完できるエディタがあったからだと思います RT @valvallow: なんで Lisp/Scheme の変数名は長いの? http://ff.im/-moAHF

@wasabiz それもあるけど、組み込み関数の命名とかさ。Common Lispは「クソ長い」の。AT&TのC文化圏では「命名は短く」ってのがあって、それはテキストエディタで打つとメンドくせえし間違えるから。CLは関数名を「自動補完で記述する」前提があるんですよ。


追記


プログラミングGaucheプログラミングClojure

Common Lisp のなかで最も名前が長いシンボル

On Lisp の後注、P.400 にあるコードを試しに実行してみました。38文字て・・・。
以下の式は, 現在ののパッケージで可視になっているすべてのシンボルを名前の長い順に並べたリストを返す.
(以下のコードは本にあったコードに princ を追加したものです)
;; On Lisp P.400
(princ (let ((syms nil))
(do-symbols (s)
(push s syms))
(sort syms #'(lambda (x y)
(> (length (symbol-name x))
(length (symbol-name y)))))))
;; (LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT
;; LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT
;; LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT
;; LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT
;; LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT
;; LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT
;; LEAST-POSITIVE-NORMALIZED-LONG-FLOAT
;; LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT
;; FUNDAMENTAL-CHARACTER-OUTPUT-STREAM
;; UPDATE-INSTANCE-FOR-DIFFERENT-CLASS
;; UPDATE-INSTANCE-FOR-REDEFINED-CLASS
;; FUNDAMENTAL-CHARACTER-INPUT-STREAM
;; LOAD-LOGICAL-PATHNAME-TRANSLATIONS
;; IMPLICIT-GENERIC-FUNCTION-WARNING
;; SIMPLE-CONDITION-FORMAT-ARGUMENTS FUNDAMENTAL-BINARY-OUTPUT-STREAM
;; *EFFICIENCY-NOTE-COST-THRESHOLD* FLOATING-POINT-INVALID-OPERATION
;; FUNDAMENTAL-BINARY-INPUT-STREAM *STACK-ALLOCATE-DYNAMIC-EXTENT*
;; *COMPILER-PRINT-VARIABLE-ALIST* SIMPLE-CONDITION-FORMAT-CONTROL
;; DOUBLE-FLOAT-POSITIVE-INFINITY IMPLICIT-GENERIC-FUNCTION-NAME
;; DOUBLE-FLOAT-NEGATIVE-INFINITY SINGLE-FLOAT-NEGATIVE-INFINITY
;; SINGLE-FLOAT-POSITIVE-INFINITY INTERNAL-TIME-UNITS-PER-SECOND
;; SHORT-FLOAT-POSITIVE-INFINITY REMOVE-IMPLEMENTATION-PACKAGE
;; SHORT-FLOAT-NEGATIVE-INFINITY MAKE-DISPATCH-MACRO-CHARACTER
;; LOGICAL-PATHNAME-TRANSLATIONS SINGLE-FLOAT-NEGATIVE-EPSILON
;; PPRINT-EXIT-IF-LIST-EXHAUSTED DOUBLE-FLOAT-NEGATIVE-EPSILON
;; FUNDAMENTAL-CHARACTER-STREAM LONG-FLOAT-NEGATIVE-INFINITY
;; *DEBUG-PRINT-VARIABLE-ALIST* LONG-FLOAT-POSITIVE-INFINITY
;; *DEBUG-PRINT-VARIABLE-ALIST* *ONLY-BLOCK-START-LOCATIONS*
;; TWO-WAY-STREAM-OUTPUT-STREAM INVOKE-RESTART-INTERACTIVELY
;; SET-DISPATCH-MACRO-CHARACTER SHORT-FLOAT-NEGATIVE-EPSILON
;; GET-DISPATCH-MACRO-CHARACTER DEFCONSTANT-UNEQL-NEW-VALUE
;; DEFCONSTANT-UNEQL-OLD-VALUE *MODULE-PROVIDER-FUNCTIONS*
;; PACKAGE-IMPLEMENTED-BY-LIST PACKAGE-LOCKED-ERROR-SYMBOL
;; SYMBOL-PACKAGE-LOCKED-ERROR *TRACE-ENCAPSULATE-DEFAULT*
;; *DEFAULT-PATHNAME-DEFAULTS* UPGRADED-ARRAY-ELEMENT-TYPE
;; HASH-TABLE-REHASH-THRESHOLD LEAST-POSITIVE-DOUBLE-FLOAT
;; CONCATENATED-STREAM-STREAMS LEAST-NEGATIVE-DOUBLE-FLOAT
;; MAKE-LOAD-FORM-SAVING-SLOTS *READ-DEFAULT-FLOAT-FORMAT*
;; LISP-IMPLEMENTATION-VERSION LONG-FLOAT-NEGATIVE-EPSILON
;; LEAST-POSITIVE-SINGLE-FLOAT LEAST-NEGATIVE-SINGLE-FLOAT
;; TWO-WAY-STREAM-INPUT-STREAM ADD-IMPLEMENTATION-PACKAGE
;; *SHOW-ENTRY-POINT-DETAILS* TRANSLATE-LOGICAL-PATHNAME
;; UPGRADED-COMPLEX-PART-TYPE LEAST-POSITIVE-SHORT-FLOAT
;; MOST-NEGATIVE-DOUBLE-FLOAT ARITHMETIC-ERROR-OPERATION
;; COMPUTE-APPLICABLE-METHODS LEAST-NEGATIVE-SHORT-FLOAT
;; MOST-NEGATIVE-SINGLE-FLOAT MOST-POSITIVE-SINGLE-FLOAT
;; READ-PRESERVING-WHITESPACE MOST-POSITIVE-DOUBLE-FLOAT
;; FUNCTION-LAMBDA-EXPRESSION FUNDAMENTAL-BINARY-STREAM
;; FUNDAMENTAL-OUTPUT-STREAM HASH-TABLE-SYNCHRONIZED-P
;; *INTEXP-MAXIMUM-EXPONENT* *UNDEFINED-WARNING-LIMIT*
;; *ENCLOSING-SOURCE-CUTOFF* MOST-POSITIVE-SHORT-FLOAT
;; MOST-NEGATIVE-SHORT-FLOAT MAKE-STRING-OUTPUT-STREAM
;; PACKAGE-SHADOWING-SYMBOLS ECHO-STREAM-OUTPUT-STREAM
;; STANDARD-GENERIC-FUNCTION DEFINE-METHOD-COMBINATION
;; PRINT-NOT-READABLE-OBJECT LEAST-NEGATIVE-LONG-FLOAT
;; LEAST-POSITIVE-LONG-FLOAT ARITHMETIC-ERROR-OPERANDS
;; STREAM-ADVANCE-TO-COLUMN FUNDAMENTAL-INPUT-STREAM
;; STREAM-READ-CHAR-NO-HANG RESTRICT-COMPILER-POLICY
;; DESCRIBE-COMPILER-POLICY *INLINE-EXPANSION-LIMIT*
;; BYTES-CONSED-BETWEEN-GCS *TRACE-INDENTATION-STEP*
;; UNWIND-TO-FRAME-AND-CALL LISP-IMPLEMENTATION-TYPE
;; MAKE-STRING-INPUT-STREAM WITH-HASH-TABLE-ITERATOR
;; BROADCAST-STREAM-STREAMS TYPE-ERROR-EXPECTED-TYPE
;; FLOATING-POINT-UNDERFLOW ARRAY-HAS-FILL-POINTER-P
;; ENSURE-DIRECTORIES-EXIST GET-OUTPUT-STREAM-STRING
;; METHOD-COMBINATION-ERROR MAKE-CONCATENATED-STREAM
;; MOST-POSITIVE-LONG-FLOAT MOST-NEGATIVE-LONG-FLOAT
;; ECHO-STREAM-INPUT-STREAM STEP-FINISHED-CONDITION
;; PACKAGE-IMPLEMENTS-LIST PARSE-NATIVE-NAMESTRING
;; *DERIVE-FUNCTION-TYPES* STEP-VARIABLE-CONDITION
;; *EFFICIENCY-NOTE-LIMIT* *DEBUG-BEGINNER-HELP-P*
;; *MAX-TRACE-INDENTATION* WITH-CONDITION-RESTARTS
;; PRINT-UNREADABLE-OBJECT LAMBDA-PARAMETERS-LIMIT
;; MAKE-INSTANCES-OBSOLETE ENSURE-GENERIC-FUNCTION
;; *PRINT-PPRINT-DISPATCH* WITH-STANDARD-IO-SYNTAX
;; *COMPILE-FILE-TRUENAME* *COMPILE-FILE-PATHNAME*
;; COMPILER-MACRO-FUNCTION FLOATING-POINT-OVERFLOW
;; DEFCONSTANT-UNEQL-NAME DEFINE-HASH-TABLE-TEST
;; WITH-LOCKED-HASH-TABLE *INVOKE-DEBUGGER-HOOK*
;; WITH-UNLOCKED-PACKAGES NAME-CONFLICT-FUNCTION
;; PACKAGE-LOCK-VIOLATION STREAM-EXTERNAL-FORMAT
;; ARRAY-TOTAL-SIZE-LIMIT HASH-TABLE-REHASH-SIZE
;; GET-INTERNAL-REAL-TIME WITH-INPUT-FROM-STRING
;; FLOATING-POINT-INEXACT STREAM-WRITE-SEQUENCE DEFINE-SOURCE-CONTEXT
;; DISABLE-PACKAGE-LOCKS STEP-VALUES-CONDITION NAME-CONFLICT-SYMBOLS
;; WITHOUT-PACKAGE-LOCKS STEP-CONDITION-RESULT FRAME-HAS-DEBUG-TAG-P
;; *PRINT-LOCATION-KIND* DEFINE-ALIEN-VARIABLE UNDEFINED-ALIEN-ERROR
;; DEFINE-COMPILER-MACRO COMPILE-FILE-PATHNAME PACKAGE-ERROR-PACKAGE
;; USER-HOMEDIR-PATHNAME SYNONYM-STREAM-SYMBOL REINITIALIZE-INSTANCE
;; ENCODE-UNIVERSAL-TIME ARRAY-ROW-MAJOR-INDEX DECODE-UNIVERSAL-TIME
;; ARRAY-DIMENSION-LIMIT WITH-COMPILATION-UNIT MAKE-BROADCAST-STREAM
;; MULTIPLE-VALUES-LIMIT WITH-PACKAGE-ITERATOR GET-INTERNAL-RUN-TIME
;; UNBOUND-SLOT-INSTANCE WITH-OUTPUT-TO-STRING STREAM-READ-SEQUENCE
;; STREAM-FILE-POSITION STREAM-FINISH-OUTPUT FLOAT-TRAPPING-NAN-P
;; ARRAY-STORAGE-VECTOR FLOAT-DENORMALIZED-P PACKAGE-LOCKED-ERROR
;; ENABLE-PACKAGE-LOCKS *FLUSH-DEBUG-ERRORS* UNLOAD-SHARED-OBJECT
;; DEFINE-ALIEN-ROUTINE MOST-NEGATIVE-FIXNUM INVALID-METHOD-ERROR
;; DEFINE-SETF-EXPANDER CALL-ARGUMENTS-LIMIT COPY-PPRINT-DISPATCH
;; LAMBDA-LIST-KEYWORDS INTEGER-DECODE-FLOAT DIRECTORY-NAMESTRING
;; NO-APPLICABLE-METHOD SINGLE-FLOAT-EPSILON MULTIPLE-VALUE-PROG1
;; SET-SYNTAX-FROM-CHAR INTERACTIVE-STREAM-P MOST-POSITIVE-FIXNUM
;; PACKAGE-USED-BY-LIST *PRINT-RIGHT-MARGIN* PPRINT-LOGICAL-BLOCK
;; DOUBLE-FLOAT-EPSILON STREAM-CLEAR-OUTPUT STREAM-WRITE-STRING
;; STREAM-START-LINE-P STREAM-FORCE-OUTPUT STEP-CONDITION-FORM
;; PROCESS-STATUS-HOOK STEP-CONDITION-ARGS SYMBOL-GLOBAL-VALUE
;; PROCESS-CORE-DUMPED CANCEL-FINALIZATION HASH-TABLE-WEAKNESS
;; UNMUFFLE-CONDITIONS STEP-FORM-CONDITION NAME-CONFLICT-DATUM
;; *DEBUG-HELP-STRING* SYSTEM-AREA-POINTER DEFINE-SYMBOL-MACRO
;; *PRINT-MISER-WIDTH* FILE-ERROR-PATHNAME COMPILED-FUNCTION-P
;; CONCATENATED-STREAM DEFINE-MODIFY-MACRO MULTIPLE-VALUE-CALL
;; SIMPLE-BIT-VECTOR-P MULTIPLE-VALUE-SETQ SHORT-FLOAT-EPSILON
;; GET-MACRO-CHARACTER READ-DELIMITED-LIST MAKE-SYNONYM-STREAM
;; DO-EXTERNAL-SYMBOLS STREAM-ELEMENT-TYPE INITIALIZE-INSTANCE
;; MAKE-TWO-WAY-STREAM MULTIPLE-VALUE-LIST STRING-NOT-GREATERP
;; STREAM-ERROR-STREAM SET-PPRINT-DISPATCH MULTIPLE-VALUE-BIND
;; WITH-SIMPLE-RESTART SET-MACRO-CHARACTER FUNDAMENTAL-STREAM
;; STREAM-UNREAD-CHAR STREAM-CLEAR-INPUT STREAM-LINE-LENGTH
;; STREAM-LINE-COLUMN *MUFFLED-WARNINGS* CODE-DELETION-NOTE
;; *COMPILE-PROGRESS* WEAK-POINTER-VALUE LOAD-SHARED-OBJECT
;; UNSIGNED-LONG-LONG PRINT-NOT-READABLE *MACROEXPAND-HOOK*
;; TRANSLATE-PATHNAME NSTRING-CAPITALIZE DESTRUCTURING-BIND
;; ARRAY-DISPLACEMENT ARRAY-ELEMENT-TYPE SIMPLE-BASE-STRING
;; PATHNAME-DIRECTORY FILE-STRING-LENGTH GET-SETF-EXPANSION
;; METHOD-COMBINATION LONG-FLOAT-EPSILON *BREAK-ON-SIGNALS*
;; SPECIAL-OPERATOR-P NSUBSTITUTE-IF-NOT ADJUSTABLE-ARRAY-P
;; VECTOR-PUSH-EXTEND GET-UNIVERSAL-TIME UNDEFINED-FUNCTION
;; STREAM-FRESH-LINE STREAM-WRITE-BYTE STREAM-WRITE-CHAR
;; SAVE-LISP-AND-DIE DEFCONSTANT-UNEQL MUFFLE-CONDITIONS
;; TIMER-SCHEDULED-P NATIVE-NAMESTRING MAKE-WEAK-POINTER
;; PROCESS-EXIT-CODE *DEBUG-CONDITION* BACKTRACE-AS-LIST
;; *TRACED-FUN-LIST* *IN-THE-DEBUGGER* *DEBUG-READTABLE*
;; DEFINE-ALIEN-TYPE ENOUGH-NAMESTRING STORAGE-CONDITION
;; PACKAGE-NICKNAMES READ-CHAR-NO-HANG COMPILED-FUNCTION
;; *STANDARD-OUTPUT* STRING-RIGHT-TRIM ALLOCATE-INSTANCE
;; NSET-EXCLUSIVE-OR SERIOUS-CONDITION STRING-CAPITALIZE
;; CHAR-NOT-GREATERP ARRAY-IN-BOUNDS-P FUNCTION-KEYWORDS
;; REMOVE-DUPLICATES COMPILATION-SPEED SIMPLE-BIT-VECTOR
;; SUBSTITUTE-IF-NOT SHARED-INITIALIZE DELETE-DUPLICATES
;; MAKE-RANDOM-STATE SIMPLE-TYPE-ERROR METHOD-QUALIFIERS
;; *COMPILE-VERBOSE* LIST-ALL-PACKAGES &ALLOW-OTHER-KEYS
;; STREAM-READ-BYTE STREAM-READ-CHAR STREAM-READ-LINE
;; STREAM-PEEK-CHAR *AFTER-GC-HOOKS* STRING-TO-OCTETS
;; COMPARE-AND-SWAP INTERACTIVE-EVAL FLOAT-INFINITY-P
;; RESOLVE-CONFLICT GET-BYTES-CONSED UNSCHEDULE-TIMER
;; PACKAGE-LOCKED-P DISABLE-DEBUGGER *EVALUATOR-MODE*
;; INHIBIT-WARNINGS CALL-WITH-TIMING OCTETS-TO-STRING
;; DO-DEBUG-COMMAND *STACK-TOP-HINT* SET-EXCLUSIVE-OR
;; PACKAGE-USE-LIST ARRAY-TOTAL-SIZE *STANDARD-INPUT*
;; ARITHMETIC-ERROR UNBOUND-VARIABLE STRING-NOT-LESSP
;; STRING-NOT-EQUAL SOFTWARE-VERSION STRUCTURE-OBJECT
;; NSTRING-DOWNCASE HASH-TABLE-COUNT ARRAY-DIMENSIONS
;; BROADCAST-STREAM PATHNAME-MATCH-P MAKE-ECHO-STREAM
;; *GENSYM-COUNTER* GENERIC-FUNCTION PARSE-NAMESTRING
;; STRING-LEFT-TRIM SIMPLE-CONDITION WITH-OPEN-STREAM
;; TYPE-ERROR-DATUM COMPUTE-RESTARTS GET-DECODED-TIME
;; FIND-ALL-SYMBOLS ARRAY-RANK-LIMIT READ-FROM-STRING
;; CALL-NEXT-METHOD LOGICAL-PATHNAME PATHNAME-VERSION
;; DEFINE-CONDITION *PRINT-READABLY* SHADOWING-IMPORT
;; DIVISION-BY-ZERO MACHINE-INSTANCE PROCESS-ALIVE-P *CORE-PATHNAME*
;; ENABLE-DEBUGGER GET-TIME-OF-DAY NATIVE-PATHNAME LIST-ALL-TIMERS
;; STANDARD-METHOD *READ-SUPPRESS* PRINC-TO-STRING *LOAD-TRUENAME*
;; STRUCTURE-CLASS FILE-WRITE-DATE SIMPLE-STRING-P OUTPUT-STREAM-P
;; CHAR-CODE-LIMIT NSET-DIFFERENCE STRING-DOWNCASE PATHNAME-DEVICE
;; DESCRIBE-OBJECT FILE-NAMESTRING PPRINT-DISPATCH HOST-NAMESTRING
;; HASH-TABLE-TEST SIMPLE-VECTOR-P MACHINE-VERSION INVOKE-DEBUGGER
;; SYMBOL-FUNCTION PRIN1-TO-STRING ARRAY-DIMENSION WILD-PATHNAME-P
;; STRING-GREATERP POSITION-IF-NOT SLOT-MAKUNBOUND *LOAD-PATHNAME*
;; MERGE-PATHNAMES MAKE-HASH-TABLE CELL-ERROR-NAME STANDARD-CHAR-P
;; FLOAT-PRECISION STANDARD-OBJECT LOAD-TIME-VALUE *COMPILE-PRINT*
;; SYMBOL-MACROLET WRITE-TO-STRING *DEBUGGER-HOOK* SHORT-SITE-NAME
;; HASH-TABLE-SIZE PROCESS-STATUS WEAK-POINTER-P *STEPPER-HOOK*
;; SCHEDULE-TIMER *ED-FUNCTIONS* UNLOCK-PACKAGE PROCESS-OUTPUT
;; STEP-CONDITION INTERNAL-DEBUG *TRACE-VALUES* UNSIGNED-SHORT
;; LOAD-1-FOREIGN SYNONYM-STREAM PPRINT-NEWLINE INPUT-STREAM-P
;; GET-PROPERTIES READTABLE-CASE COPY-STRUCTURE BUILT-IN-CLASS
;; *ERROR-OUTPUT* INTEGER-LENGTH MAKE-LOAD-FORM *TRACE-OUTPUT*
;; WITH-ACCESSORS *PRINT-ESCAPE* *LOAD-VERBOSE* ROW-MAJOR-AREF
;; COMPILER-MACRO SET-DIFFERENCE DO-ALL-SYMBOLS COPY-READTABLE
;; MACRO-FUNCTION SYMBOL-PACKAGE SIMPLE-WARNING *PRINT-GENSYM*
;; DYNAMIC-EXTENT *PRINT-CIRCLE* MUFFLE-WARNING *PRINT-PRETTY*
;; GRAPHIC-CHAR-P TWO-WAY-STREAM CHAR-NOT-LESSP MAKE-CONDITION
;; CHAR-NOT-EQUAL LONG-SITE-NAME NSTRING-UPCASE NSUBSTITUTE-IF
;; STANDARD-CLASS RENAME-PACKAGE NO-NEXT-METHOD WITH-OPEN-FILE
;; RANDOM-STATE-P PPRINT-TABULAR WRITE-SEQUENCE *RANDOM-STATE*
;; INVOKE-RESTART DELETE-PACKAGE UNWIND-PROTECT *PRINT-LENGTH*
;; STREAM-TERPRI STREAM-LISTEN STEP-CONTINUE PROCESS-CLOSE
;; PROCESS-PLIST POSIX-ENVIRON PROCESS-INPUT PROCESS-ERROR
;; *GC-RUN-TIME* NAME-CONFLICT COMPILER-NOTE *TRACE-FRAME*
;; UNSIGNED-LONG UNSIGNED-CHAR ALIEN-FUNCALL IGNORE-ERRORS
;; MAKE-SEQUENCE REMOVE-IF-NOT BYTE-POSITION OPEN-STREAM-P
;; FILE-POSITION *PRINT-ARRAY* PPRINT-LINEAR RASSOC-IF-NOT
;; STANDARD-CHAR CONTROL-ERROR PPRINT-INDENT PATHNAME-TYPE
;; *PRINT-LEVEL* SIMPLE-STRING STRING-UPCASE NINTERSECTION
;; *PRINT-LINES* DOCUMENTATION UNSIGNED-BYTE SOFTWARE-TYPE
;; *PRINT-RADIX* UNUSE-PACKAGE PROGRAM-ERROR NEXT-METHOD-P
;; PATHNAME-NAME NSUBST-IF-NOT FINISH-OUTPUT EXTENDED-CHAR
;; MEMBER-IF-NOT PATHNAME-HOST ALPHANUMERICP SUBSTITUTE-IF
;; MACROEXPAND-1 PARSE-INTEGER CHAR-GREATERP MAKE-PATHNAME
;; STYLE-WARNING DELETE-IF-NOT PACKAGE-ERROR *TERMINAL-IO*
;; READ-SEQUENCE CHAR-DOWNCASE REMOVE-METHOD DEPOSIT-FIELD
;; MAKE-INSTANCE STRING-STREAM SIMPLE-VECTOR SLOT-EXISTS-P
;; *SAVE-HOOKS* WEAK-POINTER PROCESS-KILL INVALID-FASL ALWAYS-BOUND
;; MAYBE-INLINE *EXIT-HOOKS* POSIX-GETENV *POSIX-ARGV* PROCESS-WAIT
;; LOCK-PACKAGE *INIT-HOOKS* WITH-TIMEOUT UNSIGNED-INT LOAD-FOREIGN
;; SINGLE-FLOAT EXTERN-ALIEN DOUBLE-FLOAT BIT-VECTOR-P *PRINT-CASE*
;; MAKE-PACKAGE COUNT-IF-NOT INTERSECTION UNBOUND-SLOT SLOT-UNBOUND
;; *PRINT-BASE* LOWER-CASE-P CHANGE-CLASS STREAM-ERROR HANDLER-BIND
;; UPPER-CASE-P SIMPLE-ARRAY PRINT-OBJECT CLEAR-OUTPUT APROPOS-LIST
;; ALPHA-CHAR-P FIND-RESTART ADJUST-ARRAY HASH-TABLE-P DECODE-FLOAT
;; FORCE-OUTPUT *LOAD-PRINT* DOUBLE-FLOAT RESTART-NAME FIND-PACKAGE
;; RESTART-CASE DEFPARAMETER RESTART-BIND WRITE-STRING FLOAT-DIGITS
;; STRING-LESSP STRING-EQUAL DIGIT-CHAR-P ASSOC-IF-NOT READER-ERROR
;; FILL-POINTER HANDLER-CASE &ENVIRONMENT SUBST-IF-NOT PACKAGE-NAME
;; SIMPLE-ERROR MACHINE-TYPE RANDOM-STATE SLOT-MISSING COMPILE-FILE
;; SYMBOL-PLIST SINGLE-FLOAT SYMBOL-VALUE FREEZE-TYPE ATOMIC-INCF
;; FLOAT-NAN-P RUN-PROGRAM *INSPECTED* PROCESS-PID PROCESS-PTY
;; UTF8-STRING BOOLE-ANDC2 MAKE-STRING MACROEXPAND LOOP-FINISH
;; MAKE-METHOD FILE-LENGTH FILE-AUTHOR CLEAR-INPUT MAKE-SYMBOL
;; UNREAD-CHAR ECHO-STREAM FILE-STREAM PARSE-ERROR YES-OR-NO-P
;; STORE-VALUE SLOT-BOUNDP DENOMINATOR SYMBOL-NAME FMAKUNBOUND
;; PPRINT-FILL USE-PACKAGE NSUBSTITUTE DECLARATION RATIONALIZE
;; RETURN-FROM FIND-METHOD SHORT-FLOAT END-OF-FILE LIST-LENGTH
;; FLOAT-RADIX FDEFINITION BOTH-CASE-P BASE-STRING FIND-SYMBOL
;; SIGNED-BYTE VALUES-LIST RENAME-FILE STABLE-SORT DEFCONSTANT
;; DISASSEMBLE FIND-IF-NOT *READTABLE* BOOLE-ANDC1 CONCATENATE
;; *READ-EVAL* STRING-TRIM DELETE-FILE COPY-SYMBOL CHAR-UPCASE
;; VECTOR-PUSH SCALE-FLOAT POSITION-IF CALL-METHOD *READ-BASE*
;; MAKE-TIMER TIMER-NAME NULL-ALIEN MAKE-ALIEN FREE-ALIEN LONG-FLOAT
;; ALIEN-SIZE WITH-ALIEN WITH-SLOTS COMPLEMENT SUBSTITUTE CHAR-LESSP
;; ARRAY-RANK PPRINT-POP FIND-CLASS BOOLE-ORC1 DO-SYMBOLS TYPE-ERROR
;; COPY-ALIST WRITE-LINE PROBE-FILE WRITE-BYTE HASH-TABLE CONSTANTLY
;; BOOLE-NAND WRITE-CHAR FLOAT-SIGN *DEBUG-IO* FILE-ERROR TREE-EQUAL
;; NAMESTRING CHECK-TYPE IN-PACKAGE BOOLE-ORC2 MAKE-ARRAY SLOT-VALUE
;; CHARACTERP DEFGENERIC CELL-ERROR LONG-FLOAT *FEATURES* CHAR-EQUAL
;; DIGIT-CHAR ADD-METHOD BIT-VECTOR MAKUNBOUND READTABLEP CLASS-NAME
;; VECTOR-POP FRESH-LINE MASK-FIELD DEFPACKAGE *QUERY-IO* PPRINT-TAB
;; 2010-01-06 UNPROFILE TRULY-THE STEP-NEXT DEFGLOBAL STEP-INTO
;; PROCESS-P BACKTRACE LONG-LONG SAP-ALIEN ALIEN-SAP GET-ERRNO
;; BIT-ANDC1 DEFMETHOD READ-LINE FUNCTIONP FORMATTER NOTINLINE
;; BOOLE-AND PEEK-CHAR READ-BYTE BIT-ANDC2 DIRECTORY STRUCTURE
;; &OPTIONAL NUMERATOR CONSTANTP DEFSTRUCT SATISFIES FTRUNCATE
;; BYTE-SIZE BOOLE-CLR *MODULES* REVAPPEND COPY-TREE CHAR-NAME
;; BOOLE-IOR CHAR-CODE ETYPECASE READ-CHAR NTH-VALUE CONJUGATE
;; CTYPECASE RASSOC-IF IGNORABLE OTHERWISE CODE-CHAR MAKE-LIST
;; MEMBER-IF PATHNAMEP BOOLE-EQV COPY-LIST EVAL-WHEN BOOLE-NOR
;; BASE-CHAR CHARACTER CONDITION RATIONALP BOOLE-XOR USE-VALUE
;; *PACKAGE* REMOVE-IF NSUBST-IF BOOLE-SET NAME-CHAR DELETE-IF
;; READTABLE FINALIZE STEP-OUT C-STRING FUNCTION UNSIGNED TRUENAME
;; IDENTITY BIT-NAND IMAGPART NREVERSE KEYWORDP MISMATCH ASSOC-IF
;; TYPECASE CLASS-OF NBUTLAST PROCLAIM FUNCTION DEFCLASS CHAR-INT
;; SUBTYPEP SEQUENCE NOTEVERY BOOLE-C1 STRING<= INTEGERP LOGANDC1
;; MAP-INTO LDB-TEST COPY-SEQ MACROLET BIT-ORC2 BIT-ORC1 POSITION
;; REALPART UNINTERN PATHNAME RATIONAL PACKAGEP OPTIMIZE LOGCOUNT
;; STRING>= DEFMACRO TRUNCATE VARIABLE STRING/= UNEXPORT LOGANDC2
;; Y-OR-N-P STANDARD BOOLE-C2 COUNT-IF SUBST-IF FCEILING DESCRIBE
;; CONTINUE COMPLEXP PROFILE TIMEOUT INTEGER BOOLEAN DECLAIM DEFTYPE
;; STRING= NSUBLIS LOGTEST PROVIDE BIT-XOR STREAMP LOGORC2 BUTLAST
;; BIT-EQV STRING< BIT-IOR BIT-NOR WARNING UNTRACE SPECIAL SUBSETP
;; LOGORC1 BIT-AND LOGNAND ROTATEF REMHASH MAPLIST FBOUNDP CLRHASH
;; PACKAGE STRINGP PUSHNEW REMPROP LOGBITP PAIRLIS KEYWORD FUNCALL
;; TAGBODY BOOLE-2 CEILING COMPLEX REQUIRE STRING> INSPECT BOOLE-1
;; NUMBERP GETHASH COMPILE VECTORP REPLACE MAPHASH SEVENTH DECLARE
;; REVERSE INTEGER NRECONC FIND-IF LOCALLY GENTEMP BOOLEAN DRIBBLE
;; BIT-NOT SYMBOLP DOTIMES APROPOS RESTART DEFSETF TYPE-OF REPORT
;; GLOBAL PURIFY SIGNED STRUCT DOUBLE VALUES RASSOC FROUND MINUSP
;; EQUALP VECTOR LABELS TERPRI CHAR<= FOURTH RPLACD SIGNUM CAADDR
;; SUBSEQ CADAAR FORMAT BIGNUM FLOATP EIGHTH GENSYM VALUES INTERN
;; APPEND UNLESS REDUCE ASSERT ADJOIN INLINE DOLIST SUBLIS LISTEN
;; DELETE FIXNUM NUNION SHIFTF CDADAR CDAAAR LOGAND LOGNOT IGNORE
;; PPRINT BOUNDP LOGXOR CDDDAR CDDAAR CAAAAR LAMBDA CADDAR SHADOW
;; LENGTH MEMBER DEFVAR CADADR SECOND MAPCAN NTHCDR &WHOLE STREAM
;; STRING CADDDR RPLACA COERCE SXHASH SYMBOL NOTANY MAPCON CDDADR
;; IMPORT MAPCAR CDAADR SIGNAL RANDOM LOGNOR NSUBST CERROR CDADDR
;; CHAR>= REMOVE EXPORT SEARCH NUMBER RETURN LOGIOR SAFETY CHAR/=
;; LOGEQV METHOD CDDDDR ARRAYP CAAADR CAADAR FFLOOR RESET TIMER FLOAT
;; ARRAY DEREF ALIEN UNION SHORT PSETQ QUOTE DEFUN &REST ROUND FLOAT
;; PROGN APPLY TENTH EVERY PSETF PROG* ABORT CDDAR CATCH CDADR ECASE
;; BREAK PHASE ARRAY SLEEP CADAR BLOCK CDAAR COUNT ERROR ASSOC TYPEP
;; ACOSH ACONS CDDDR NCONC ATANH FTYPE SPACE FIRST SIXTH THIRD RATIO
;; LDIFF PRIN1 DEBUG CAADR SUBST &BODY PRINT EQUAL PROG1 WRITE EVENP
;; CAAAR PROG2 ASINH TRACE PLUSP REALP UNION SCHAR CONSP CLOSE SPEED
;; CLASS CCASE CADDR LIST* CHAR< SVREF ISQRT ZEROP LISTP BOOLE FLOOR
;; PRINC MERGE CHAR> FIFTH TAILP NINTH PROGV CHAR= THROW QUIT SLOT
;; CHAR CAST ADDR VOID ENUM LONG REAL MAPL LET* CDDR ATAN CONS PROG
;; REST TIME GETF REMF LOAD SORT CADR CDAR WHEN TYPE CHAR ACOS LOOP
;; COND LAST FLET NULL ASIN FILL WARN PUSH INCF OPEN TANH ATOM CAAR
;; BYTE ENDP AREF &KEY SOME SQRT FIND ROOM &AUX MAPC LIST SINH EXPT
;; DECF SBIT SETQ EVAL READ STEP ODDP SETF CASE COSH SYMS ARG VAR INT
;; SIN REM AND BIT CAR MAP NIL +++ NOT MIN COS EXP SET GET DPB NTH
;; MAX GCD LET LOG DO* ABS ASH THE CDR *** POP MOD LCM /// EQL ELT
;; TAN CIS LDB GC 1- >= ++ OR ** GO // <= DO EQ ED 1+ PI IF /= * > +
;; T * = < - / X Y S)
view raw *sbcl*.lisp hosted with ❤ by GitHub


On Lisp

Lisp は「C 言語並みに速い」「C 言語より速い場合がある」

だそうです。

On Lisp

On Lisp 後注より
Gabriel, Richard P. Performance and Standardization. Proceedings of the First International Workshop on Lisp Evolution and Standardization, 1988, p.60
ある処理系で triangle を試していて, Gabriel は次のことを発見した:「プログラマが C コンパイラにレジスタ割り当ての指示を与えたときと比べても, C 版の反復による実装よりも Lisp 版のほうが 17% も高速だった.」彼の論文では Lisp で実装したほうが C より高速になるプログラムが他にもいくつか挙がっており, なかには 43% も高速になったものもある.

Lisp:よくある誤解

Lisp:よくある誤解 「Lispは高速なプログラムが書けない?」 より
LispでもほぼC並に速いコードを 書くことは可能です。
C並に速いLispコードは見た目も安全性もC並になる

ベンチマーク

こういうベンチマークもあるそうで

Let Over Lambda

Lisp の速度について、LET OVER LAMBDA Edition 1.0 では6章で扱っていました。
Lisp は速い。本当に速いのだ。
この章では、Lisp が他のあらゆるプログラミング言語よりも速くなり得ること、実は C のような低水準プログラミング言語は、マクロがかけているため、Lisp に対して性能面で不利なことを明らかするつもりである。 
参考までに LOL の6章の目次はこんな感じ。
  • 第6章
    • Lisp は速い
    • マクロが Lisp を速くする
    • ディスアセンブラと仲良くなる
    • ポインタスコープ
    • tlist とコンスプール
    • ソーティングネットワーク
    • コンパイラの書き方とベンチマーク 

参考


追記

まさか shiro さんのところに valvallow という文字が現れるようなことが起こるとは・・・。
すげーな Common Lisp ・・・。

追記2

How to make Lisp go faster than C
という論文が面白いです。
簡単な画像処理をCとCommon Lispで書いて速度を比べるというものですが、
CLの速度の劇的な変化が笑えます。
インタプリタで実行 -> Cの2300倍遅い
コンパイルして実行 -> Cの60倍遅い
型宣言と最適化を付ける -> Cと同等の速度(一部に関してはCより速い)

追記3

LET OVER LAMBDA Edition 1.0 P.75 より
(CL-PPCRE は、Common Lisp で書かれた正規表現ライブラリ)
第1に、CL-PPCRE は高速である。本当に高速だ。品質の良いネイティブコードコンパイラでコンパイルすれば、ほとんどの正規表現に対するベンチマークが、CL-PPCRE の方が Perl よりも2倍か、もっと高速だという結果をしばしば示す。そして、Perl の正規表現エンジンは、非 Lisp 正規表現エンジンの中では最高速なものの1つだ。それは C で書かれ、高度に最適化されたエンジンなのである。

LET OVER LAMBDA Edition 1.0


On Lisp 読了

ようやく LET OVER LAMBDA Edition 1.0 に引き続き On Lisp を読み終わりました。これが初級者向けってホントですか。前半はまー、確かにそうでしょうけども。。Lisp 怖い。


個人的におもしろかったのは、
  • Paul Graham 節
  • 前半の入門的なところ
  • ユーティリティ関数のところ
    • コードがキレイ
    • こういう風にユーティリティを書いていけば良いのかー。
  • マクロの導入的なところ
    • 「マクロとはこういうものだ」というのが随所に書かれていて、丁寧でわかりやすい
    • できること、できないこと、長所、短所、デバッグ方法、ハマりどころ
    • やっぱりマクロは難しいんだ
    • 「こうやって書いていけば良いよ」
  • アナフォリックマクロ
    • カッコイイ
  • 非決定性
    • とてもわかりやすい
  • CLOS
    • 言うほど異色じゃなくね?(ほんの少ししか紹介されていなかったからかも)
  • 付録のパッケージのところ
    • パッケージややこしそう。
でしょうか。

継続の実装のところは少し期待を裏切られました。あとATN コンパイラと Prolog のところは完全に置いていかれました。

コードがキレイですごく見やすかったです。お手本にしたいコード(当たり前か)。私は先に LET OVER LAMBDA Edition 1.0 を読みました。LOL もすごくおもしろかったのですが内容的にもコード的にも読むのに負荷が高かったです。On Lisp を先に読んだ方が良いのではないかと思います。


On LispLET OVER LAMBDA Edition 1.0

「最終的には Prolog を 94 行で実装した.」

Web 版にはないと思われますが、P.393以降の「後注」に以下の様なことが書かれています。
最終的には Prolog を 94 行で実装した. それには以前の章から 90 行分のユーティリティを持ってきて使っている. ATN コンパイラにはさらに 33 行を追加したので, 217 行になる. ただし Lisp の言語仕様上では行という概念が無いので, Lisp プログラムの長さを行数で図ると誤差が大きいことに注意.
最後の一文。
ただし Lisp の言語仕様上では行という概念が無いので, Lisp プログラムの長さを行数で図ると誤差が大きいことに注意.
そうですよね。。ならどんな単位で測ると良いんでしょうね。

そういえば、「Lisp は S/N 比が高いので・・・」どうのこうの、というようなことを良く見聞きしますが、S/N 比ってなんなんでしょう?
ノイズが少ないってことなんですかね。


On Lisp の後注がおもしろいですね。Yコンビネータが出てきたり、SICP(計算機プログラムの構造と解釈)が出てきたりします。Paul Graham は自分のやってる VC の名前を「Y Combinator」にしたり、SICP の原書にレビューしてたりと、きっと両方共好きなんでしょうね。SICP 原書のレビューの方には、最近話題(と、言っても原書は20年前のものらしい)の実用 Common Lisp (IT Architects’Archive CLASSIC MODER) の著者 Peter Norvig 氏もレビューしてますね。

On Lisp

「ファーストクラスの脱出手続き」

schemeは, ファースト・クラスの脱出手続きを採用した初めての広く使われたプログラミング言語であった
ってのは、やっぱ継続のことですよね。

継続は非局所的脱出, バックトラッキング, コルーチンなど広範囲の高度な制御構造を実装することに有用である。
とも。


プログラミングGauche

RnRS 年表と資料へのポインタ

ようやく R5RS を読み始めました。まだ始めの方しか読んでませんが、意外におもしろいです。
これなら R4RS や R3RS なんかもさかのぼって読んでみたい!と思いましたが、日本語訳は見当たりませんね。。やっぱり読むなら英語ですか・・・。


年号は R5RS 犬飼さん版日本語訳の P.2 「はじめに - 背景」を参考にしています。
1975年は、TCP/IP が公開されたり、Microsoft がスタートしたりした年みたいですね。


お、Practical Scheme にこんなページが。

追記

コメントにて R4RS は日本語訳があると教えて頂いたので、再度探してみました。
ここにリンクがあったのですが、リンク先は消失しているようです。

で、こちらに復刻版が!

プログラミングGaucheプログラミング言語SCHEME


2010/06/16

On Lisp 非決定性

On Lisp の非決定性の章がとてもわかりやすいです。以前写経した、syntax-rules 版の amb より、関数版の方がよくわかりました。
以下のコードは関数版の方です。取りあえず動かしてみました。
;; amb - ambiguous
;; On Lisp : P.300
;; http://www.komaba.utmc.or.jp/~flatline/onlispjhtml/nondeterminism.html
(define *paths* '())
(define failsym '@)
(define (choose choices)
(if (null? choices)
(fail)
(call-with-current-continuation
(lambda (cc)
(set! *paths*
(cons (lambda ()
(cc (choose (cdr choices))))
*paths*))
(car choices)))))
(define fail #f)
(call-with-current-continuation
(lambda (cc)
(set! fail
(lambda ()
(if (null? *paths*)
(cc failsym)
(let ((p1 (car *paths*)))
(set! *paths* (cdr *paths*))
(p1)))))))
(let ((x (choose '(1 2 3))))
(if (odd? x)
(+ x 1)
x))
;; 2
(let ((x (choose '(2 3))))
(if (odd? x)
(choose '(a b))
x))
;; 2
(let ((x (choose '(1 2))))
(if (odd? x)
(fail)
x))
;; 2
(let ((x (choose '(1 2))))
(if (odd? x)
(let ((y (choose '(a b))))
(if (eq? y 'a)
(fail)
y))
x))
;; b
(let ((x (choose '(1 2 3 4 5 6 7 8 9 10))))
(if (and (odd? x)
(zero? (modulo x 3))
(not (= x 3)))
x
(fail)))
;; 9
(define (two-numbers)
(list (choose '(1 2 3 4 5))
(choose '(1 2 3 4 5))))
(define (parlor-trick sum)
(let ((nums (two-numbers)))
(if (= (apply + nums) sum)
`(the sum of ,@nums)
(fail))))
(parlor-trick 5)
;; (the sum of 1 4)
view raw amb2.scm hosted with ❤ by GitHub


で、少し書き換えてみました。(Gauche)
(use gauche.parameter)
(define paths (make-parameter '()))
(define-constant failsym '@)
(define (choose choices)
(if (null? choices)
(fail)
(call/cc (lambda (cc)
(paths (cons (lambda ()
(cc (choose (cdr choices))))
(paths)))
(car choices)))))
(define fail
(call/cc (lambda (cc)
(lambda ()
(if (null? (paths))
(cc failsym)
(let ((p1 (car (paths))))
(paths (cdr (paths)))
(p1)))))))
;; (define two-numbers
;; (let ((numbers '()))
;; (lambda nums
;; (unless (null? nums)
;; (set! numbers nums))
;; (list (choose numbers)
;; (choose numbers)))))
;; (two-numbers 0 1 2 3 4 5 6 7 8 9)
;; (use srfi-1)
;; (define (make-two-numbers min max)
;; (let ((numbers (iota max min)))
;; (lambda ()
;; (list (choose numbers)
;; (choose numbers)))))
;; (define two-numbers (make-two-numbers 1 10))
;; (define (sum-comb sum)
;; (let loop ((acc '())
;; (nums (two-numbers)))
;; (cond ((eq? nums failsym) #?=acc)
;; ((not (= (apply + nums) sum))(fail))
;; ((find (cut lset= eq? nums <>) acc)(fail))
;; (else (loop (cons nums acc)
;; (two-numbers))))))
;; (define (sum-comb sum)
;; (let ((nums (two-numbers)))
;; (if (= (apply + nums) sum)
;; nums
;; (fail))))
;; (let ((acc '())
;; (comb (sum-comb 10)))
;; (set! acc (cons comb acc))
;; (when (find (cut lset= eq? comb <>) acc)
;; (fail))
;; acc)
view raw amb3.scm hosted with ❤ by GitHub


その後、自分でも思いついたサンプルを書こうとしたのですが、思ったように動きません。。わかったようでわかっていないようです・・・。

On Lisp

2010/06/09

(syntax-rules () ((_ "hoge" args ...


(define-syntax hoge
(syntax-rules ()
((_ x)
(hoge "hoge" x))
((_ "hoge" x)
(let ()
(print x)
(print "hoge")))))
(hoge 'valvallow)
;; valvallow
;; hoge
;; #<undef>
(macroexpand '(hoge 'valvallow))
;; (#<identifier user#let> ()
;; (#0=#<identifier user#print> 'valvallow)
;; (#0# "hoge"))
(hoge "hoge" 'valvallow)
;; valvallow
;; hoge
;; #<undef>
(macroexpand '(hoge "hoge" 'valvallow))
;; (#<identifier user#let> ()
;; (#0=#<identifier user#print> 'valvallow)
;; (#0# "hoge"))
(hoge "hoge")
;; hoge
;; hoge
;; #<undef>
(macroexpand '(hoge "hoge"))
;; (#<identifier user#let> ()
;; (#0=#<identifier user#print> "hoge")
;; (#0# "hoge"))
(define (p l1 l2)
(format #t " x:~a - y:~a\n" l1 l2))
(define-syntax print-reverse-list
(syntax-rules ()
((_ (x ...))
(print-reverse-list "sub" (x ...)()))
((_ "sub" (x1 x2 ...)())
(begin
(p '(x1 x2 ...)())
(print-reverse-list "sub" (x2 ...)(x1))))
((_ "sub" (x1 x2 ...)(y ...))
(begin
(p '(x1 x2 ...)'(y ...))
(print-reverse-list "sub" (x2 ...)(x1 y ...))))
((_ "sub" (x)(y1 y2 ...))
(print-reverse-list "sub" ()(x y1 y2 ...)))
((_ "sub" ()(y ...))
(p '() '(y ...)))))
(print-reverse-list (1 2 3 4 5))
;; x:(1 2 3 4 5) - y:()
;; x:(2 3 4 5), y:(1)
;; x:(3 4 5), y:(2 1)
;; x:(4 5), y:(3 2 1)
;; x:(5), y:(4 3 2 1)
;; x:(), y:(5 4 3 2 1)
;; #<undef>
(print-reverse-list (1))
;; x:(1) - y:()
;; x:(), y:(1)
;; #<undef>
(print-reverse-list ())
;; x:(), y:()

プログラミングGauche

define-syntax: upto, downto

正確には知りませんが、 ruby にこんなのありますよね。

;; upto, downto
;; (downto (i 99 0)
;; (print i))
;; (downto (i 99 0 1)
;; (print i))
;; (upto (i 0 99)
;; (print i))
;; (upto (i 0 99 1)
;; (print i))
(define-syntax downto
(syntax-rules ()
((_ (var init end step) body ...)
(do ((var init (- var step)))
((< var end))
body ...))
((_ (var init end) body ...)
(downto (var init end 1) body ...))))
;; test
(downto (i 99 0)
(print i))
(downto (i 99 0 2)
(print i))
(define-syntax upto
(syntax-rules ()
((_ (var init end step) body ...)
(do ((var init (+ var step)))
((> var end))
body ...))
((_ (var init end) body ...)
(upto (var init end 1) body ...))))
;; test
(upto (i 0 99)
(print i))
(upto (i 0 99 3)
(print i))
(define-syntax for
(syntax-rules ()
((_ ((var init) stop-exp upd-exp) body ...)
(do ((var init upd-exp))
((not stop-exp))
body ...))))
(define-syntax downto
(syntax-rules ()
((_ (var init end step) body ...)
(for ((var init)(<= end var)(- var step)) body ...))
((_ (var init end) body ...)
(downto (var init end 1) body ...))))
;; test
(let ((acc '()))
(downto (i 99 0 3)
(set! acc (append acc (list i))))
acc)
(define-syntax upto
(syntax-rules ()
((_ (var init end step) body ...)
(for ((var init)(<= var end)(+ var step)) body ...))
((_ (var init end) body ...)
(upto (var init end 1) body ...))))
;; test
(let ((acc '()))
(upto (i 0 99 3)
(set! acc (append acc (list i))))
acc)
view raw downto,upto.scm hosted with ❤ by GitHub


初めてのRuby

if-let1 の所在

On Lisp のアナフォリックマクロで aif というものがあります。scheme で書いてみたりしました。
Gauche には if-let1 があるということを教えて頂きました。
これですね。
で、grep してみたら lib/gauche/common-macros.scm の中にありました。このファイルはおもしろそうですね。。
;like aif in On Lisp, but explicit var
if-let1 なるほど、この名前しっくり。


ググってみると。



On Lisp

2010/06/08

Emacs windows.el 次のウィンドウ、前のウィンドウ

今まで C-. と C-, は、bs-cycle-next, bs-cycle-previous に割り当てていました。
これを C-> と C-< に変更して、C-. C-, は、windows.el の win-next-window, win-prev-window に割り当てました。
;; (global-set-key [?\C-,] 'bs-cycle-next)
;; (global-set-key [?\C-.] 'bs-cycle-previous)
(global-set-key [?\C-<] 'bs-cycle-next)
(global-set-key [?\C->] 'bs-cycle-previous)
(global-set-key "\C-x\C-b" 'bs-show)
(require 'windows)
(setq win:use-frame nil)
(win:startup-with-window)
(define-key ctl-x-map "C" 'see-you-again)
(global-set-key [?\C-.] 'win-next-window)
(global-set-key [?\C-,] 'win-prev-window)

.emacs 汚い・・・。整理したい。けど放置。

入門 GNU Emacs 第3版

2010/06/06

anaphora

else は、Common Lisp だと &optional else で良さそうだけど、syntax-rules だとどう書くのが良いのか。。
;; aif
(define-syntax aif
(syntax-rules ()
((_ var pred then else)
(let ((var pred))
(if var then else)))
((_ var pred then)
(let ((var pred))
(if var pred then)))))
(define-syntax aif
(syntax-rules ()
((_ var pred then else)
(let ((var pred))
(if var then else)))
((_ var pred then)
(aif var pred then (undefined)))))
(define-syntax aif
(syntax-rules ()
((_ var pred then . else)
(let ((var pred))
(if var then . else)))))
(define (test n)
(aif it (even? n)
it
'false))
(test 0)
;; #t
(test 1)
;; false
(aif it (even? 0) it)
;; #t
(aif it (even? 1) it)
;; #<undef>
(define-macro (aif pred then . else)
`(let ((it ,pred))
(if it ,then ,@else)))
(aif #t it it)
;; #t
(aif #f it it)
;; #f
view raw aif.scm hosted with ❤ by GitHub
こういうのは、衛生的なマクロでなくて素直に伝統的なマクロで書いた方が良さそうですね。というか、伝統的なマクロでないと書けないですね。

acond は scheme だと必要なさそうですね。
;; anaphora
(define-macro (aif pred then . else)
`(let ((it ,pred))
(if it ,then ,@else)))
(define-macro (awhen pred . body)
`(aif ,pred
(begin ,@body)))
(define-macro (awhile expr . body)
`(do ((it ,expr ,expr))
((not it))
,@body))
(define-macro (aand . args)
(cond ((null? args) #t)
((null? (cdr args))(car args))
(else `(aif ,(car args)(aand ,@(cdr args))))))
(define-macro (alambda params . body)
`(letrec ((self (lambda ,params ,@body)))
self))
view raw anaphora.scm hosted with ❤ by GitHub


On LispLET OVER LAMBDA Edition 1.0

condの節

これ知りませんでした。なんか、なんか、こうなってくれたらうれしそうな場面があったような・・・。。
gosh> (cond (#t))

#t


この形式って、何か名称ってあるんでしょうか。
(cond (#t => (cut display <>)))


プログラミングGauche

Gauche 文字列補間

ずっと補完だと思ってました。補間なんですね。
gosh> (define (hello name) #`"Hello, ,|name|!!")
hello
gosh> (hello 'valvallow)
"Hello, valvallow!!"

プログラミングGauche

Lisp/Scheme 読み物、メモ、よくわからないけど後で読む

Lisp関連の翻訳もの多数

社長がSchemerらしい。採用情報のページがなんかすごい。

Schemeのマクロ、継続関連。

コンパイラとか3impとか。

雑記

また探しに行ってみたけど、熊本の本屋さんには 実用 Common Lisp (IT Architects’Archive CLASSIC MODER) は置いてねぇーわ・・・。
ちょっと立ち読みしてみたいんだけどなぁ・・・。

実用 Common Lisp (IT Architects’Archive CLASSIC MODER)

2010/06/04

syntax-rules: define-memoize

以前、On Lisp に出てくるメモ化関数を試しに書いてみました。
追記で書きなおした方のものでも、再帰先の分まではメモってくれない、ということで良いと思います。そこで、マクロならなんとかなるかも知れない、と思って実験的に書いてみました。

こういうのはありなのか、これでちゃんと動くのか、よくわかりません。。
(let ((val (begin body ...))) ・・・) とか、これどうなんでしょう。

;; memoize
(define-syntax define-memoize
(syntax-rules ()
((_ (name arg) body ...)
(define name
(let ((cache (make-hash-table 'equal?)))
(lambda (arg)
(let ((val (hash-table-get cache arg #f)))
(if val
val
(let ((val (begin body ...)))
(hash-table-put! cache arg val)
val)))))))))
(define-memoize (fib n)
(if (< n 2)
1
(+ (fib (- n 1))
(fib (- n 2)))))
;(time (fib 35))
; real 0.000
; user 0.000
; sys 0.000
14930352
;(time (fib 2000))
; real 0.031
; user 0.016
; sys 0.015
6835702259575806647045396549170580107055408029365524565407553367798082454408054014954534318953113802726603726769523447478238192192714526677939943338306101405105414819705664090901813637296453767095528104868264704914433529355579148731044685634135487735897954629842516947101494253575869699893400976539545740214819819151952085089538422954565146720383752121972115725761141759114990448978941370030912401573418221496592822626
view raw memoize-3.scm hosted with ❤ by GitHub


で、上記の単一引数のものが、なんとなく動いてるようなので、可変長引数に対応させてみようとしたところ行き詰まりました。
(define-syntax define-memoize
(syntax-rules ()
((_ (name . args) body ...)
(define name
(let ((cache (make-hash-table 'equal?)))
(lambda args
(let ((val (hash-table-get cache args #f)))
(if val
val
(let ((val (begin body ...)))
(hash-table-put! cache args val)
val)))))))))
(define-memoize (fib n)
(if (< n 2)
1
(+ (fib (- n 1))
(fib (- n 2)))))
(fib 5)
;; *** ERROR: invalid application: (5)


デバッグしてみるわけです。
(define-syntax define-memoize
(syntax-rules ()
((_ (name . args) body ...)
(define name
(let ((cache (make-hash-table 'equal?)))
(lambda args
'(let ((val (hash-table-get cache args #f)))
(if val
val
(let ((val (begin body ...)))
(hash-table-put! cache args val)
val)))))))))
(let ((val (hash-table-get cache #0=(n) #f)))
(if val
val
(let ((val (begin (if (< n 2)
1
(+ (fib (- n 1))
(fib (- n 2)))))))
(hash-table-put! cache #0# val) val)))

そうか、#0# が (5) になって、5を関数として実行しようとしている、ということで良さそうです。
これがわかったから解決できたかというと、できていません。うーん。

追記


いつものごとく、@cametan_001 さんにアドバイス頂いて、... で書いてみたら取りあえず動くようになりましたー!
(define-syntax define-memoize
(syntax-rules ()
((_ (name arg ...) body ...)
(define name
(let ((cache (make-hash-table 'equal?)))
(lambda (arg ...)
(let ((val (hash-table-get cache `(,arg ...) #f)))
(if val
val
(let ((val (begin body ...)))
(hash-table-put! cache `(,arg ...) val)
val)))))))))
(define-memoize (fib n)
(if (< n 2)
1
(+ (fib (- n 1))
(fib (- n 2)))))
;(time (fib 100))
; real 0.000
; user 0.000
; sys 0.000
573147844013817084101
(define-syntax define-memoize
(syntax-rules ()
((_ (name arg ...) body ...)
(define name
(let ((cache (make-hash-table 'equal?)))
(lambda (arg ...)
(let ((al `(,arg ...)))
(let ((val (hash-table-get cache al #f)))
(if val
val
(let ((val (begin body ...)))
(hash-table-put! cache al val)
val))))))))))
view raw memoized-6.scm hosted with ❤ by GitHub

ところで、2引数以上でメモ化すると劇的に早くなる例が思いつきません・・・。眠いので、また明日 or 今度、ということで。

プログラミングGauche

2010/06/02

Re: syntax-rules: bind-variables

「...」だと、こうは書けないですよね。。
に反応頂きました!
(define-syntax bind-variables
(syntax-rules ()
((_ () form ...)
(begin form ...))
;; ここはオリジナルの syntax-error がどんな挙動か分からないので割愛
;; error で置き換えてみたが、本体に form ... が無い、と怒られた
;; ((_ ((var val0 val1 ...) ...) form ...)
;; (error "bind-variables illegal binding" (var val0 val1 ...)))
((_ ((var val) more-bindings ...) form ...)
(let ((var val)) (bind-variables (more-bindings ...) form ...)))
((_ ((var) more-bindings ...) form ...)
(let ((var #f)) (bind-variables (more-bindings ...) form ...)))
((_ (var more-bindings ...) form ...)
;; ここは、本当は上のパターンに差し替えたほうが綺麗かも
(let ((var #f)) (bind-variables (more-bindings ...) form ...)))
((_ bindings form ...)
(error "Bindings must be a list." bindings))
))
;; ;; 実行例
;; > (bind-variables ((a 1)
;; (b)
;; c
;; e
;; (d (+ a 3)))
;; (list a b c d e))
;; (1 #f #f 4 #f)
;; > (let ((a 1))
;; (bind-variables ((b)
;; c
;; e
;; (d (+ a 3)))
;; (list a b c d e)))
;; (1 #f #f 4 #f)
;; > (let ((a 1))
;; (let ((b #t))
;; (bind-variables (c
;; e
;; (d (+ a 3)))
;; (list a b c d e))))
;; (1 #t #f 4 #f)
;; > (bind-variables (a b c d e)
;; (list a b c d e))
;; (#f #f #f #f #f)
;; > (bind-variables ((a) (b) (c) (d) (e))
;; (list a b c d e))
;; (#f #f #f #f #f)
;; > (bind-variables (a (b 1) (c 2) d (e))
;; (list a b c d e))
;; (#f 1 2 #f #f)
;; >

写経したも同然ですが、早速自分なりに書いてみました。
(define-syntax bind-vars
(syntax-rules ()
((_ () body ...)
(let ()
body ...))
((_ ((var val) more ...) body ...)
(let ((var val))
(bind-vars (more ...)
body ...)))
((_ ((var) more ...) body ...)
(bind-vars ((var #f))
(bind-vars (more ...)
body ...)))
((_ (var more ...) body ...)
(bind-vars ((var))
(bind-vars (more ...)
body ...)))))
(bind-vars ((a 1)
(b)
c
e
(d (+ a 3)))
(list a b c d e))
;; (1 #f #f 4 #f)
(let ((a 1))
(bind-vars ((b)
c
e
(d (+ a 3)))
(list a b c d e)))
;; (1 #f #f 4 #f)
(let ((a 1))
(let ((b #t))
(bind-vars (c
e
(d (+ a 3)))
(list a b c d e))))
;; (1 #t #f 4 #f)
(bind-vars (a b c d e)
(list a b c d e))
;; (#f #f #f #f #f)
(bind-vars ((a)(b)(c)(d)(e))
(list a b c d e))
;; (#f #f #f #f #f)
(bind-vars (a (b 1)(c 2) d (e))
(list a b c d e))
;; (#f 1 2 #f #f)
view raw bind-vars2.scm hosted with ❤ by GitHub



オリジナルのコードだとsyntax-errorっての使ってますが、これはR5RSで定義されていないので、errorに差し替えています。
もっとも、2番目のパターンだとそれじゃあ怒られたので、syntax-errorの挙動がしりたいトコなんですけどねえ。
今読んでいるところまでには、出てきてないですね。
Gauche では、組み込みであるようです。
実行時ではなくマクロ展開時(すなわち、コンパイル時)に エラーを通知する

追記

あれ、これって「自分で書け」ってお題が出てるんですかね。
*** Write a syntax-error macro.
    Write `rejection' patterns by expanding into a call to
    syntax-error.

プログラミングGauche

syntax-rules: bind-variables

こういうの。
(bind-variables ((a 1)
            (b)
            c
            e
            (d (+ a 3)))
           (list a b c d e))
;; -> (1 #f #f 4 #f)

で、自分なりに書いてはみたものの・・・。かなり苦戦しました。
しかも複雑になってしまって、何が何やら。動いてはいるっぽいものの、これじゃーちょっと・・・。それに何よりダサい。
;; vind-vars
;; vind-variables http://web.archive.org/web/20060616054033/home.comcast.net/~prunesquallor/macro.txt
(define-syntax bind-vars
(syntax-rules ()
((_ () body ...)
(let ()
body ...))
((_ ((var init)) body ...)
(let ((var init))
body ...))
((_ ((var1 init1)(var2 init2) ...) body ...)
(bind-vars ((var1 init1))
(bind-vars ((var2 init2) ...)
body ...)))
((_ ((var1)) body ...)
(bind-vars ((var1 #f)) body ...))
((_ ((var1)(var2) ...) body ...)
(bind-vars ((var1))
(bind-vars ((var2) ...)
body ...)))
((_ ((var1)(var2 init2) ...) body ...)
(bind-vars ((var1))
(bind-vars ((var2 init2) ...)
body ...)))
((_ (var) body ...)
(bind-vars ((var))
body ...))
((_ (var1 var2 ...) body ...)
(bind-vars (var1)
(bind-vars (var2 ...) body ...)))
((_ (var1 (var2) ...) body ...)
(bind-vars (var1)
(bind-vars ((var2) ...) body ...)))
((_ (var1 (var2 init2) ...) body ...)
(bind-vars (var1)
(bind-vars ((var2 init2) ...) body...)))))
(bind-vars ((a 1)
(b)
c
e
(d (+ a 3)))
(list a b c d e))
;; (1 #f #f 4 #f)
(let ((a 1))
(bind-vars ((b)
c
e
(d (+ a 3)))
(list a b c d e)))
;; (1 #f #f 4 #f)
(let ((a 1))
(let ((b #t))
(bind-vars (c
e
(d (+ a 3)))
(list a b c d e))))
;; (1 #t #f 4 #f)
(bind-vars (a b c d e)
(list a b c d e))
;; (#f #f #f #f #f)
(bind-vars ((a)(b)(c)(d)(e))
(list a b c d e))
;; (#f #f #f #f #f)
(bind-vars (a (b 1)(c 2) d (e))
(list a b c d e))
;; (#f 1 2 #f #f)
view raw bind-vars.scm hosted with ❤ by GitHub


お手本はこちら。うーん、だいぶスッキリしていますね。「...」だと、こうは書けないですよね。。場合によってはドット対表現で書いた方がスッキリするんですね。
;; vind-variables http://web.archive.org/web/20060616054033/home.comcast.net/~prunesquallor/macro.txt
(define-syntax bind-variables
(syntax-rules ()
((bind-variables () form . forms)
(begin form . forms))
((bind-variables ((variable value0 value1 . more) . more-bindings) form . forms)
(syntax-error "bind-variables illegal binding" (variable value0 value1 . more)))
((bind-variables ((variable value) . more-bindings) form . forms)
(let ((variable value)) (bind-variables more-bindings form . forms)))
((bind-variables ((variable) . more-bindings) form . forms)
(let ((variable #f)) (bind-variables more-bindings form . forms)))
((bind-variables (variable . more-bindings) form . forms)
(let ((variable #f)) (bind-variables more-bindings form . forms)))
((bind-variables bindings form . forms)
(syntax-error "Bindings must be a list." bindings))))
(bind-variables ((a 1)
(b)
c
e
(d (+ a 3)))
(list a b c d e))
;; (1 #f #f 4 #f)
(let ((a 1))
(bind-variables ((b)
c
e
(d (+ a 3)))
(list a b c d e)))
;; (1 #f #f 4 #f)
(let ((a 1))
(let ((b #t))
(bind-variables (c
e
(d (+ a 3)))
(list a b c d e))))
;; (1 #t #f 4 #f)
(bind-variables (a b c d e)
(list a b c d e))
;; (#f #f #f #f #f)
(bind-variables ((a)(b)(c)(d)(e))
(list a b c d e))
;; (#f #f #f #f #f)
(bind-variables (a (b 1)(c 2) d (e))
(list a b c d e))
;; (#f 1 2 #f #f)


追記

書けてるー(笑)なるほどー。
(define-syntax bind-variables
(syntax-rules ()
((_ () form ...)
(begin form ...))
;; ここはオリジナルの syntax-error がどんな挙動か分からないので割愛
;; error で置き換えてみたが、本体に form ... が無い、と怒られた
;; ((_ ((var val0 val1 ...) ...) form ...)
;; (error "bind-variables illegal binding" (var val0 val1 ...)))
((_ ((var val) more-bindings ...) form ...)
(let ((var val)) (bind-variables (more-bindings ...) form ...)))
((_ ((var) more-bindings ...) form ...)
(let ((var #f)) (bind-variables (more-bindings ...) form ...)))
((_ (var more-bindings ...) form ...)
;; ここは、本当は上のパターンに差し替えたほうが綺麗かも
(let ((var #f)) (bind-variables (more-bindings ...) form ...)))
((_ bindings form ...)
(error "Bindings must be a list." bindings))
))
;; ;; 実行例
;; > (bind-variables ((a 1)
;; (b)
;; c
;; e
;; (d (+ a 3)))
;; (list a b c d e))
;; (1 #f #f 4 #f)
;; > (let ((a 1))
;; (bind-variables ((b)
;; c
;; e
;; (d (+ a 3)))
;; (list a b c d e)))
;; (1 #f #f 4 #f)
;; > (let ((a 1))
;; (let ((b #t))
;; (bind-variables (c
;; e
;; (d (+ a 3)))
;; (list a b c d e))))
;; (1 #t #f 4 #f)
;; > (bind-variables (a b c d e)
;; (list a b c d e))
;; (#f #f #f #f #f)
;; > (bind-variables ((a) (b) (c) (d) (e))
;; (list a b c d e))
;; (#f #f #f #f #f)
;; > (bind-variables (a (b 1) (c 2) d (e))
;; (list a b c d e))
;; (#f 1 2 #f #f)
;; >


プログラミングGauche

dotted Re: Re: syntax-rules: when, unless

ドット対でも書けるんですね。。(begin . body) って、最初見たとき「???」でしたよ。
(define-syntax my-when
(syntax-rules ()
((_ pred . body)
(if pred
(begin . body)))))
(my-when #t (display 'hoge))
;; hoge#<undef>
(mac (my-when #t (display 'hoge)))
;; (#<identifier user#if> #t
;; (#<identifier user#begin> (display 'hoge)))
(my-when #t (print 'hoge)(print 'fuga))
;; hoge
;; fuga
;; #<undef>
(mac (my-when #t (print 'hoge)(print 'fuga)))
;; (#<identifier user#if> #t
;; (#<identifier user#begin>
;; (print 'hoge)
;; (print 'fuga)))
view raw dotted.scm hosted with ❤ by GitHub


プログラミングGauche

戻り値 Re: syntax-rules: when, unless

when や unless って、戻り値が undef より #f の方が好みかも。なぜその方が良いかと言われると困るけど・・・。未定義が返るより、安心するというか。

;; when
(define-syntax my-when
(syntax-rules ()
((_ pred body ...)
(if pred
(begin
body ...)
#f))))
(when #f)
;; #<undef>
(my-when #f)
;; #f
(((lambda (f)
(f f))
(lambda (f)
(lambda (n)
(my-when (< 0 n)
(print n)
((f f)(- n 1)))))) 5)
;; 5
;; 4
;; 3
;; 2
;; 1
;; #f
(((lambda (f)
(f f))
(lambda (f)
(lambda (n)
(when (< 0 n)
(print n)
((f f)(- n 1)))))) 5)
;; 5
;; 4
;; 3
;; 2
;; 1
;; #<undef>
(((lambda (f)
(f f))
(lambda (f)
(lambda (n)
(my-when (< 0 n)
(print n)
((f f)(- n 1)))))) -1)
;; #f


Gauche の when, unless って、戻り値が未定義なわけですが、もしかしてその方が良い理由とかあったりするのかなー。
まー、戻り値が欲しいケースに出会った時に、when を上書いてしまえば良いのかな。そういう問題でもないのかな。うーん。

上書くというかシャドウするとか。
(let-syntax ((when (syntax-rules ()
((_ pred body ...)
(if pred
(begin body ...) #f)))))
(when #t)
(when #f))
;; #f
(when #f)
;; #<undef>
view raw shadow.scm hosted with ❤ by GitHub


when, unless で戻り値を利用するケースが発生すること自体、何か見直しが必要ということなのかも?

なんだか、以前も同じようなことをどこかで言ったような見たような・・・。そして教えてもらったような気も・・・。忘れた・・・orz

プログラミングGauche

Scheme マクロのデバッグ4種

マクロのデバッグ方法をいくつか。(* 追記あり)

expander

expander を使うのがオーソドックスみたいですね。
Gauche なら Common Lisp と同じく、macroexpand, macroexpand-1 などがあります。
(define-syntax nth-value
(syntax-rules ()
((_ n values-body)
(call-with-values
(lambda () values-body)
(lambda vals
(list-ref vals n))))))
(macroexpand-1 '(nth-value 0 (apply values '(a b c d e f g))))
;; (#<identifier user#call-with-values>
;; (#0=#<identifier user#lambda> () (apply values '(a b c d e f g)))
;; (#0# #1=#<identifier user#vals> (#<identifier user#list-ref> #1# 0)))
(macroexpand '(nth-value 3 (apply values '(a b c d e f g))))
;; (#<identifier user#call-with-values>
;; (#0=#<identifier user#lambda> () (apply values '(a b c d e f g)))
;; (#0# #1=#<identifier user#vals> (#<identifier user#list-ref> #1# 3)))
(macroexpand '(nth-value 10 (apply values '(a b c d e f g))))
;; (#<identifier user#call-with-values>
;; (#0=#<identifier user#lambda> () (apply values '(a b c d e f g)))
;; (#0# #1=#<identifier user#vals> (#<identifier user#list-ref> #1# 10)))
view raw debug1.scm hosted with ❤ by GitHub


mac

On Lisp よろしく mac マクロを定義しておくと便利そうです。
(define-syntax mac
(syntax-rules ()
((_ code)
(macroexpand-1 'code))))
(mac (nth-value 0 (apply values '(a b c d e f g))))
;; (#<identifier user#call-with-values>
;; (#0=#<identifier user#lambda> () (apply values '(a b c d e f g)))
;; (#0# #1=#<identifier user#vals> (#<identifier user#list-ref> #1# 0)))
view raw debug2.scm hosted with ❤ by GitHub


リーダーマクロ

Gacuhe #?= リーダーマクロはどうでしょう?うーん。
(define-syntax nth-value
(syntax-rules ()
((_ n values-body)
#?=(call-with-values
(lambda () values-body)
(lambda vals
(list-ref vals n))))))
(nth-value 0 (apply values '(a b c d e f g)))
;; #?=(call-with-values (lambda () (apply values '(a b c d e f g))) ...
;; #?- a
;; a
(define-syntax nth-value
(syntax-rules ()
((_ n values-body)
#?=(call-with-values
(lambda () #?=values-body)
(lambda vals
(list-ref #?=vals n))))))
(nth-value 0 (apply values '(a b c d e f g)))
;; #?=(call-with-values (lambda () (debug-print (apply values '(a b ...
;; #?="(stdin)":140:(apply values '(a b c d e f g))
;; #?- a
;; #?+ b
;; #?+ c
;; #?+ d
;; #?+ e
;; #?+ f
;; #?+ g
;; #?=vals
;; #?- (a b c d e f g)
;; #?- a
;; a
view raw debug3.scm hosted with ❤ by GitHub


quote

これは初見。任意のパターンの展開部分を quote しちゃう。これは意外と便利かも知れません。
*** Debugging trick
One very easy debugging trick is to wrap the template with a quote:
(define-syntax nth-value
(syntax-rules ()
((_ n values-body)
'(call-with-values
(lambda () values-body)
(lambda vals
(list-ref vals n))))))
(nth-value 0 (apply values '(a b c d e f g)))
;; (call-with-values (lambda () (apply values '(a b c d e f g)))
;; (lambda vals (list-ref vals 0)))
(nth-value 3 (apply values '(a b c d e f g)))
;; (call-with-values (lambda () (apply values '(a b c d e f g)))
;; (lambda vals (list-ref vals 3)))
(nth-value 10 (apply values '(a b c d e f g)))
;; (call-with-values (lambda () (apply values '(a b c d e f g)))
;; (lambda vals (list-ref vals 10)))
view raw debug4.scm hosted with ❤ by GitHub


複数のパターンがある場合に、特定のパターンだけ quote してみるとか・・・。
(define-syntax letstar
(syntax-rules ()
((_ () body ...)
'(let ()
body ...))
((_ ((var init)) body ...)
(let ((var init))
body ...))
((_ ((var1 init1)(var2 init2) ...) body ...)
(let ((var1 init1))
(letstar ((var2 init2) ...) body ...)))))
(letstar ()
(display 'a))
;; (let () (display 'a))
(letstar ((x 1))
(display 'a)
(display x))
;; a1#<undef>
(letstar ((x 1)
(y 2)
(z (+ x y)))
(print z))
;; 3
;; #<undef>
view raw debug5.scm hosted with ❤ by GitHub


マクロ初心者な私の知る限りこんなところでしょうか・・・。

追記

gaucheにはmac相当の%macroexpandがあるみたいです。さらにsyntax-rulesマクロなどをmacroexpandした際の表示を見やすくするunwrap-syntaxも便利です。


追記



The Reasoned Schemer

Emacs 行末のスペースに色をつける

意図しない時に、行末にスペースが入ることがあって、イラっとしてました。
これで解決。

(when (boundp 'show-trailing-whitespace)
  (setq-default show-trailing-whitespace t))

色は初期状態では真っ赤なので、変更したければ以下のように指定。
(set-face-background 'trailing-whitespace "purple4")

入門 GNU Emacs 第3版

Emacs 任意のサイズと起動時のサイズを切り替える

こういうのわざわざ書く必要も無いんでしょうけども。
起動時のサイズと場所、任意のサイズと場所に変更できるだけでよかったので、書いてみました。

はじめに、こう書いてみたのですが、意図した通りに動いてくれませんでした。
(defun change-frame-size (frame top left height width)
(interactive)
(set-frame-width frame width)
(set-frame-height frame height)
(set-frame-position frame left top))
(change-frame-size (selected-frame) 0 0 35 130)
view raw temp.emacs hosted with ❤ by GitHub


取りあえず、意図した動きをしてくれたので、これでOK。
;; channge frame size
(defun inject-alist (from to)
(mapcar '(lambda (e)
(let ((exist (assq (car e) from)))
(if exist exist e))) to))
(defun make-frame-alist (top left height width)
`((top . ,top)(left . ,left)
(height . ,height)(width . ,width)))
(defun change-frame-my-size ()
(interactive)
(let ((al (make-frame-alist 0 0 35 125)))
(modify-frame-parameters
(selected-frame)(inject-alist al initial-frame-alist))))
(defun change-frame-init-size ()
(interactive)
(modify-frame-parameters
(selected-frame) initial-frame-alist))
(define-key global-map "\C-cm" 'change-frame-init-size)
(define-key global-map "\C-cM" 'change-frame-my-size)
view raw @.emacs hosted with ❤ by GitHub


C-cm で起動時のサイズと場所に、C-cM で任意のサイズと場所に変更するようにしました。


なんか一冊読んでみたい気がしなくもない。

入門 GNU Emacs 第3版

Scheme マクロプログラミング ~基礎・応用~

みたいな本はないんでしょうか。日本語だと嬉しいんですが・・・。
On Lisp の Scheme 版みたいな。

scheme の「健全な(衛生的)マクロ」について基礎から詳しく書いてある書籍って、あるんでしょうか。見たことないし、聞いたこともない。ような気がします。あったら読んでみたいです。この際、R4RS でも・・・。

scheme の書籍でも、日本語の scheme 入門サイトでも、マクロはざっくり扱われている印象。
英語だと、濃そうなのは結構あるっぽい。

マクロの勘所は、あれこれ書いてみたり人のコードを読んだりしているうちに掴めるのかもしれません。ですが、なんというか、書籍1冊分くらいにまとまった量の情報を読みたいなーなどと思うわけです。。そういうのを読んで「へー!」とか「こういうふうに書けるのかー!」するのって楽しいんですよね。。

The Reasoned Schemer

syntax-rules: nth-value


多値を返す手続きから受け取った多値の n 番目を返すマクロ。
;; nth-value
;; http://web.archive.org/web/20060616054033/home.comcast.net/~prunesquallor/macro.txt
(define-syntax nth-value
(syntax-rules ()
((_ n values-body)
(call-with-values
(lambda () values-body)
(lambda vals
(list-ref vals n))))))
(nth-value 0 (apply values '(a b c d e f g)))
; -> a
(nth-value 3 (apply values '(a b c d e f g)))
; -> d
(nth-value 10 (apply values '(a b c d e f g)))
; -> *** ERROR: argument out of range: 10
view raw nth-value.scm hosted with ❤ by GitHub


The Scheme Programming Language, 4th Edition