((Pythonで) 書く (Lisp) インタプリタ)

Pythonで書くSchemeインタプリタです。

	#!/usr/bin/env python
	# -*- coding: utf-8 -*-
	### Env クラス
	class Env(dict):
	"環境: ペア{'var':val} の dict で、外部環境(outer)を持つ。"
	def __init__(self, parms = (), args = (), outer = None):
	self.update(zip(parms, args))
	self.outer = outer
	def find(self, var):
	"var が現れる一番内側の Env を見つける"
	return self if var in self else self.outer.find(var)
	### グローバル環境
	def add_globals(env):
	"環境に Scheme 標準の手続きのいくつか追加する"
	import math, operator as op
	env.update(vars(math)) # sin, sqrt, ...
	env.update(
	{'+':op.add, '-':op.sub, '*':op.mul, '/':op.div, 'not':op.not_,
	'>':op.gt, '<':op.lt, '>=':op.ge, '<=':op.le, '=':op.eq,
	'equal?':op.eq, 'eq?':op.is_, 'length':len, 'cons':lambda x, y: [x] + y,
	'car':lambda x: x[0], 'cdr':lambda x:x[1:], 'append':op.add,
	'list':lambda *x:list(x), 'list?':lambda x:isa(x, list),
	'null?':lambda x:x==[], 'symbol?':lambda x: isa(x, Symbol)})
	return env
	global_env = add_globals(Env())
	### 実行: eval
	def interpret(x, env = global_env):
	"環境の中で式を評価する。"
	if isa(x, Symbol): # 変数参照
	return env.find(x)[x]
	elif not isa(x, list): # 定数リテラル
	return x
	elif x[0] == 'quote': # (quote exp)
	(_, exp) = x
	return exp
	elif x[0] == 'if': # (if test conseq alt)
	(_, test, conseq, alt) = x
	return interpret((conseq if interpret(test, env) else alt), env)
	elif x[0] == 'define': # (define var exp)
	(_, var, exp) = x
	env[var] = interpret(exp, env)
	elif x[0] == 'lambda': # (lambda (var*) exp)
	(_, vars, exp) = x
	return lambda *args: interpret(exp, Env(vars, args, env))
	elif x[0] == 'begin': # (begin exp*)
	for exp in x[1:]:
	val = interpret(exp, env)
	return val
	else: # (proc exp*)
	exps = [interpret(exp, env) for exp in x]
	proc = exps.pop(0)
	return proc(*exps)
	isa = isinstance
	Symbol = str
	### 構文解析: read と parse
	def read(s):
	"文字列から Scheme 式を読み込む。"
	return read_from(tokenize(s))
	parse = read
	def tokenize(s):
	"文字列をトークンのリストに変換する。"
	return s.replace('(', ' ( ').replace(')', ' ) ').split()
	def read_from(tokens):
	"トークンの列から式を読み込む。"
	if len(tokens) == 0:
	raise SyntaxError('unexpected EOF while reading')
	token = tokens.pop(0)
	if '(' == token:
	L = []
	while tokens[0] != ')':
	L.append(read_from(tokens))
	tokens.pop(0) # pop off ')'
	return L
	elif ')' == token:
	raise SyntaxError('unexpected )')
	else:
	return atom(token)
	def atom(token):
	"数は数にし、それ以外のトークンはシンボルにする。"
	try: return int (token)
	except ValueError:
	try: return float(token)
	except ValueError:
	return Symbol(token)
	def to_string(exp):
	"Python オブジェクトを Lisp の読める文字列に戻す。"
	return '('+' '.join(map(to_string, exp))+')' if isa(exp, list) else str(exp)
	def repl(prompt='lis.py> '):
	"read-eval-print-loop のプロンプト"
	while True:
	val = interpret(parse(raw_input(prompt)))
	if val is not None: print to_string(val)
	repl()

view raw lispy.py hosted with ❤ by GitHub

実際は、Schemeとは呼べないんですけどね(笑)。仕様満たしてませんし。かつ単なる写経です(爆)。
作者はPAIPの著者として有名なPeter Norvig。過去はLisperとして有名でしたが、現在はPythonistaとして有名な人です。

「Lisp以外の言語で」Lispを実装してみる、ってのは初めての経験で、結構面白いとは思いました。
ただ、Pythonの構文の細かいトコには明るくないんで、「読解」自体は上手く行ってるとは思いませんが(笑)。んで、やっぱOOPは嫌いです(笑)。

ちなみに、Python2.6.xだとだいぶ改良されてはいますが、やっぱエンコーディングはめんどっちいと思っています。

Goldbach's conjecture

	;; P40 (**) Goldbach's conjecture.
	;; Goldbach's conjecture says that every positive even number greater than 2 is the sum of two prime numbers. Example: 28 = 5 + 23. It is one of the most famous facts in number theory that has not been proved to be correct in the general case. It has been numerically confirmed up to very large numbers (much larger than we can go with our Prolog system). Write a predicate to find the two prime numbers that sum up to a given even integer.
	;; Example:
	;; * (goldbach 28)
	;; (5 23)
	#lang racket
	(provide goldbach)
	(require "p39.ss")
	(define (goldbach n)
	(and (> n 2) (even? n)
	(let loop ((lst (eratosthenes n)))
	(let ((i (car lst)))
	(let ((j (- n i)))
	(if (member j lst)
	`(,i ,j)
	(loop (cdr lst))))))))

view raw p40.ss hosted with ❤ by GitHub

A list of prime numbers

	;; P39 (*) A list of prime numbers.
	;; Given a range of integers by its lower and upper limit, construct a list of all prime numbers in that range.
	#lang racket
	(provide (all-defined-out))
	(require srfi/1)
	(define (eratosthenes n)
	(let loop ((lst (iota n 3)) (acc '(2)))
	(let ((i (car acc)))
	(if (< (apply max lst) (expt i 2))
	(append (reverse acc) lst)
	(let ((lst (remove (lambda (x)
	(zero? (modulo x i)))
	lst)))
	(loop (cdr lst) (cons (car lst) acc)))))))
	(define (p39 m n)
	(remove (lambda (x)
	(< x m))
	(eratosthenes n)))

view raw p39.ss hosted with ❤ by GitHub

Compare the two methods of calculating Euler's totient function

	;; P38 (*) Compare the two methods of calculating Euler's totient function.
	;; Use the solutions of problems P34 and P37 to compare the algorithms. Take the number of logical inferences as a measure for efficiency. Try to calculate phi(10090) as an example.
	> (time (phi 10090))
	cpu time: 0 real time: 1 gc time: 0
	4032
	> (time (totient-phi 10090))
	cpu time: 4 real time: 4 gc time: 0
	4032
	>

view raw p38.ss hosted with ❤ by GitHub

Calculate Euler's totient function phi(m) (improved)

	;; P37 (**) Calculate Euler's totient function phi(m) (improved).
	;; See problem P34 for the definition of Euler's totient function. If the list of the prime factors of a number m is known in the form of problem P36 then the function phi(m) can be efficiently calculated as follows: Let ((p1 m1) (p2 m2) (p3 m3) ...) be the list of prime factors (and their multiplicities) of a given number m. Then phi(m) can be calculated with the following formula:
	;; phi(m) = (p1 - 1) * p1 ** (m1 - 1) + (p2 - 1) * p2 ** (m2 - 1) + (p3 - 1) * p3 ** (m3 - 1) + ...
	;; Note that a ** b stands for the b'th power of a.
	(require "p36.ss")
	(define (phi m)
	(let loop ((lst (prime-factors-mult m))
	(acc 1))
	(if (null? lst)
	acc
	(let ((p (caar lst))
	(m (- (cadar lst) 1)))
	(loop (cdr lst)
	(* (- p 1) (expt p m) acc))))))

view raw p37.ss hosted with ❤ by GitHub

Determine the prime factors of a given positive integer (2)

	;; P36 (**) Determine the prime factors of a given positive integer (2).
	;; Construct a list containing the prime factors and their multiplicity.
	;; Example:
	;; * (prime-factors-mult 315)
	;; ((3 2) (5 1) (7 1))
	;; Hint: The problem is similar to problem P13.
	#lang racket
	(provide prime-factors-mult)
	(require "p10.ss")
	(require "p35.ss")
	(define (prime-factors-mult n)
	(map reverse (encode (prime-factors n))))

view raw p36.ss hosted with ❤ by GitHub

Determine the prime factors of a given positive integer

	;; P35 (**) Determine the prime factors of a given positive integer.
	;; Construct a flat list containing the prime factors in ascending order.
	;; Example:
	;; * (prime-factors 315)
	;; (3 3 5 7)
	#lang racket
	(provide prime-factors)
	(require "p31.ss")
	(define (prime-factors n)
	(let loop ((x n) (y 2) (acc '()))
	(cond
	((= x 1)
	(reverse acc))
	((and (is-prime? y) (zero? (modulo x y)))
	(loop (/ x y) 2 (cons y acc)))
	(else
	(loop x (+ y 1) acc)))))

view raw p35.ss hosted with ❤ by GitHub

Calculate Euler's totient function phi(m)

	;; P34 (**) Calculate Euler's totient function phi(m).
	;; Euler's so-called totient function phi(m) is defined as the number of positive integers r (1 <= r < m) that are coprime to m.
	;; Example: m = 10: r = 1,3,7,9; thus phi(m) = 4. Note the special case: phi(1) = 1.
	;; * (totient-phi 10)
	;; 4
	;; Find out what the value of phi(m) is if m is a prime number. Euler's totient function plays an important role in one of the most widely used public key cryptography methods (RSA). In this exercise you should use the most primitive method to calculate this function (there are smarter ways that we shall discuss later).
	(require "p33.ss")
	(define (totient-phi m)
	(let loop ((r 1) (acc '()))
	(if (> r m)
	(length acc)
	(loop (+ 1 r)
	(if (coprime? r m)
	(cons r acc)
	acc)))))

view raw p34.ss hosted with ❤ by GitHub

Determine whether two positive integer numbers are coprime

	;; P33 (*) Determine whether two positive integer numbers are coprime.
	;; Two numbers are coprime if their greatest common divisor equals 1.
	;; Example:
	;; * (coprime 35 64)
	;; T
	#lang racket
	(provide coprime?)
	(define (coprime? a b)
	(= 1 (gcd a b)))

view raw p33.ss hosted with ❤ by GitHub

Determine the greatest common divisor of two positive integer numbers

	;; P32 (**) Determine the greatest common divisor of two positive integer numbers.
	;; Use Euclid's algorithm.
	;; Example:
	;; * (gcd 36 63)
	;; 9
	(define (gcd a b)
	(let loop ((x a) (y b) (z 1) (w 0))
	(let ((q (quotient x y)) (r (modulo x y)))
	(if (zero? r)
	y
	(loop y r w (- z (* q w)))))))

view raw p32.ss hosted with ❤ by GitHub

Determine whether a given integer number is prime

	;; P31 (**) Determine whether a given integer number is prime.
	;; Example:
	;; * (is-prime 7)
	;; T
	#lang racket
	(provide is-prime?)
	(define (is-prime? n)
	(and (> n 1)
	(or (= n 2)
	(and (not (zero? (modulo n 2)))
	(let loop ((i 3))
	(or (> (* i i) n)
	(and (not (zero? (modulo n i)))
	(loop (+ i 2)))))))))

view raw p31.ss hosted with ❤ by GitHub

Sorting a list of lists according to length of sublists

	;; P28 (**) Sorting a list of lists according to length of sublists
	;; a) We suppose that a list contains elements that are lists themselves. The objective is to sort the elements of this list according to their length. E.g. short lists first, longer lists later, or vice versa.
	;; Example:
	;; * (lsort '((a b c) (d e) (f g h) (d e) (i j k l) (m n) (o)))
	;; ((O) (D E) (D E) (M N) (A B C) (F G H) (I J K L))
	;; b) Again, we suppose that a list contains elements that are lists themselves. But this time the objective is to sort the elements of this list according to their length frequency; i.e., in the default, where sorting is done ascendingly, lists with rare lengths are placed first, others with a more frequent length come later.
	;; Example:
	;; * (lfsort '((a b c) (d e) (f g h) (d e) (i j k l) (m n) (o)))
	;; ((i j k l) (o) (a b c) (f g h) (d e) (d e) (m n))
	;; Note that in the above example, the first two lists in the result have length 4 and 1, both lengths appear just once. The third and forth list have length 3 which appears twice (there are two list of this length). And finally, the last three lists have length 2. This is the most frequent length.
	(define (lsort lst)
	(sort lst (lambda (x y)
	(< (length x) (length y)))))
	(define (lfmark lst)
	(let loop ((old lst) (acc '()))
	(if (null? old)
	(reverse acc)
	(let ((head (car old)))
	(loop (cdr old)
	(cons
	`(,(lfreq lst (length head))
	,head)
	acc))))))
	(define (lfunmark lst)
	(let loop ((lst lst) (acc '()))
	(if (null? lst)
	(reverse acc)
	(loop (cdr lst)
	(cons (second (car lst)) acc)))))
	(define (lfreq lst len)
	(let loop ((lst lst) (acc 0))
	(if (null? lst)
	acc
	(loop (cdr lst)
	(+ (if (= (length (car lst)) len)
	1
	0) acc)))))
	(define (lfsort lst)
	(let ((lst (lfmark lst)))
	(lfunmark (sort lst (lambda (x y)
	(< (car x) (car y)))))))

view raw p28.ss hosted with ❤ by GitHub

Group the elements of a set into disjoint subsets

	;; P27 (**) Group the elements of a set into disjoint subsets.
	;; a) In how many ways can a group of 9 people work in 3 disjoint subgroups of 2, 3 and 4 persons? Write a function that generates all the possibilities and returns them in a list.
	;; Example:
	;; * (group3 '(aldo beat carla david evi flip gary hugo ida))
	;; ( ( (ALDO BEAT) (CARLA DAVID EVI) (FLIP GARY HUGO IDA) )
	;; ... )
	;; b) Generalize the above predicate in a way that we can specify a list of group sizes and the predicate will return a list of groups.
	;; Example:
	;; * (group '(aldo beat carla david evi flip gary hugo ida) '(2 2 5))
	;; ( ( (ALDO BEAT) (CARLA DAVID) (EVI FLIP GARY HUGO IDA) )
	;; ... )
	;; Note that we do not want permutations of the group members; i.e. ((ALDO BEAT) ...) is the same solution as ((BEAT ALDO) ...). However, we make a difference between ((ALDO BEAT) (CARLA DAVID) ...) and ((CARLA DAVID) (ALDO BEAT) ...).
	;; You may find more about this combinatorial problem in a good book on discrete mathematics under the term "multinomial coefficients".
	(require "p07.ss")
	(require "p26.ss")
	(define (remove-list old new)
	(if (null? new)
	old
	(remove-list (remove (car new) old) (cdr new))))
	(define (group-n num result old)
	(combination-aux
	result
	(combination num
	(remove-list old
	(flatten result)))))
	(define (group-n-aux num result lst)
	(let loop ((result result) (acc '()))
	(if (null? result)
	acc
	(let ((head (car result))
	(tail (cdr result)))
	(loop tail
	`(,@acc ,@(group-n num head lst)))))))
	(define (group3 lst)
	(group-n-aux 4
	(group-n-aux 3
	(group-n 2 '() lst)
	lst)
	lst))
	(define (group old new)
	(if (null? (cdr new))
	(group-n (car new) '() old)
	(let ((lst (reverse new)))
	(group-n-aux (car lst)
	(group old (reverse (cdr lst)))
	old))))

view raw p27.ss hosted with ❤ by GitHub

Generate the combinations of K distinct objects chosen from the N elements of a list

	;; P26 (**) Generate the combinations of K distinct objects chosen from the N elements of a list
	;; In how many ways can a committee of 3 be chosen from a group of 12 people? We all know that there are C(12,3) = 220 possibilities (C(N,K) denotes the well-known binomial coefficients). For pure mathematicians, this result may be great. But we want to really generate all the possibilities in a list.
	;; Example:
	;; * (combination 3 '(a b c d e f))
	;; ((A B C) (A B D) (A B E) ... )
	#lang racket
	(provide (all-defined-out))
	(require "p17.ss")
	(define (combination n lst)
	(let ((num (- n 1)))
	(let loop ((lst lst) (acc '()))
	(if (or (> num (length lst)) (< n 2))
	acc
	(let ((ls0 (split num lst))
	(ls1 (split-after num lst)))
	(loop (cdr lst)
	`(,@acc ,@(combination-aux ls0 ls1))))))))
	(define (combination-aux new old)
	(let loop ((lst old) (acc '()))
	(if (null? lst)
	acc
	(loop (cdr lst)
	`(,@acc (,@new ,(car lst)))))))

view raw p26.ss hosted with ❤ by GitHub

Generate a random permutation of the elements of a list

	;; P25 (*) Generate a random permutation of the elements of a list.
	;; Example:
	;; * (rnd-permu '(a b c d e f))
	;; (B A D C E F)
	;; Hint: Use the solution of problem P23.
	(require "p23.ss")
	(define (rnd-permu lst)
	(rnd-select lst (length lst)))

view raw p25.ss hosted with ❤ by GitHub

Lotto: Draw N different random numbers from the set 1..M

	;; P24 (*) Lotto: Draw N different random numbers from the set 1..M.
	;; The selected numbers shall be returned in a list.
	;; Example:
	;; * (lotto-select 6 49)
	;; (23 1 17 33 21 37)
	;; Hint: Combine the solutions of problems P22 and P23.
	(require "p22.ss")
	(require "p23.ss")
	(define (lotto-select num max-elm)
	(rnd-select (range 1 max-elm) num))

view raw p24.ss hosted with ❤ by GitHub

Extract a given number of randomly selected elements from a list

	;; P23 (**) Extract a given number of randomly selected elements from a list.
	;; The selected items shall be returned in a list.
	;; Example:
	;; * (rnd-select '(a b c d e f g h) 3)
	;; (E D A)
	;; Hint: Use the built-in random number generator and the result of problem P20.
	#lang racket
	(provide rnd-select)
	(require "p03.ss")
	(require "p20.ss")
	(define (rnd-select lst num)
	(let loop ((lst lst) (selected 0) (acc '()))
	(if (= num selected)
	(reverse acc)
	(let ((rand-pos (+ (random (length lst)) 1)))
	(loop (remove-at lst rand-pos)
	(+ selected 1)
	(cons (element-at lst rand-pos) acc))))))

view raw p23.ss hosted with ❤ by GitHub

Create a list containing all integers within a given range

	;; P22 (*) Create a list containing all integers within a given range.
	;; If first argument is smaller than second, produce a list in decreasing order.
	;; Example:
	;; * (range 4 9)
	;; (4 5 6 7 8 9)
	#lang racket
	(provide range)
	(define (range ini fin)
	(let ((proc (if (> ini fin) - +)))
	(let loop ((i ini) (acc '()))
	(let ((cia (cons i acc)))
	(if (= i fin)
	(reverse cia)
	(loop (proc i 1) cia))))))

view raw p22.ss hosted with ❤ by GitHub

Insert an element at a given position into a list

	;; P21 (*) Insert an element at a given position into a list.
	;; Example:
	;; * (insert-at 'alfa '(a b c d) 2)
	;; (A ALFA B C D)
	(define (insert-at elm lst pos)
	(let loop ((lst lst) (pos pos) (acc '()))
	(if (or (= pos 1) (null? lst))
	(append (reverse acc) (cons elm lst))
	(loop (cdr lst) (- pos 1) (cons (car lst) acc)))))

view raw p21.ss hosted with ❤ by GitHub

Remove the K'th element from a list

	;; P20 (*) Remove the K'th element from a list.
	;; Example:
	;; * (remove-at '(a b c d) 2)
	;; (A C D)
	#lang racket
	(provide remove-at)
	(define (remove-at lst pos)
	(let loop ((lst lst) (ini 1) (acc '()))
	(let ((tail (cdr lst)))
	(if (= pos ini)
	(append (reverse acc) tail)
	(loop tail (+ ini 1) (cons (car lst) acc))))))

view raw p20.ss hosted with ❤ by GitHub

Rotate a list N places to the left

	;; P19 (**) Rotate a list N places to the left.
	;; Examples:
	;; * (rotate '(a b c d e f g h) 3)
	;; (D E F G H A B C)
	;; * (rotate '(a b c d e f g h) -2)
	;; (G H A B C D E F)
	;; Hint: Use the predefined functions length and append, as well as the result of problem P17.
	(require "p17.ss")
	(define (rotate lst x)
	(define (proc arg)
	(if (negative? x)
	(reverse arg)
	arg))
	(let ((ls (split (proc lst) (abs x))))
	(let ((head (car ls)) (tail (cadr ls)))
	(proc (append tail head)))))

view raw p19.ss hosted with ❤ by GitHub

Extract a slice from a list

	;; P18 (**) Extract a slice from a list.
	;; Given two indices, I and K, the slice is the list containing the elements between the I'th and K'th element of the original list (both limits included). Start counting the elements with 1.
	;; Example:
	;; * (slice '(a b c d e f g h i k) 3 7)
	;; (C D E F G)
	(require srfi/1)
	(define (slice lst i k)
	(drop (take lst k) (- i 1)))

view raw p18.ss hosted with ❤ by GitHub

Split a list into two parts; the length of the first part is given

	;; P17 (*) Split a list into two parts; the length of the first part is given.
	;; Do not use any predefined predicates.
	;; Example:
	;; * (split '(a b c d e f g h i k) 3)
	;; ( (A B C) (D E F G H I K))
	#lang racket
	(provide (all-defined-out))
	(require srfi/1)
	(define (split pos lst)
	(take lst pos))
	(define (split-after pos lst)
	(drop lst pos))

view raw p17.ss hosted with ❤ by GitHub

Drop every N'th element from a list

	;; P16 (**) Drop every N'th element from a list.
	;; Example:
	;; * (drop '(a b c d e f g h i k) 3)
	;; (A B D E G H K)
	(define (drop lst x)
	(let loop ((lst lst) (i 1) (acc '()))
	(let ((revacc (reverse acc)))
	(if (null? lst)
	revacc
	(let ((tail (cdr lst)))
	(cond ((< (length lst) x)
	(append revacc tail))
	((= i x)
	(loop tail 1 acc))
	(else
	(loop tail (+ 1 i) (cons (car lst) acc)))))))))

view raw p16.ss hosted with ❤ by GitHub

Replicate the elements of a list a given number of times

	;; P15 (**) Replicate the elements of a list a given number of times.
	;; Example:
	;; * (repli '(a b c) 3)
	;; (A A A B B B C C C)
	(define (repli lst int)
	(let loop ((lst lst) (i int) (acc '()))
	(cond ((null? lst) (reverse acc))
	((< i 1) (loop (cdr lst) int acc))
	(else (loop lst (- i 1) (cons (car lst) acc))))))

view raw p15.ss hosted with ❤ by GitHub

Duplicate the elements of a list

	;; P14 (*) Duplicate the elements of a list.
	;; Example:
	;; * (dupli '(a b c c d))
	;; (A A B B C C C C D D)
	(define (dupli lst)
	(let loop ((lst lst) (acc '()))
	(if (null? lst)
	(reverse acc)
	(let ((head (car lst)))
	(loop (cdr lst)
	(append `(,head ,head) acc))))))

view raw p14.ss hosted with ❤ by GitHub

Run-length encoding of a list (direct solution)

	;; P13 (**) Run-length encoding of a list (direct solution).
	;; Implement the so-called run-length encoding data compression method directly. I.e. don't explicitly create the sublists containing the duplicates, as in problem P09, but only count them. As in problem P11, simplify the result list by replacing the singleton lists (1 X) by X.
	;; Example:
	;; * (encode-direct '(a a a a b c c a a d e e e e))
	;; ((4 A) B (2 C) (2 A) D (4 E))
	;; Basd on the implementation of Paul Graham's ANSI Common Lisp
	(define (encode-direct x)
	(if (pair? x)
	(compress (car x) 1 (cdr x))
	x))
	(define (compress elt n lst)
	(let loop ((elt elt) (n n) (lst lst) (acc '()))
	(let ((cna (cons (n-elts elt n) acc)))
	(if (null? lst)
	(reverse cna)
	(let ((next (car lst))
	(tail (cdr lst)))
	(if (eq? next elt)
	(loop elt (+ n 1) tail acc)
	(loop next 1 tail cna)))))))
	(define (n-elts elt n)
	(if (> n 1)
	`(,n ,elt)
	elt))

view raw p13.ss hosted with ❤ by GitHub

Decode a run-length encoded list

	;; P12 (**) Decode a run-length encoded list.
	;; Given a run-length code list generated as specified in problem P11. Construct its uncompressed version.
	(define (decode lst)
	(let loop ((lst lst) (acc '()))
	(if (null? lst)
	(reverse acc)
	(let ((head (car lst)))
	(loop (cdr lst) (append
	(if (pair? head)
	(decode-aux head)
	`(,head)) acc))))))
	(define (decode-aux lst)
	(let ((n (car lst)) (symb (cadr lst)))
	(let loop ((n n) (acc '()))
	(if (zero? n)
	acc
	(loop (- n 1) (cons symb acc))))))

view raw p12.ss hosted with ❤ by GitHub

Modified run-length encoding

	;; P11 (*) Modified run-length encoding.
	;; Modify the result of problem P10 in such a way that if an element has no duplicates it is simply copied into the result list. Only elements with duplicates are transferred as (N E) lists.
	;; Example:
	;; * (encode-modified '(a a a a b c c a a d e e e e))
	;; ((4 A) B (2 C) (2 A) D (4 E))
	(require srfi/1)
	(define (encode lst)
	(let loop ((lst lst) (acc '()))
	(if (null? lst)
	(reverse acc)
	(loop (strip lst)
	(cons
	(let ((head (car lst))
	(len (length (picks lst))))
	(if (= len 1)
	head
	`(,len ,head)))
	acc)))))
	(define-syntax define-encode-aux
	(syntax-rules ()
	((_ name proc)
	(define (name lst)
	(let ((head (car lst)))
	(proc (lambda (x)
	(eq? head x)) lst))))))
	;; Using a procedure, take-while, defined in SRFI-1
	(define-encode-aux picks take-while)
	;; Using a procedure, drop-while, defined in SRFI-1
	(define-encode-aux strip drop-while)

view raw p11.ss hosted with ❤ by GitHub

Run-length encoding of a list

	;; P10 (*) Run-length encoding of a list.
	;; Use the result of problem P09 to implement the so-called run-length encoding data compression method. Consecutive duplicates of elements are encoded as lists (N E) where N is the number of duplicates of the element E.
	;; Example:
	;; * (encode '(a a a a b c c a a d e e e e))
	;; ((4 A) (1 B) (2 C) (2 A) (1 D)(4 E))
	#lang racket
	(provide encode)
	(require srfi/1)
	(define (encode lst)
	(let loop ((lst lst) (acc '()))
	(if (null? lst)
	(reverse acc)
	(loop (strip lst)
	(cons
	`(,(length (picks lst)) ,(car lst))
	acc)))))
	(define-syntax define-encode-aux
	(syntax-rules ()
	((_ name proc)
	(define (name lst)
	(let ((head (car lst)))
	(proc (lambda (x)
	(eq? head x)) lst))))))
	;; Using a procedure, take-while, defined in SRFI-1
	(define-encode-aux picks take-while)
	;; Using a procedure, drop-while, defined in SRFI-1
	(define-encode-aux strip drop-while)

view raw p10.ss hosted with ❤ by GitHub

Pack consecutive duplicates of list elements into sublists

	;; P09 (**) Pack consecutive duplicates of list elements into sublists.
	;; If a list contains repeated elements they should be placed in separate sublists.
	;; Example:
	;; * (pack '(a a a a b c c a a d e e e e))
	;; ((A A A A) (B) (C C) (A A) (D) (E E E E))
	(require srfi/1)
	(define (pack lst)
	(let loop ((lst lst) (acc '()))
	(if (null? lst)
	(reverse acc)
	(loop (strip lst) (cons (picks lst) acc)))))
	(define-syntax define-pack-aux
	(syntax-rules ()
	((_ name proc)
	(define (name lst)
	(let ((head (car lst)))
	(proc (lambda (x)
	(eq? head x)) lst))))))
	;; Using a procedure, take-while, defined in SRFI-1
	(define-pack-aux picks take-while)
	;; Using a procedure, drop-while, defined in SRFI-1
	(define-pack-aux strip drop-while)

view raw p09.ss hosted with ❤ by GitHub

Eliminate consecutive duplicates of list elements

	;; P08 (**) Eliminate consecutive duplicates of list elements.
	;; If a list contains repeated elements they should be replaced with a single copy of the element. The order of the elements should not be changed.
	;; Example:
	;; * (compress '(a a a a b c c a a d e e e e))
	;; (A B C A D E)
	(define (compress lst)
	(if (null? lst)
	'()
	(let loop ((lst lst) (acc '()))
	(let ((head (car lst)) (tail (cdr lst)))
	(let ((cha (cons head acc)))
	(if (null? tail)
	(reverse cha)
	(loop tail (if (eq? head (car tail)) acc cha))))))))

view raw p08.ss hosted with ❤ by GitHub

Flatten a nested list structure

	;; P07 (**) Flatten a nested list structure.
	;; Transform a list, possibly holding lists as elements into a `flat' list by replacing each list with its elements (recursively).
	;; Example:
	;; * (my-flatten '(a (b (c d) e)))
	;; (A B C D E)
	;; Hint: Use the predefined functions list and append.
	(define (my-flatten lst)
	(if (null? lst)
	'()
	(let ((head (car lst)) (flat-tail (my-flatten (cdr lst))))
	(append ((if (pair? head) my-flatten list) head) flat-tail))))

view raw p07.ss hosted with ❤ by GitHub

Find out whether a list is a palindrome

	;; P06 (*) Find out whether a list is a palindrome.
	;; A palindrome can be read forward or backward; e.g. (x a m a x).
	(define (palin? lst)
	(equal? lst (reverse lst)))

view raw p06.ss hosted with ❤ by GitHub

Reverse a list

	;; P05 (*) Reverse a list.
	(define (reverses lst)
	(let loop ((lst lst ) (acc '()))
	(if (null? lst)
	acc
	(loop (cdr lst) (cons (car lst) acc)))))

view raw p05.ss hosted with ❤ by GitHub

Find the number of elements of a list

	;; P04 (*) Find the number of elements of a list.
	(define (longitude lst)
	(let loop ((lst lst) (acc 0))
	(if (null? lst)
	acc
	(loop (cdr lst) (+ 1 acc)))))

view raw p04.ss hosted with ❤ by GitHub

Find the K'th element of a list

	;; P03 (*) Find the K'th element of a list.
	;; The first element in the list is number 1.
	;; Example:
	;; * (element-at '(a b c d e) 3)
	;; C
	#lang racket
	(provide element-at)
	(define (element-at lst n)
	(list-ref lst (- n 1)))

view raw p03.ss hosted with ❤ by GitHub

Find the last but one box of a list

	;; P02 (*) Find the last but one box of a list.
	;; Example:
	;; * (my-but-last '(a b c d))
	;; (C D)
	(define (my-but-last lst)
	(let ((revlis (reverse lst)))
	(cond
	((null? revlis) '())
	((< (length revlis) 3) lst)
	(else `(,(cadr revlis) ,(car revlis))))))

view raw p02.ss hosted with ❤ by GitHub

Find the last box of a list

	;; P01 (*) Find the last box of a list.
	;; Example:
	;; * (my-last '(a b c d))
	;; (D)
	(define (my-last lst)
	(if (null? lst)
	'()
	(let ((tail (cdr lst)))
	(if (null? tail)
	lst
	(my-last tail)))))

view raw p01.ss hosted with ❤ by GitHub

Script-Fu

	(define (script-fu-duplicate-layer img layer)
	(let ((copy-layer (car (gimp-layer-copy layer TRUE))))
	(gimp-image-add-layer img copy-layer -1)
	(gimp-displays-flush)))
	(script-fu-register
	"script-fu-duplicate-layer"
	"Duplicate Layer..."
	"description"
	"name"
	"copyright"
	"date"
	"RGB*"
	SF-IMAGE "Image" 0
	SF-DRAWABLE "Drawable" 0)
	(script-fu-menu-register "script-fu-duplicate-layer"
	"<Image>/Filters/Test")

view raw duplicate.scm hosted with ❤ by GitHub

	(define (script-fu-create-new-image bg-color width height)
	(let ((img (car (gimp-image-new width height RGB))))
	(let ((layer (car (gimp-layer-new img width height RGB-IMAGE
	"Background" 100 NORMAL-MODE))))
	(gimp-context-push)
	(gimp-deawable-fill layer BG-IMAGE-FILL)
	(gimp-image-add-layer img layer -1)
	(gimp-context-pop)
	(gimp-display-new img)
	(gimp-displays-flush))))
	(script-fu-register
	"script-fu-create-new-image"
	"New Image..."
	"description"
	"name"
	"copyright"
	"date"
	""
	SF-COLOR "Background color" '(255 255 255)
	SF-ADJUSTMENT "Width" '(256 1 1024 1 10 0 1)
	SF-ADJUSTMENT "Height" '(256 1 1024 1 10 0 1))
	(script-fu-menu-register "script-fu-create-new-image"
	"<Image>/Filters/Test")

view raw create-new-image.scm hosted with ❤ by GitHub

	;; ドロップシャドウを作るスクリプト
	(define (script-fu-drop-shadow-text text size font bg-color text-color)
	(let ((img (car (gimp-image-new 256 256 RGB))))
	;; 前処理
	(gimp-image-undo-disable img)
	(gimp-context-push)
	;; テキストレイヤー作り
	(gimp-context-set-foreground text-color)
	(let ((text-layer (car (gimp-text-fontname img -1 0 0 text 20
	TRUE size PIXELS font))))
	;; 背景レイヤー作り
	(let ((width (car (gimp-drawable-width text-layer)))
	(height (car (gimp-drawable-height text-layer))))
	(gimp-image-resize img width height 0 0)
	(let ((bg-layer (car (gimp-layer-new img width height RGB-IMAGE
	"Background" 100 NORMAL-MODE))))
	(gimp-image-add-layer img bg-layer 1)
	(gimp-context-set-background bg-color)
	(gimp-edit-clear bg-layer)
	;; ドロップシャドウの作成
	(gimp-context0set-foreground '(0 0 0))
	(let ((shadow-layer (car (gimp-text-fontname img -1 0 0 text 20
	TRUE xize PIXELS font))))
	(gimp-channel-ops-offset shadow-layer FALSE OFFSET-TRANSPARENT 5 5)
	(gimp-channel-ops-offset text-layer FALSE OFFSET-TRANSPARENT -5 -5)
	(plug-in-gauss-iir2 1 img shadow-layer 20 20)
	(gimp-layer-set-opacity shadow-layer 75)
	;; 後処理
	(gimp-context-pop)
	(gimp-image-undo-enable img)
	(gimp-display-new img)
	(gimp-displays-flush)))))))
	;; スクリプトの登録
	(script-fu-register
	"script-fu-drop-shadow-text"
	"Drop Shadow Text..."
	"Create the drop shadow text"
	"Iccii <iccii@hotmail.com>"
	"iccii"
	"Jun, 2001/May, 2009"
	""
	SF-STRING "Text" "Script-Fu!"
	SF-ADJUSTMENT "Font size (pixels)" '(100 2 1000 1 10 0 1)
	SF-FONT "Font" "Dragonwick"
	SF-COLOR "Background color" '(255 255 255)
	SF-COLOR "Text color" '(223 8 8))
	(script-fu-menu-register "script-fu-drop-shadow-text"
	"<Image>/Filters/Test")

view raw drop-shadow-text.scm hosted with ❤ by GitHub

	(define (script-fu-all-inputs-box
	image drawable layer channel vectors color
	toggle value string filename dirname
	adjustment0 adjustment1 font pattern brush
	gradient option palette text enum display)
	;; (gimp-message "This is the input box test script!")
	(gimp-message (string-append
	"Image is " (number->string image) "\n"
	"Drawable is " (number->string drawable) "\n"
	"Layer is " (number->string layer) "\n"
	"Channel is " (number->string channel) "\n"
	"Vectors is " (number->string vectors) "\n"
	"Color is " "'(" (number->string (car color)) " "
	(number->string (cadr color)) " "
	(number->string (caddr color)) ")\n"
	"Toggle is " (if (equal? toggle TRUE) "TRUE\n" "FALSE\n")
	"Value is " (number->string value) "\"\n"
	"String is " "\"" string "\"\n"
	"Filename is " "\"" filename "\"\n"
	"Dirname is " "\"" dirname "\"\n"
	"Adjust0 is " (number->string adjustment0) "\n"
	"Adjust1 is " (number->string adjustment1) "\n"
	"Font is " "\"" font "\"\n"
	"Pattern is " "\"" pattern "\"\n"
	"Brush is " "'(" "\"" (list-ref brush 0) "\" "
	(number->string (list-ref brush 1)) " "
	(number->string (list-ref brush 2)) " "
	(number->string (list-ref brush 3)) ")\n"
	"Gradient is " "\"" gradient "\"\n"
	"Option is " (number->string option) "\n"
	"Palette is " "\"" palette "\"\n"
	"Text is " "\"" text "\"\n"
	"Enmu is " (number->string enum) "\n"
	"Display is " (number->string display)))
	)
	(script-fu-register
	"script-fu-all-inputs-box"
	"All Inputs Box..."
	"Show all inputs box"
	"Iccii <iccii@hotmail.com>"
	"Iccii"
	"Jun, 2001/May, 2009"
	""
	SF-IMAGE "SF-IMAGE" 0
	SF-DRAWABLE "SF-DRAWABLE" 0
	SF-LAYER "SF-LAYER" 0
	SF-CHANNEL "SF-CHANNEL" 0
	SF-VECTORS "SF-VECTORS" 0
	SF-COLOR "SF-COLOR" '(255 255 255)
	SF-TOGGLE "SF-TOGGLE" FALSE
	SF-VALUE "SF-VALUE" "10"
	SF-STRING "SF-STRING" "The Gimp"
	SF-FILENAME "SF-FILENAME" "/FILENAME"
	SF-DIRNAME "SF-DIRNAME" ""
	SF-ADJUSTMENT "SF-ADJUSTMENT 0" '(256 1 1024 1 10 0 0)
	SF-ADJUSTMENT "SF-ADJUSTMENT 1" '(256 1 1024 1 10 0 1)
	SF-FONT "SF-FONT" "Sans"
	SF-PATTERN "SF-PATTERN" "Leopard"
	SF-BRUSH "SF-BRUSH" '("Circle (15)" 1.0 20 0)
	SF-GRADIENT "SF-GRADIENT" "Blue Green"
	SF-OPTION "SF-OPTION" '("Option1" "Option2" "Option3")
	SF-PALETTE "SF-PALETTE" "Blues"
	SF-TEXT "SF-TEXT" "Try input \n any texts"
	SF-ENUM "SF-ENUM" '("GimpGradientType" "linear")
	SF-DISPLAY "SF-DISPLAY" 0
	)
	(script-fu-menu-register "script-fu-all-inputs-box"
	"<Image>/Filters/Test")

view raw all-inputs-box.scm hosted with ❤ by GitHub

	;; ドロップシャドウを追加するスクリプト
	(define (script-fu-layer-effect-drop-shadow
	img ; 画像
	layer ; ドロアブル (レイヤー)
	shadow-color ; 影の色
	blur-radius ; 影のぼかし半径
	opacity ; 影の不透明度
	x-offset ; 影の X オフセット
	y-offset ; 影の Y オフセット
	)
	(let ((width (car gimp-drawable-width layer))
	(height (car (gimp-drawable-height layer))))
	(let ((shadow-layer (car (gimp-layer-new img width height RGBA-IMAGE
	"Drop Shadow" opacity MULTIPLY-MODE))))
	(let ((shadow-mask (car (gimp-layer-create-mask shadow-layer BLACK-MASK))))
	;; 処理準備
	(gimp-image-undo-group-start img)
	(gimp-context-push)
	(gimp-image-add-layer img shadow-layer -1)
	(gimp-image-add-layer-mask img shadow-layer shadow-mask)
	;; シャドウレイヤーマスクの作成
	(gimp-context-set-background shadow-color)
	(gimp-drawabla-fill shadow-layer BG-IMAGE-FILL)
	(gimp-selection-layer-alpha layer)
	(gimp-edit-fill shadow-mask WHITE-IMAGE-FILL)
	(gimp-selection-none img)
	;; シャドウレイヤーマスクへの変更
	(gimp-context-set-background '(0 0 0))
	(gimp-channel-ops-offset shadow-mask FALSE OFFSET-BACKGROUND x-offset y-offset)
	(plug-in-gauss-iir2 1 img shadow-mask blur-radius blur-radius)
	;; 後処理
	(gimp-image-lower-layer img shadow-layer)
	(gimp-context-pop)
	(gimp-image-undo-group-end img)
	(gimp-displays-flush)))))
	(script-fu-register
	"script-fu-layer-effect-drop-shadow"
	"Drop Shadow..."
	"Create drop shadow on the layer with alpha"
	"iccii <iccii@hotmail.com"
	"iccii"
	"Aug, 2001/May, 2009"
	"RGBA"
	SF-IMAGE "Image" 0
	SF-DRAWABLE "Drawable" 0
	SF-COLOR "Shadow color" '(0 0 0)
	SF-ADJUSTMENT "Shadow blur radius" '(10 1 100 1 10 0 0)
	SF-ADJUSTMENT "Drop shadow opacity" '(75 0 100 1 10 0 0)
	SF-ADJUSTMENT "Shadow X offset" '(5 -100 100 1 10 0 1)
	SF-ADJUSTMENT "Shadow Y offset" '(5 -100 100 1 10 0 1))
	(script-fu-menu-register "script-fu-layer-effect-drop-shadow"
	"<Image>/Filters/Layer Effect")

view raw layer-effect-drop-shadow.scm hosted with ❤ by GitHub

	;; レイヤー光彩 (内側) スクリプト
	(define (script-fu-layer-effect-inner-glow
	img ; 画像
	layer ; ドロアブル (レイヤー)
	glow-color ; 光彩の色
	blur-radius ; 光彩のぼかし半径
	glow-radius ; 光彩の半径
	opacity ; 光彩の不透明度
	glow-type ; 光彩のタイプ (縁 or 内部)
	)
	(let ((width (car (gimp-drawable-width layer)))
	(height (car (gimp-drawable-height layer))))
	(let ((glow-layer (car (gimp-layer-new img width height RGBA-IMAGE
	"Inner Glow" opacity SCREEN-MODE))))
	(let ((glow-mask (car (gimp-layer-create-mask glow-layer WHITE-MASK))))
	;; 処理準備
	(gimp-image-undo-group-start img)
	(gimp-context-push)
	(gimp-image-add-layer img glow-layer -1)
	(gimp-image-add-layer-mask img glow-layer glow-mask)
	;; 光彩レイヤーマスクの作成
	(gimp-context-set-background glow-color)
	(gimp-drawable-fill glow-layer BG-IMAGE-FILL)
	(gimp-selection-layer-alpha layer)
	(gimp-selection-invert img)
	(gimp-selection-grow img glow-radius)
	(gimp-selection-invert img)
	(gimp-context-set-background '(0 0 0))
	(gimp-edit-fill glow-mask BG-IMAGE-FILL)
	(gimp-selection-none img)
	;; 光彩レイヤーマスクへの変更
	(plug-in-gauss-iir2 1 img glow-mask blur-radius blur-radius)
	(and (eqv? glow-type 1)
	(gimp-invert glow-mask))
	;; もう一度レイヤーマスクを作る
	(gimp-image-remove-layer-mask img glow-layer APPLY)
	(let ((glow-mask2 (car (gimp-layer-create-mask glow-layer BLACK-MASK))))
	(gimp-image-add-layer-mask img glow-layer glow-mask2)
	(gimp-selection-layer-alpha layer)
	(gimp-edit-fill glow-mask2 WHITE-IMAGE-FILL)
	(gimp-selection-none img)
	;; 後処理
	(gimp-context-pop)
	(gimp-image-undo-group-end img)
	(gimp-displays-flush))))))
	(script-fu-register
	"script-fu-layer-effect-inner-glow"
	"Inside Glow..."
	"Create inner glow on the layer with alpha"
	"Iccii <iccii@hotmail.com>"
	"Iccii"
	"Aug, 2001/May, 2009"
	"RGBA"
	SF-IMAGE "Image" 0
	SF-DRAWABLE "Drawable" 0
	SF-COLOR "Glow color" '(255 255 191)
	SF-ADJUSTMENT "Blur radius" '(10 1 100 1 10 0 0)
	SF-ADJUSTMENT "Glow radius" '(2 1 100 1 10 0 0)
	SF-ADJUSTMENT "Opacity" '(75 0 100 1 10 0 0)
	SF-OPTION "Glow type" '("Edge" "Inner")
	)
	(script-fu-menu-register "script-fu-layer-effect-inner-glow"
	"<Image>/Filters/Layer Effect")

view raw layer-effect-inner-grow.scm hosted with ❤ by GitHub

	;; レイヤー光彩 (外側) スクリプト
	(define (script-fu-layer-effect-outer-glow
	img ; 画像
	layer ; ドロアブル (レイヤー)
	glow-color ; 光彩の色
	blur-radius ; 光彩のぼかし半径
	glow-radius ; 光彩の半径
	opacity ; 光彩の不透明度
	)
	(let ((width (car (gimp-drawable-width layer)))
	(height (car (gimp-drawable-height layer))))
	(let ((glow-layer (car (gimp-layer-new img width height RGBA-IMAGE
	"Outer Glow" opacity SCREEN-MODE))))
	(let ((glow-mask (car (gimp-layer-create-mask glow-layer BLACK-MASK))))
	;; 処理準備
	(gimp-image-undo-group-start img)
	(gimp-context-push)
	(gimp-image-add-layer img glow-layer -1)
	(gimp-image-add-layer-mask img glow-layer glow-mask)
	;; 光彩レイヤーマスクの作成
	(gimp-context-set-background glow-color)
	(gimp-drawable-fill glow-layer BG-IMAGE-FILL)
	(gimp-selection-layer-alpha layer)
	(gimp-selection-grow img glow-radius)
	(gimp-edit-fill glow-mask WHITE-IMAGE-FILL)
	(gimp-selection-none img)
	;; 光彩レイヤーマスクへの変更
	(gimp-context-set-background '(0 0 0))
	(plug-in-gauss-iir2 1 img glow-mask blur-radius blur-radius)
	;; 後処理
	(gimp-image-lower-layer img glow-layer)
	(gimp-context-pop)
	(gimp-image-undo-group-end img)
	(gimp-displays-flush)))))
	(script-fu-register
	"script-fu-layer-effect-outer-glow"
	"Outer Glow..."
	"Create outer glow on the layer with alpha"
	"Iccii <iccii@hotmail.com>"
	"Iccii"
	"Aug, 2001/May, 2009"
	"RGBA"
	SF-IMAGE "Image" 0
	SF-DRAWABLE "Drawable" 0
	SF-COLOR "Glow color" '(255 255 191)
	SF-ADJUSTMENT "Blur radius" '(10 1 100 1 10 0 0)
	SF-ADJUSTMENT "Glow radius" '(2 1 100 1 10 0 0)
	SF-ADJUSTMENT "Opacity" '(75 0 100 1 10 0 0)
	)
	(script-fu-menu-register "script-fu-layer-effect-outer-glow"
	"<Image>/Filters/Layer Effect")

view raw layer-effect-outer-grow.scm hosted with ❤ by GitHub

	;; レイヤー光彩 (内側) スクリプト
	(define (script-fu-layer-effect-inner-glow
	img ; 画像
	layer ; ドロアブル (レイヤー)
	glow-color ; 光彩の色
	blur-radius ; 光彩のぼかし半径
	glow-radius ; 光彩の半径
	opacity ; 光彩の不透明度
	glow-type ; 光彩のタイプ (縁 or 内部)
	)
	(let ((width (car (gimp-drawable-width layer)))
	(height (car (gimp-drawable-height layer))))
	(let ((glow-layer (car (gimp-layer-new img width height RGBA-IMAGE
	"Inner Glow" opacity SCREEN-MODE))))
	(let ((glow-mask (car (gimp-layer-create-mask glow-layer WHITE-MASK))))
	;; 処理準備
	(gimp-image-undo-group-start img)
	(gimp-context-push)
	(gimp-image-add-layer img glow-layer -1)
	(gimp-image-add-layer-mask img glow-layer glow-mask)
	;; 光彩レイヤーマスクの作成
	(gimp-context-set-background glow-color)
	(gimp-drawable-fill glow-layer BG-IMAGE-FILL)
	(gimp-selection-layer-alpha layer)
	(gimp-selection-invert img)
	(gimp-selection-grow img glow-radius)
	(gimp-selection-invert img)
	(gimp-context-set-background '(0 0 0))
	(gimp-edit-fill glow-mask BG-IMAGE-FILL)
	(gimp-selection-none img)
	;; 光彩レイヤーマスクへの変更
	(plug-in-gauss-iir2 1 img glow-mask blur-radius blur-radius)
	(and (eqv? glow-type 1)
	(gimp-invert glow-mask))
	;; もう一度レイヤーマスクを作る
	(gimp-image-remove-layer-mask img glow-layer APPLY)
	(let ((glow-mask2 (car (gimp-layer-create-mask glow-layer BLACK-MASK))))
	(gimp-image-add-layer-mask img glow-layer glow-mask2)
	(gimp-selection-layer-alpha layer)
	(gimp-edit-fill glow-mask2 WHITE-IMAGE-FILL)
	(gimp-selection-none img)
	;; 後処理
	(gimp-context-pop)
	(gimp-image-undo-group-end img)
	(gimp-displays-flush))))))
	(script-fu-register
	"script-fu-layer-effect-inner-glow"
	"Inside Glow..."
	"Create inner glow on the layer with alpha"
	"Iccii <iccii@hotmail.com>"
	"Iccii"
	"Aug, 2001/May, 2009"
	"RGBA"
	SF-IMAGE "Image" 0
	SF-DRAWABLE "Drawable" 0
	SF-COLOR "Glow color" '(255 255 191)
	SF-ADJUSTMENT "Blur radius" '(10 1 100 1 10 0 0)
	SF-ADJUSTMENT "Glow radius" '(2 1 100 1 10 0 0)
	SF-ADJUSTMENT "Opacity" '(75 0 100 1 10 0 0)
	SF-OPTION "Glow type" '("Edge" "Inner")
	)
	(script-fu-menu-register "script-fu-layer-effect-inner-glow"
	"<Image>/Filters/Layer Effect")

view raw layer-effect-inner-grow.scm hosted with ❤ by GitHub

プロダクション・システム

	;; 前向き推論はつぎの3つのステップの繰り返しによって実現される
	;; Step1 照合(パターンマッチング)
	;; ルールベースの中のすべてのプロダクションルールの条件部とワー
	;; キングメモリーの内容とを照合し、実行可能なルールの集まり
	;; を探す。実行可能なルールがなければ終了する。
	;; Step2 競合の解消
	;; 実行可能なルールの集まりの中から実際に実行するルールを1
	;; つ選択する。以下の例ではユーザーがこれを行う。
	;; Step3 動作
	;; 競合の解消によって選ばれたルールの結論部を実行する。これ
	;; によりワーキングメモリーの内容は更新される。
	;;;; プロダクションルールの実現
	(define (get-rulename rule) (car rule))
	(define (get-cond rule) (cadr rule))
	(define (get-action rule) (fourth rule))
	;;;; 推論エンジンの実現
	(define (forward-reasoning memory)
	;; Step-1 照合と Step-2 競合解消
	(let loop ((rule (choice (pattern-matching memory)))
	(memory memory))
	;; 実行可能なルールがなければ終了
	;; quit が入力されたら終了
	(if (or (null? rule) (eq? rule 'quit))
	'end
	(let ((memory (rule-action rule memory))) ;Step-3 動作
	(output-data memory) ;ワーキングメモリーの出力
	(loop (choice (pattern-matching memory))
	memory)))))
	;; ワーキングメモリの内容を出力する手続き
	(define (output-data memory)
	(printn " *working-memory* :" memory))
	;; すべての引数を印字したのち改行する手続き
	(define (printn . x)
	(for-each display x)
	(newline))
	;;;; 照合 : pattern-matching
	;;; pattern-matching は、ワーキングメモリーの内容 states とルールベー
	;;; ス *rule-base* から実行可能なルールの集まりを求める手続き
	;; PLT 実装依存の filter を使ったヴァージョン
	;; SRFI-1 を用いても良い
	(define (pattern-matching states)
	;; 全体が評価値
	(map get-rulename
	;; 偽ならそのルールをフィルタリングする
	(filter (lambda (candidate) ;対象とするルール
	(rule-cond? (get-cond candidate) states))
	*rule-base*)))
	;; プロダクションルールの条件部 conds がワーキ
	;; ングメモリー states に含まれているかどうかを
	;; 調べる手続き
	(define (rule-cond? conds states)
	(or (null? conds)
	(if (eq? (car conds) 'and) ;論理積であるか？
	(condition-aux? (cdr conds) states)
	(member conds states)))) ;単独の場合
	(define (condition-aux? conds states) ;論理積の場合
	(or (null? conds)
	(and (member (car conds) states)
	(condition-aux? (cdr conds) states))))
	;;;; 競合解消 : choice
	;; 選択されたルールのルール名を評価値とする
	(define (choice lst) ;lst は実行可能なルールの集まり
	(cond ((null? lst) '())
	(else
	(printn "enable rules : " lst)
	(display "enter rule-name >> ")
	(read)))) ;ルール名の読み込み
	;;;; 実行 : rule-action
	;; ルールの結論部を実行することで、ワーキングメモリーの内容 memory を
	;; 変更する手続き
	(define (rule-action r memory) ; r はルール名
	(let ((rule (get-rule r *rule-base*)))
	(if (null? rule)
	memory
	;; ルールの実行部を評価する
	(eval-action (get-action rule) memory))))
	;; ルール集合 rules の中のルール名 r の内容を評価値とする手
	;; 続き
	(define (get-rule r rules) ; rules はルール集合
	(if (null? rules)
	'() ; rules はルールベース
	(let ((rule (car rules)))
	(if (eq? (car rule) r) ;ルール名のチェック
	rule ;選択されたルール
	(get-rule r (cdr rules))))))
	;;;; ルールベースの表現
	(define *rule-base*
	'((rule1 (and (USA) (English)) --> (Honolulu))
	(rule2 (and (Europe) (France)) --> (Paris))
	(rule3 (and (USA) (Continent)) --> (LosAngels))
	(rule4 (and (Island) (Equator)) --> (Honolulu))
	(rule5 (and (Asia) (Equator)) --> (Singapore))
	(rule6 (and (Island) (Micronesia)) --> (Guam))
	(rule7 (Swimming) --> (Equator))))
	;;;; ワーキングメモリーの表現
	(define *working-memory* '((Island) (Swimming)))
	;;;; eval-action
	(define (eval-action action memory) ; action は実行される結論部
	(printn "action : " action) ;追加される結論部の表示
	(cons action memory)) ;結論部の追加 & memory の内容が評価値
	;; ;; 実行例
	;; > (forward-reasoning *working-memory*)
	;; enable rules : (rule7)
	;; enter rule-name >> rule7
	;; action : (Equator)
	;; *working-memory* :((Equator) (Island) (Swimming))
	;; enable rules : (rule4 rule7)
	;; enter rule-name >> rule4
	;; action : (Honolulu)
	;; *working-memory* :((Honolulu) (Equator) (Island) (Swimming))
	;; enable rules : (rule4 rule7)
	;; enter rule-name >> quit
	;; end
	;; >

view raw forward-reasoning.ss hosted with ❤ by GitHub

	;;;; ルールベースの表現
	;; ・もし、積木 x の上に何もないならば、x をテーブルの上に置く。こ
	;; れを (on x table) と表現する。
	;; ・もし、積木 x と y の上に何もないならば、 x を y の上に積む。こ
	;; れを (on x y) と表現する。
	(define *rule-base*
	'((rule1 (clear a) --> (on a table))
	(rule2 (clear b) --> (on b table))
	(rule3 (clear c) --> (on c table))
	(rule4 (and (clear a) (clear b)) --> (on a b))
	(rule5 (and (clear a) (clear c)) --> (on a c))
	(rule6 (and (clear b) (clear a)) --> (on b a))
	(rule7 (and (clear b) (clear c)) --> (on b c))
	(rule8 (and (clear c) (clear a)) --> (on c a))
	(rule9 (and (clear c) (clear b)) --> (on c b))))
	;;;; 積み木の世界の実行部
	;; (on x y) 形式で表現されている結論部を実行
	(define (eval-action rule memory) ; memory はワーキングメモリの内容
	(let ((act (car rule)))
	(if (eq? act 'on)
	(on (cadr rule) (third rule) memory) ; on の実行
	'())))
	;; 第1引数 x を第2引数 y の上に置く操作を実現
	(define (on x y memory)
	;; (clear y) を除き
	;; (on x y) になってたら (clear z) を加え、 (on x z) を除き
	;; (on x y) を加え評価値とする
	(cons `(on ,x ,y)
	(insert-clear x (remove-clear y memory))))
	;; (remove-clear 'c '((on a table) (on c a) (clear c)))
	;; ===> ((on a table) (on c a))
	(define (remove-clear foo lst)
	(let loop ((lst lst) (acc '()))
	(if (null? lst)
	(reverse acc)
	(let ((item (car lst))
	(state (caar lst))
	(block (cadar lst)))
	(loop (cdr lst)
	(if (and (eq? block foo) (eq? state 'clear))
	acc
	(cons item acc)))))))
	;; (insert-clear 'c '((on a table) (on c a) (clear c)))
	;; ===> ((on a table) (clear a) (clear c))
	(define (insert-clear foo lst)
	(let loop ((lst lst) (acc '()))
	(if (null? lst)
	(reverse acc)
	(let ((item (car lst))
	(state (caar lst))
	(block (cadar lst)))
	(loop (cdr lst)
	(call/cc
	(lambda (k)
	(cons
	(cond
	((not (and (eq? block foo) (eq? state 'on)))
	item)
	((eq? (caddr item) 'table)
	(k acc))
	(else
	`(clear ,(caddr item))))
	acc))))))))
	;;;; プロダクションルールの実現
	(define (get-rulename rule) (car rule))
	(define (get-cond rule) (cadr rule))
	(define (get-action rule) (fourth rule))
	;;;; 推論エンジンの実現
	(define (forward-reasoning memory)
	;; Step-1 照合と Step-2 競合解消
	(let loop ((rule (choice (pattern-matching memory)))
	(memory memory))
	;; 実行可能なルールがなければ終了
	;; quit が入力されたら終了
	(if (or (null? rule) (eq? rule 'quit))
	'end
	(let ((memory (rule-action rule memory))) ;Step-3 動作
	(output-data memory) ;ワーキングメモリーの出力
	(loop (choice (pattern-matching memory))
	memory)))))
	;; ワーキングメモリの内容を出力する手続き
	(define (output-data memory)
	(printn " *working-memory* :" memory))
	;; すべての引数を印字したのち改行する手続き
	(define (printn . x)
	(for-each display x)
	(newline))
	;;;; 照合 : pattern-matching
	;;; pattern-matching は、ワーキングメモリーの内容 states とルールベー
	;;; ス *rule-base* から実行可能なルールの集まりを求める手続き
	;; PLT 実装依存の filter を使ったヴァージョン
	;; SRFI-1 を用いても良い
	(define (pattern-matching states)
	;; 全体が評価値
	(map get-rulename
	;; 偽ならそのルールをフィルタリングする
	(filter (lambda (candidate) ;対象とするルール
	(rule-cond? (get-cond candidate) states))
	*rule-base*)))
	;; プロダクションルールの条件部 conds がワーキ
	;; ングメモリー states に含まれているかどうかを
	;; 調べる手続き
	(define (rule-cond? conds states)
	(or (null? conds)
	(if (eq? (car conds) 'and) ;論理積であるか？
	(condition-aux? (cdr conds) states)
	(member conds states)))) ;単独の場合
	(define (condition-aux? conds states) ;論理積の場合
	(or (null? conds)
	(and (member (car conds) states)
	(condition-aux? (cdr conds) states))))
	;;;; 競合解消 : choice
	;; 選択されたルールのルール名を評価値とする
	(define (choice lst) ;lst は実行可能なルールの集まり
	(cond ((null? lst) '())
	(else
	(printn "enable rules : " lst)
	(display "enter rule-name >> ")
	(read)))) ;ルール名の読み込み
	;;;; 実行 : rule-action
	;; ルールの結論部を実行することで、ワーキングメモリーの内容 memory を
	;; 変更する手続き
	(define (rule-action r memory) ; r はルール名
	(let ((rule (get-rule r *rule-base*)))
	(if (null? rule)
	memory
	;; ルールの実行部を評価する
	(eval-action (get-action rule) memory))))
	;; ルール集合 rules の中のルール名 r の内容を評価値とする手
	;; 続き
	(define (get-rule r rules) ; rules はルール集合
	(if (null? rules)
	'() ; rules はルールベース
	(let ((rule (car rules)))
	(if (eq? (car rule) r) ;ルール名のチェック
	rule ;選択されたルール
	(get-rule r (cdr rules))))))
	;; ;; 実行例
	;; > (define *working-memory*
	;; '((on a table) (clear b) (on b table) (on c a)
	;; (clear c)))
	;; > (forward-reasoning *working-memory*)
	;; enable rules : (rule2 rule3 rule7 rule9)
	;; enter rule-name >> rule3
	;; *working-memory* :((on c table) (on a table) (clear b) (on b table) (clear a) (clear c))
	;; enable rules : (rule1 rule2 rule3 rule4 rule5 rule6 rule7 rule8 rule9)
	;; enter rule-name >> rule7
	;; *working-memory* :((on b c) (on c table) (on a table) (clear b) (clear a))
	;; enable rules : (rule1 rule2 rule4 rule6)
	;; enter rule-name >> rule4
	;; *working-memory* :((on a b) (on b c) (on c table) (clear a))
	;; enable rules : (rule1)
	;; enter rule-name >> quit
	;; end
	;; >

view raw bricks.ss hosted with ❤ by GitHub

	;;;; ルールベースの表現
	(define *rule-base*
	'((rule1 (and (USA) (English)) --> (Honolulu))
	(rule2 (and (Europe) (France)) --> (Paris))
	(rule3 (and (USA) (Continent)) --> (LosAngels))
	(rule4 (and (Island) (Equator)) --> (Honolulu))
	(rule5 (and (Asia) (Equator)) --> (Singapore))
	(rule6 (and (Island) (Micronesia)) --> (Guam))
	(rule7 (Swimming) --> (Equator))))
	;;;; ワーキングメモリーの表現
	(define *working-memory* '((Honolulu)))
	;;;; 推論エンジンの実現
	;; Step1 照合
	;; 目標をルールの結論部として含むルールの集まりを探す。その
	;; ようなルールがなければ、仮定は否定されたとして終了する。
	;; Step2 競合の解消
	;; ルールの集まりの中からルールを1つ選択する。前向き推論と
	;; 同様に、ユーザーがこれを行うものとする。
	;; Step3 動作
	;; 選択されたルールの条件部への各要素がつぎの条件のいずれかを
	;; 満たしていれば、これらを新しい目標値とし、Step1 へと戻る。
	;; 1) 他のルールへの結論部として含まれている。
	;; 2) ユーザーへの問い合わせによって肯定された。
	;; これらの条件が満足されなければ、仮定は否定されたこととし
	;; て終了する。
	(define (backward-reasoning memory) ;目標を memory とする
	;; Step-1 最初の目標の照合と Step-2 競合解消
	(let loop ((rule (choice (pattern-matching-back memory)))
	(memory memory))
	;; 実行可能なルールがなければ終了
	;; quit が入力されたら終了
	(if (or (null? rule) (eq? rule 'quit))
	'end
	(let ((memory (rule-action-back rule))) ; Step-3 動作
	(output-data-back memory) ; 結果の出力
	(loop (choice (pattern-matching-back memory)) memory)))))
	;;; 仮定が成立しないときに、そのことを出力する手続き
	(define (output-data-back item)
	(and (null? item)
	(printn (caar *working-memory*)
	" is unsuitable for you.")))
	;; すべての引数を印字したのち改行する手続き
	(define (printn . x)
	(for-each display x)
	(newline))
	;;;; 競合解消 : choice
	;; 選択されたルールのルール名を評価値とする
	(define (choice lst) ;lst は実行可能なルールの集まり
	(cond ((null? lst) '())
	(else
	(printn "enable rules : " lst)
	(display "enter rule-name >> ")
	(read)))) ;ルール名の読み込み
	;;;; 照合 : pattern-matching-back
	;;; states で表される結論部をもつルールを
	;;; *rule-base* から探す手続き
	(define (pattern-matching-back states)
	;; 全体が評価値
	(map get-rulename ;以降が真ならそのルールを含める
	(filter (lambda (candidate) ;対象とするルール
	(rule-cond? (get-action candidate) states))
	*rule-base*)))
	;; プロダクションルールの条件部 conds がワーキ
	;; ングメモリー states に含まれているかどうかを
	;; 調べる手続き
	(define (rule-cond? conds states)
	(or (null? conds)
	(if (eq? (car conds) 'and) ;論理積であるか？
	(condition-aux? (cdr conds) states)
	(member conds states)))) ;単独の場合
	(define (condition-aux? conds states) ;論理積の場合
	(or (null? conds)
	(and (member (car conds) states)
	(condition-aux? (cdr conds) states))))
	;;;; プロダクションルールの実現
	(define (get-rulename rule) (car rule))
	(define (get-cond rule) (cadr rule))
	(define (get-action rule) (fourth rule))
	;;;; 実行 : rule-action-back
	;;; 選択されたルールの条件部が論理積の形式である
	;;; かどうかに応じて、 eval-action-back を呼び出し、
	;;; 新しい目標とすべき要素のリストを返す
	(define (rule-action-back r) ; r は選択されたルール名
	(let ((rule (get-rule r *rule-base*))) ;ルール r を取り出す
	(if (null? rule)
	'()
	(let ((items (get-cond rule)))
	(let ((item (car items)))
	(eval-action-back
	(if (eq? item 'and) ;論理積であるか?
	(cdr items) ;論理積の場合
	`(,items))
	'()))))))
	(define (eval-action-back items lst)
	(if (null? items)
	lst
	(let ((item (car items)))
	(let ((rules (pattern-matching-back `(,item))))
	(call/cc
	(lambda (k)
	(eval-action-back (cdr items)
	;; 条件部が他のルールの結論部に含まれている場合
	(if (or (pair? rules)
	;; あるいはユーザーに質問
	(eq? (question item) 'y))
	;; 論理積で記述されているならばつぎの条件の評価
	(cons item lst)
	(k '())))))))))
	(define (question lst)
	(and (pair? lst)
	(begin
	(printn "Do you feel satisfied next condition ?")
	(printn (car lst)) ;条件の表示
	(display "Please input 'y' or 'n' >> ")
	(read)))) ; y, n の読み込み
	;; ルール集合 rules の中のルール名 r の内容を評価値とする手
	;; 続き
	(define (get-rule r rules) ; rules はルール集合
	(if (null? rules)
	'() ; rules はルールベース
	(let ((rule (car rules)))
	(if (eq? (car rule) r) ;ルール名のチェック
	rule ;選択されたルール
	(get-rule r (cdr rules))))))
	;; ;; 実行例
	;; > (backward-reasoning *working-memory*)
	;; enable rules : (rule1 rule4)
	;; enter rule-name >> rule4
	;; Do you feel satisfied next condition ?
	;; Island
	;; Please input 'y' or 'n' >> y
	;; enable rules : (rule7)
	;; enter rule-name >> rule7
	;; Do you feel satisfied next condition ?
	;; Swimming
	;; Please input 'y' or 'n' >> y
	;; end
	;; >

view raw backward-reasoning.ss hosted with ❤ by GitHub

dot-emacs-example.el

Emacs Newbiesの為に.emacsの雛形を公開します。Emacs23以上対応です。

以前、UbuntuのEmacs22辺りまではUbuntu Japanese Team制作のdot.emacs.exampleが同梱されていたのですが、Emacs23からは完全UTF-8対応になった為か、無くなってしまいました。
そこで利便性を考え、オリジナル(GPLライセンス)のdot.emacs.exampleを改造したのが以下のdot-emacs-example.elです。

勝手に持って行って下さい(笑)。

	;;=======================================================================
	;; map-dir-list-into-load-path の定義
	;;=======================================================================
	;; rubikitch さん作のユーティリティ
	;; http://d.hatena.ne.jp/rubikitch/20090609/1244484272
	(defun add-to-load-path-recompile (dir)
	(add-to-list 'load-path dir)
	(let (save-abbrevs) (byte-recompile-directory dir)))
	(defun map-dir-list-into-load-path (dir-lst)
	(mapcar #'(lambda (x)
	(add-to-load-path-recompile
	(expand-file-name x)))
	dir-lst))
	;;
	;;=======================================================================
	;; パスを通す
	;;=======================================================================
	(defvar *dot-emacs-load-path-list*
	'("~/.emacs.d/auto-install"
	;; ここで文字列でパスを通したいディレクトリを指定する
	;; 例： "/i/want/to/make/a/path/to/the/directory"
	))
	(map-dir-list-into-load-path *dot-emacs-load-path-list*)
	;;
	;;=======================================================================
	;; dot-emacs-requirements-list
	;;=======================================================================
	(defvar *dot-emacs-requirements-list*
	'(cl
	session
	;; 必要な機能があったらここに書き込む
	;; 例： auto-install
	))
	(mapcar #'require *dot-emacs-requirements-list*)
	;;
	;;=======================================================================
	;; フレームサイズ
	;;=======================================================================
	(defvar *dot-emacs-frame-setting-list*
	'((width . 90) ; フレームの幅
	(height . 49) ; フレームの高さ
	(top . 0) ; Y 表示位置
	(left . 340) ; X 表示位置
	(alpha . (100 25)))) ; 透明度
	(loop for i in *dot-emacs-frame-setting-list*
	do (add-to-list 'initial-frame-alist i))
	(setf default-frame-alist initial-frame-alist)
	;;
	;;=======================================================================
	;; Misc
	;;=======================================================================
	(mouse-wheel-mode t) ;;ホイールマウス
	(global-font-lock-mode t) ;;文字の色つけ
	(setf line-number-mode t) ;;カーソルのある行番号を表示
	(auto-compression-mode t) ;;日本語infoの文字化け防止
	(set-scroll-bar-mode 'right) ;;スクロールバーを右に表示
	(global-set-key "\C-z" 'undo) ;;UNDO
	(setf frame-title-format ;;フレームのタイトル指定
	(concat "%b - emacs@" system-name))
	(display-time) ;;時計を表示
	;; (global-set-key "\C-h" 'backward-delete-char) ;;Ctrl-Hでバックスペース
	;; (setf make-backup-files nil) ;;バックアップファイルを作成しない
	;; (setf visible-bell t) ;;警告音を消す
	;; (setf kill-whole-line t) ;;カーソルが行頭にある場合も行全体を削除
	;; (when (boundp 'show-trailing-whitespace)
	;; (setq-default show-trailing-whitespace t)) ;;行末のスペースを強調表示
	;;
	;;=======================================================================
	;; 履歴の保存
	;;=======================================================================
	(add-hook 'after-init-hook 'session-initialize)
	;;
	;;=======================================================================
	;; 最近使ったファイル
	;;=======================================================================
	(recentf-mode)
	;;
	;;=======================================================================
	;; リージョンに色を付ける
	;;=======================================================================
	(setf transient-mark-mode t)
	;;
	;;=======================================================================
	;; 対応する括弧を光らせる
	;;=======================================================================
	(show-paren-mode)
	;;
	;;=======================================================================
	;; C-c c で compile コマンドを呼び出す
	;;=======================================================================
	(define-key mode-specific-map "c" 'compile)
	;;
	;;=======================================================================
	;; スクリプトを保存する時、自動的に chmod +x を行うようにする
	;;=======================================================================
	;; http://www.namazu.org/~tsuchiya/elisp/#chmod
	;; を参照
	(defun make-file-executable ()
	"Make the file of this buffer executable, when it is a script source."
	(save-restriction
	(widen)
	(if (string= "#!"
	(buffer-substring-no-properties 1
	(min 3 (point-max))))
	(let ((name (buffer-file-name)))
	(or (equal ?. (string-to-char
	(file-name-nondirectory name)))
	(let ((mode (file-modes name)))
	(set-file-modes name (logior mode (logand
	(/ mode 4) 73)))
	(message (concat "Wrote " name " (+x)"))))))))
	(add-hook 'after-save-hook 'make-file-executable)
	;;
	;;=======================================================================
	;; End of File
	;;=======================================================================

view raw dot-emacs-example.el hosted with ❤ by GitHub

vallog: syntax-rules: bind-variables

vallog: 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)
	;; >

view raw bind-variables.ss hosted with ❤ by GitHub

オリジナルのコードだとsyntax-errorっての使ってますが、これはR5RSで定義されていないので、errorに差し替えています。
もっとも、2番目のパターンだとそれじゃあ怒られたので、syntax-errorの挙動がしりたいトコなんですけどねえ。

いずれにせよ、省略子で書いた方がパターン的にはシンプルなのではないでしょうか。

!Lisp Ver.1.0

いや、最初は色々と

「LispによるLispの実装?んな、言語設計者になりたいわけでもねえのにメンド臭い。っつーかさ。それってハッキリ言うとComputer Scienceの極めてTrivialなネタなんじゃねえの?やってられっか。Computer Science学科に在籍した事もねえのに。バカヤロー。」

的な文句言ってたわけなんですが。気づいたらすっかりハマってました(爆)。いや、意外と面白いんだ、これが(笑)。

今回は2回目のLisp実装への挑戦、って事で日曜日辺りからやりはじめたのかな?今回参考にした書籍は対話によるCommon Lisp入門 POD版という本。最近、#9LISP用にLOLにかかりっきりで、それはそれで楽しいんですが、週末時間が足りなくってストレスが溜まってた。そこで気分転換にとか思ったんですが、色んな意味でドツボにハマってました(爆)。

前回のSmall-Lispの実装を通じて、

• クロージャの実装ってどうやんの?
  

とか言う疑問があって。その点対話によるCommon Lisp入門 POD版では曲りなりにもCommon Lispを実装しよう、と言うネタなんで。ああ、これは前回のSmall-Lispの実装をまた一段上に上げられるかな?とか楽観的に考えてたんですが。目論見が大失敗(爆)。完全に別の実装として考えないと整合性が持てない、という結論に到達致しました。だからまたVer.1.0なんですよね。

まあ、その失敗の理由も色々とあるわけですけれども。そもそも対話によるCommon Lisp入門 POD版と言う書籍名が示すように、これはCommon LispでCommon Lispを実装しましょう、ってネタなわけですよ。それをSchemeでやろうと言うのがそもそも大間違いだった(爆)。んで色んなトコでハマるハマる(笑)。

まあ、後で細かいトコの感想は列挙していこうとは思うんですけど。そもそも対話によるCommon Lisp入門 POD版では、CLOS(Common Lisp Object System)使ってCommon Lispの基本的な機能のみのサブセットを作りましょう、ってんですが。一方、僕は知ってる人は知ってますが大のオブジェクト指向嫌いなんですよ(笑)。やってられっか、とか思って。そこでプラットフォームだけの違いじゃなくってCLOSで書かれたコードをPLTの構造体を使って書き直す、というハメになってしまった。これがハマりまくった原因です(爆)。何やってんだろうねえ、全くもう。

ただ、やっぱりオブジェクト指向は怖いですよ。後でその理由もちょっと考察してみます。では、感想文モドキのメモ。

PLTの構造体は単一継承が出来る

PLTは独自の構造体を提供しています。R6RSにも準拠してないですし、またSRFIにも準拠していない、どちらかと言うとCommon Lispの構造体定義法に近いdefine-structというデータ定義用マクロを提供しています。

このブログでも紹介しましたし、こちらのブログでも紹介されていますが、define-structは大変使い易いです。っつーか、例によって、例えばR6RS構造体のベースになったSRFIで提案されている構造体定義のドキュメントがﾜｹﾜｶﾒで使う気にならん、って事もあるんですけど。一般にSchemeのドキュメントってあんま良くねえよな。読みづらくって。しかもレコード型とか言ってるのが気にくわん(笑)。Pascalじゃねえだろっての(笑)。Common Lispと違いを出せばいいってモンじゃねえ(笑)。

さて、このPLTの構造体。単一継承が可能です。親クラスっつーか親構造体っつーか。何て呼べばいいのか知りませんが、いずれにせよ、継承可能です。ただし。多重継承は出来ません。つまり一本のラインで連鎖しているデータ型が定義出来る。

まあ、元々CLOSで書かれたネタをdefine-structで解決出来るのか、というような興味がそもそもあったわけなんですけれども。元ネタの場合にも「これは無駄な継承なんじゃないか?」ってのがチラホラあって。全体的には納得してないんですよね(笑)。

今回の場合、根本的にはアイデンティティ(同一性)の判定、つまり根幹のeq判定の為にオブジェクトと言うルート構造体を作ってるわけです。IDナンバーを振り分ける為だけの。Common Lispだと、本当は、パッケージに属してるシンボルが指しているアドレスのポインタ比較でeqが成り立ってるわけなんですが、そこをIDナンバーを製造する為だけのオブジェクト型にすり替えています。要するに手抜きですよね(笑)。全ての構造体の実体には全く違うIDナンバーが振り分けられるシステムなんで、IDナンバーが違えば同一にはならない、というカラクリになっています。

このシステムから言うと、こいつ「だけ」を継承すれば良い筈なんですが、生憎対話によるCommon Lisp入門 POD版ではCLOS使いまくりでした(笑)。弊害は番組後半で(謎)。

マクロの使い方が間違っているけど(笑)、それでもmake-instanceは超便利だった

今回はたった一つだけmake-instanceという名前のマクロを作成しました。make-instanceなんて名前は丸っきりオブジェクト指向っぽいんですけどね。だったらはじめからオブジェクト指向で実装すりゃあいいのに(笑)。いやいや。

これの作成理由は二つあります。一つは対話によるCommon Lisp入門 POD版テキスト内のコードとの整合比較を簡単にする為。もう一つは最終的には全部「全く違うIDナンバー」を継承する必要性の為、IDナンバー込みで実体を自動作成したほうがラクだろ、ってのがあったんですよね。

さて、そんなワケで、今回のマクロmake-instanceは普通使い道が無いんじゃねえの?と思われているsyntax-rulesのキーワード引数が大活躍しています。ってかこれは使い方としては間違ってんだろうな(笑)。しかし、パターンマッチング型のsyntax-rulesだとこういう使い方もアリじゃねえのか、とは思うんですけどね(笑)。上手く行ったからまあエエか(笑)。CSの宿題のcond作成の為のelse突っ込む場所なだけ、ってのも勿体ねえからな(笑)。

マクロを大量に使う場合は、ソースコード上に置く位置に気を付けて

define-structもマクロです。make-instanceも作成したマクロです。

Schemeの場合、Common Lispみたいなあからさまなeval-whenに纏わるトラブルは起きませんが。その代わり、あるマクロを使用した手続きがある場合、マクロ定義をファイルの先の方に置いておくのは鉄則です。その辺はインタプリタっぽい「お約束」があるので気を付けましょう。これは実装提供のマクロでも注意が必要です。

Lispのリストは便利過ぎる

シーケンシャルアクセスであるリスト(C用語で言うと連結リスト?)は遅いし重い、って印象があるわけですよ。従って、実践主義者であるPeter Seibelなんかは「Common Lispは遅くない」という事を言いたいが為にわざと、著書実践Common Lispでは、戦略的にリストの説明をあとの方に置いています。「Lispはリストだけじゃないんだ!」と言う為に。

LispのLispたる所以はリスト操作の快適さ、なわけなんですけれども、反面「リストの為に」遅い、重い、という印象になってるわけです。

余談ですが、Common Lisp以前のLispでは、何と本当に関数が内部構造をリストとして表現されていたとの事。ぶっちゃけ、重そうなんですが、反面、関数定義式がすぐ見れると言う利点もあった。Common Lispでのシンボル型へのアクセサの一つ、symbol-functionってのは元々はこいつを引きずり出す為の関数だった模様です。そして当時の実装で有名だったマクロにppと言うものがあり、この内部定義での関数のリスト表現を清書印字してくれました。これも当時のsymbol-functionあっての機能だったんですね。

しかし、これじゃ重すぎるんで、Common Lispでは関数のリスト表現を止め、もっと低レベルへのコードへとコンパイルする道を選んだのです。全ては効率の為に。代わりに、Common Lispではdescribeやらfunction-lambda-expressionやらを仕様として要求するようになったんですが、かと言って、当然文書フォーマットまで仕様で定義されているわけじゃあありません。従って、これで「読める」詳細は実装次第だ、という事になります。昔のLispなら実際定義されているコードが眺められたわけですけれど、実際動いているコードがどういう風に書かれているのか、ソースを見なくても分かる、という利点は永久に失われてしまったのです。ああ。

何が言いたいのかというと。効率と表現力はトレードオフの関係にあるという事です。効率を優先すると表現力が落ち、表現力を優先すると効率が落ちる、という事です。どうやらこれは真理らしい。少なくともLispに於いては。

依然としてLispのリストは便利過ぎる。プログラミング言語をLispからマトモに触り始めた自分は特にそうなんですけど、リストがあれば他に何もいらねーやってくらい他のデータ型を必要としないんですね(笑)。何でもリストでやれるわけですし、極めて柔軟なリストを使うと、例えばランダムアクセスの配列とか使う気がしなくなってくる(笑)。まあ、それじゃいけないのは百も承知なんですが、でも便利。何でも突っ込めるしアクセス方法も簡単ですから。

まあ、そういうテイストの矯正の意味もあって、敢えてハッシュとか構造体とか使ってみよう、って課題があったんですけど。まず効率が増える度に自由度があからさまに減っていくんですよ(笑)。これは痛感しました。多分データ型の極北であるオブジェクト指向なんてのは僕から言わせれば不自由の極みですね(笑)。

一体何が起きてるのか?つまり、データ型には設計が必要なんです。リストは何も要らね(笑)。ところが、データ型の設計の際に個人個人の頭の中に「システムの全体像」がある。そこを簡単に他人が修正するわけにはいかない、って事なんです。もちろん自分で設計したもので自分が改良するのはラクですが、たとえ教科書と言おうと他人の褌で相撲を取るってのは至難の業。いや、もっと言うと他人のデータ設計でプログラムを改良するのは無理だ、と言う結論に到達しました。まあ、僕の力量不足もあるんですけどね。

これは前回のSmall-Lispなんかは、他人の設計でも「自由度の高い」リストで主に組み立てられていたからこそ、ちょこちょこと色んな僕なりのアイディアを試せたわけです。一方、今回は難攻不落のオブジェクト指向が元ネタです。誰かがデータ構造さえ決まればプログラムは自然と決まるとか言ったらしいんですが、逆に言うと、データ構造を変更すればプログラムの全体を手直ししなければならないという意味でしょう。データ構造の手直しはちょっとやそっとでは出来ないって事に他なりません。リスト弄りと次元の違う難しさになります。実際、色々と改良を試みましたがことごとく失敗致しました。

まあ、今回はテキスト準拠だ、って前提があるんでこれでもいいんですけど。ただし、自分で設計する場合、どんな言語を使おうと、最初のプロトタイプは効率が悪くてももっとも柔軟なデータ型で作れってのが鉄則のような気がします。どうせ書き直すんですから(笑)、純粋に自分のアタマの中にあるロジック「だけを」試せるデータ型を選んだ方が良いです。そして動かしてみて徹底的に利点、問題点を洗い出す。最初から効率的なデータ型を選ぶと恐らくドツボです。それは恐らく早すぎる最適化と呼ばれるものでしょう。

もう一回言いますが、効率は自由度とのトレードオフで得られるものだと言う事です。C言語なんかは自分で連結リストを実装しなければならないでしょうが、恐らくその方が遥かにマシな結果になるような気がします。気がするだけですが。

ちなみに、ポール・グレアムは次のような事を書いていました。

リストはとても柔軟なので、探検的プログラミングにおいて有用である。リストが何を正確に表現するかについて事前にコミットする必要はない。たとえば、平面上の点を表現するために二つの数のリストを使える。二つのフィールドxとyをもつ点オブジェクトを定義する方がより正しいと考える人がいるかもしれない。しかし、点を表現するためにリストを使うと、n次元を扱うようにプログラムを拡張するときに、行なう必要があるのは座標がない場合はゼロをデフォルトとする新たなコードを作ることだけであり、残りの平面に関するあらゆるコードは動作し続けるだろう。

あるいは、別の方向に拡張して部分的に評価された点を許すと決めた場合、点の成分として変数を表現するシンボルを使い始めることが可能であり、そしてまた、既存のコードは動作し続ける。

探検的プログラミングでは、早すぎる仕様を避けることは早すぎる最適化を避けることと同じくらい重要である。

ポール・グレアム

ポール・グレアムがArcを実装する際に数さえリストで表現しようとしてみたのは割に有名な話だと思うんですが、これも自由度を優先した実験だったのでしょう。ある意味今は、「効率化」はプログラミング言語の仕事であるより、ハードウェアの進歩の仕事になってきてますからね。

さて、いよいよ本題。色々とオブジェクト指向への文句を書いていきます(笑)。

CLOSはオーバースペック

CLOS(Common Lisp Object System)程賛否両論のオブジェクト指向システムもないでしょう。いや、賛否両論ってのはちょっと違うか。実はANSI Common Lispが一番最初に公式仕様としてオブジェクト指向が定義された言語である事に誰も異論は挟まないようですし、また、誰もがCLOSがANSI Common Lispの基盤を支えてる、ってのは分かっているらしい。

ただ、要するに、CLOSを積極的に使う派と全く使わない派に分かれているってのが面白いトコです。まあ、カッコいい言い方をすればマルチパラダイムを体現しているって事なんでしょうけれども。

ところで。何で対話によるCommon Lisp入門 POD版ではCLOSでCommon Lispのサブセット実装、と言うネタにしたんでしょうか?想像するにページ数が足りなかったんじゃねえの、って思ってるんですが(笑)。

同書ではCommon Lispでのデータ抽象の話->オブジェクト指向の話->Common Lisp実装、と速いペースで流れているわけですが、殆ど本の最後なんですよね(笑)。んで、どうせオブジェクト指向を紹介しているわけですし、ページ数も少ないんで、いっちょCLOSでも使ってサブセット実装してみせるか、と。ページ数が足りないんで。ここって大事ですよ。

つまり、制限がキツいページ数でどうにかマトモに動くシステムを作るにはオブジェクト指向って強力なんですよ(笑)。特にCLOSは桁違いのパワーを持っている。色んな意味で舌を巻きました。恐らく普通に説明して実装する流れだとあのページ数でここまで動かせないんじゃなかろうか、と。CLOSのパワーを感じた瞬間です。だからこそ問題があると思ったわけなんですけど。

なお、元々CLOSはSmalltalkと言う言語に影響を受けて誕生した模様で(この辺、Simulaの影響を受けたC++/Javaと対照的)、またルーツを鑑みれば分かるんですが、そもそもLispマシンでのGUIフロントエンドを作成する為に作られたシステムだった模様です。要するにザックリ言うと、ある種コンピュータ・グラフィックス専用のシステムなんです。従って、それに関しては多大な力を発揮するように作られていますが、同時に、文字処理ベースのシステムに対してはオーバースペックって言っても良いかもしれません。つまり、スタイル的に色々とおかしな問題がこのレベルでは出てくるんじゃないか、って思います。

CLOSではデータ追加は超簡単、反面読み解くのが難しい

対話によるCommon Lisp入門 POD版の流れから言うと。最初にIDナンバー特定の為のルートクラスとしてオブジェクトクラスを作成。その子クラスとしてアトムクラスとリストクラスを作成しています。そしてアトムクラスを継承してシンボルクラスを作成。そしてシンボルクラスとリストクラスを多重継承してLisp唯一無二のデータ型であるnullクラスを作成します。と言うのも、nilはCommon Lispではアトムでもあるしリストでもあるから、です。これにより、両者を継承しているnilクラスは自然とアトムにもなりリストにもなる。凄く軽快にデータ型をここまで追加していきます。オブジェクト指向って何て便利なんでしょう!!!…ん?

いや、これは変なんですよ。確かにLisp初心者にはアトムとリストは対になってる、と教えます。教えますが……。実はこれらは本当は対立していません。アトムと対立してるデータ型はリストじゃなくってコンスなんです。従って、この論法から言うとnullはシンボルを継承しても構いませんが、リストを継承する必要なんてない、のです。単にルート近辺の継承クラスにアトムとリストを設定したからおかしな事になる。

ここで言いたいのは、継承を有効活用する以上、データ型のヒエラルキーはキチンと設計しなければならないと言う当たり前の話です。当たり前の話なんですが……CLOSはあまりに強力過ぎて、多重継承があまりにも簡単に行えてしまう為にデータ構造の設計ミスをいとも簡単に隠蔽出来てしまう、のです。残るのはこんがらがったヒエラルキーとは呼べないデータ階層の残骸です。お互いリンクを貼りまくってわけが分からなくなる。

CLOSはかなり危険なシステムなんですよ。自重する分には構わないんでしょうが、あまりにも簡単にデータ型同士にリンクが貼れてしまう為に後に構造見直すには大変な思いをする事になるでしょう。実際、この階層をPLTの単一継承での構造体のリンクへと直すのに若干困りましたから。規模にも当然依るでしょうが、このレベルでこんがらがる、って事は大きなシステムだったらなおさらこんがらがるだろう、って事です。

オブジェクト指向は破壊的操作がいっぱい

まあ、これもスタイルの問題なんでしょうけどね〜。根本的にオブジェクト指向の場合、フィールド(あるいはスロットの値)を破壊的に書き換えるのが前提の為、Schemeが標榜する関数型プログラミングと真逆のトコに位置しています。いやあ、こんなにSchemeで破壊的操作ばっかしたの初めてかもしれない(笑)。もっと上手いテ使ってイミュータブルに仕上げられる可能性もあるんだろうけどな〜。CLOSが前提で書かれたテキストなんで、この辺、上手いテが思いつきませんでした。っつーか先程書いた通り、データ構造設計が決まれば自ずとプログラムが決まるなら、このヒエラルキーが決定された以上、逃げようがないんですけどね。いや、参った参った。

この実装だと中身は循環構造でいっぱい

んで破壊的操作を目論むと当然中には循環構造なんかが自ずとから出てくるわけですよ(笑)。代表的なのはシンボルnil。nilのsymbol-valueはnilなんですよね(笑)。これで如何にも簡単に循環構造の出来上がり、です。破壊的操作様々っつーか(笑)。ポインタが自分自身を指している(笑)。

あと、パッケージもひでえな。パッケージに登録されたnilは当然シンボルなんで、パッケージ内で循環してる、と言う(笑)。最初、構造体で#:transparent(透過設定)付けてたんですけど、あまりにリンクがヒドイんで、見たくなくなって止めました(笑)。ハズしちゃった(笑)。

これ、本物のCommon Lisp実装ってどうなってんだろうな〜。あんまCommon Lispじゃ表面的に循環構造出さないんで。興味があると言えばあるんですけど(SBCLでは*print-circle*弄っても特に循環してませんでしたけどね)。いや、こええこええ。最近のSchemeだとこう言う感じの構造を作るって推奨されてねえんじゃないですかい?

メソッドがあっちこっちに散らかりまくり

恐らく他のメジャーな言語でオブジェクト指向をやって、CLOSでビックリすんのは。メソッドがクラスに属してないって事なんじゃないですかね?普通、オブジェクト指向の単純な説明では「データ型と関数を一緒にしたもの」って解説されているわけですけれども。Common Lisp Object Systemではクラス内で特にメソッドを定義しない。じゃあ、どこがオブジェクト指向なの?となるわけです。

CLOSではメソッドは総称関数と呼ばれる特殊な関数に属しています。しかもこいつは暗黙で作られる(もちろん明示作成してもいいわけですけど)。従ってクラスでデータ型定義、メソッドはまた別に、ってなるわけです。んじゃ何かこのレベルでメリットがあるのか?と問われれば実際は何もないってのが本当のところで(笑)。

唯一目立ったトコですと

• defmethodとはクラス特有の関数が作れる事
  


• メソッドは表面的にはクラスに総称関数を通じて関連付けられているので場合分けする必要がない

ってトコでしょうか。平たく言うと同名異機能の関数が定義出来るって事になるんですけど……。う〜む。

例えば、対話によるCommon Lisp入門 POD版によるとだ。evalなんてのもメソッドとして定義されてるわけですよ。あるクラス専用のeval、別のクラス専用のeval、と。

そうなると、ソースコード上にあっちにエバるは、こっちにエバる、はものすごく散漫な印象になりますよね(笑)。どっかにまとめて置いた方がいいんじゃねえの?と。でも、どっかにまとめるんだったら最初からcondでも使って単一関数として定義しても同じなんじゃねえか、と言う(笑)。何じゃそりゃ(笑)。

まあ、多分、こういうシステムにしてるのは、それこそやっぱりコンピュータグラフィックス作成みたいな大規模システム向けだから、って事じゃないんですかね?まともに書いてて条件分けが20とか30とかになったらさすがに嫌だろ、って事で(笑)。だったら、そのテの条件分け自体が判定システムである総称関数に任せておいて、クラスの傍にメソッド置いときゃエエやん、と。多分元々の発想はそんなトコだったと思いますけど。

要するに、この程度の分量のソースコード量だとCLOSなんて出してもしゃーないって事でもあるんですよ。どの程度の規模のシステムから上がCLOSの領域になるのか、ってのはハッキリしませんが、いずれにせよ、この程度の分量で、あっちにメソッド、こっちにも同名のメソッドが分散してる、って感じじゃ単に邪魔なだけって気がします。古き良きcondを利用したほうがスッキリすると思います。

なお、PLTの構造体を使って場合分けする場合、継承が絡んでくるので、より特定的な派生データ型から条件を徐々に緩めていくような書き方をしないとなりません。最初の一番目の述語がルート構造体のモノだったりすれば派生構造体は全部#tになっちゃうんでおかしくなる。まあ、その辺総称関数だとある程度指定しつつも、自動で最も特定的なクラスに絡んだメソッドを選び出してくれる、ってんでラクってばラクなんですけど……。そもそもそんな事態に陥るのは継承なんて余計な事をしてるからじゃねえのかってのも事実であって(笑)。やれやれ(笑)。

ま、いずれにせよ、CLOSは大規模システム向けです。個人レベルだと使おうが使わまいがどーでもいい。っつーかこのレベルでは明らかに害悪なんじゃねーの、とか思います。

CLOSに付いては以上。終わり。

継続はやっつけ仕事のハックにも最適

クダラない話なんですが(笑)。対話によるCommon Lisp入門 POD版はあまりにも教科書的なREPLモデルを採用していて。これが一旦上部レイヤーのインタプリタ内部に入ると止められないんだ(笑)。端末クローズする以外手がない、っつーか(笑)。どうすんだろ、これ、みたいな感じで(笑)。他の人の話聞いてみたい(爆)。

重要なのは。このシステムだと、一旦READしたら即レイヤー上のLisp構文に変更しちゃうわけですよ。そのデータ変換ってのがこのテキスト上のCommon Lispのサブセットの肝なんですけど。一旦変換されたらexit命令もそのレイヤー内で実装しなければならない、って事になる。一体どうすんべえ、と。かなり困ってたんですね(笑)。

そこでやっつけ仕事。伝家の宝刀、Schemeのcall/ccの出番です。連続体(print (eval (read)))は切り離せないんで、READの返り値がある条件を満たした時、これらカッコの連続体から大域脱出しちゃう。これならちょっとの変更だけで、構造壊しませんしね。やっつけ仕事の際のcall/ccはマジで重宝しますよ(笑)。もう大好き(笑)。

マクロ実装はやっぱり今後の課題

かなりマクロ実装まで後一歩、ってトコまで来てる感じもするんですけどね〜。実際、内部定義してる時「これって形式的にはマクロだよな?」と思いまた、「マクロさえあればもっと簡単に定義出来るのに…」とほぞを噛む事もしばしば、でした。

Lisp系の本では、良く、マクロによるメタプログラミングの重要性が解かれています。ポール・グレアムは次のように言ってます。

マクロを書くというのは、Lispのプログラミングの中でも特別な手法であり、固有の目的と問題がある。コンパイラに渡る内容に変更を加えられるというのは、コンパイラを書き換えられるのとほとんど一緒である。したがって、マクロを書くときには、言語設計者のように考えながら始めなければならない。

ANSI Common Lisp (スタンダードテキスト)

ぶっちゃけ、

「何この人言ってんの?」

とか思ったわけですけど(笑)。メタプログラミングやるのにあたって、プログラマが言語設計者のように考えなければならない?言語設計した事もねえのにか(笑)。だったら無理だろ、と(笑)。

いや、その通りなんだと思います。プログラマにメタプログラミングは通常要らないんですよ。歌うたった事ないヤツに「歌手のように考えろ」とか、演技した事無いヤツに「俳優のように考えろ」ってのは土台無理な相談でしょ。プログラムした事ないヤツに「プログラマのように考えろ」ってのはメタファとしては成り立ちますが現実的な提案じゃありません。しかしマクロは現実に存在してて現実に関連しているわけですから、別な言い方するとやっぱり「言語設計した事が無いヤツが言語設計者のように考える」ってのは無理なんです。んな事ありえない。

という事はだ。この提案には次の二つの意味が考えられます。

1. 実はマクロ自体は言語設計者に取って一番便利な機能であって、ある意味プログラマの為のものではない。
   


2. マクロを理解するには実際にプログラミング言語を実装してみる必要がある。

この二つですよね。そして、これらはLispに於いてはかなり接近している、って意味なんです。つまり、Lispの力がマクロにあり、他の言語に比べるとLispのLispによる実装が簡単だとしたら……。試してみる価値がありますし、恐らく自分でLisp実装をしてみるのがマクロを理解する早道でしょう。そして実装した途端マクロが絶対欲しくなる。コア機能を定義した後のライブラリ的な意味じゃない「機能拡張」はマクロがあったほうが俄然ラクだから、です。

多分、この辺が、Lispのマクロに関しての他言語ユーザーの誤解の源なのかな、とはちょっと思いますね。その辺の言語でその言語自体を実装する事自体が凄く難しい。Lispは機能拡張可能な言語ですが、それは言語設計との境界線を曖昧にしている。それが故にLispに於ける「メタプログラミング」の重要性がピンと来なくなるんで、マクロ是非論、ってのが出てくるのかも。

もう一回言うと、マクロは言語設計者の為の機能でプログラマの為の機能ではない事は明らかです。ただし、Lispに於いてはプログラマと言語設計者の境界線は曖昧だって事です。という事は曲りなりにもLispを実装してみる価値はある。

多分プログラマ的観点でいてもつまるところマクロって理解出来ないような気がします。何となくですけど。で、Lispに於ける境界線が曖昧だったら跨いでもエエんちゃうの?ってのを最近感じ始めました。向こうの水は甘いぞ(笑)。

まあ、残念ながら、今のトコ、defmacroのプリミティヴとしての実装方法って分からないんですけどね。もうちょっとLisp実装を何回かやってみて、改めてArcのソースでも精読してみたいと思います。何かヒントがあるかも。

とまあ、これらが徒然と今回感じたもの、です。CLOSでのコードには腹立ちながらやってたんですが(笑)、曲りなりにもパッケージシステムの実装を通じて、Lisp-1でLisp-2が実装出来たんだ、ってのは感慨深いです。ちょっとレアケースかも、とか思っています。まあ、まだ色々と抜けもありますが、いずれにせよ、前回のSmall-Lispに比べても高機能になったんで良かったですね。苦労しただけの事はありました。

	#!/usr/bin/env bash
	mzscheme blisp.ss

view raw blisp hosted with ❤ by GitHub

	;; mzscheme blisp.ss
	#lang scheme
	(require "bang-lisp-ver.1.0.ss")
	(!lisp-load "blisp.blisp")
	(!lisp)

view raw blisp.ss hosted with ❤ by GitHub

	;; bang-lisp is a subset of Common Lisp implementation,
	;; based on the textbook, "対話によるCommon Lisp入門",
	;; published from 森北出版株式会社.
	;; # ISBN-10: 4627836090
	;; # ISBN-13: 978-4627836099
	;; Additionally, some library functions are imported from
	;; Appendix B of Paul Graham's "ANSI Common Lisp".
	;; # ISBN-10: 4894714337
	;; # ISBN-13: 978-4894714335
	;; Originally, "対話によるCommon Lisp入門" suggests to use
	;; CLOS, Common Lisp Object System, to implement the subset
	;; of Common Lisp; however, I do not like Object Oriented
	;; Programming style; in fact, I do try that by using PLT
	;; Scheme's define-struct. Therefore, this implementation
	;; heavily depends on PLT Scheme in order to convert some OOP
	;; idea to structures with some fun and ,also, headache.
	;; Thanks to PLT to provide such a great Scheme implementation,
	;; anyway.
	;; People may see the topic like Scheme implemented on Scheme or
	;; CL implemented on CL; however I think it must be rarely to see
	;; CL implemented on Scheme and vice versa. Thus, even though this
	;; is my personal lesson to understand Lisps more, it may be helpful
	;; for the people, studying to implement a Common Lisp subset on
	;; Scheme. It must be fun across Lisp-1 and Lisp-2, with PLT.
	;; By the way, most of ! mark on this source does not related to
	;; any destructive operations(some are yes, of course).
	;; The way of naming procedures here just relies on the text book,
	;; "対話によるCommon Lisp入門".
	(module bang-lisp-ver.1.0 scheme
	(provide (all-defined-out))
	;;; !Lisp 基本設定
	;; id の設定
	(define *new-id* 0)
	(define (new-id) (set! *new-id* (+ 1 *new-id*)) *new-id*)
	;; オブジェクトの生成
	(define-struct !object (id))
	;; 二つのオブジェクトの同値性判定
	(define (!eq? x y) (= (!object-id x) (!object-id y)))
	;;; 構造体によるデータ抽象
	;; 構造体によるアトムの定義
	(define-struct (!atom !object) ()
	)
	;; 構造体によるコンスの定義
	(define-struct (!cons !object)
	(first rest)
	)
	;; 構造体による数値の定義
	(define-struct (!number !atom) (number)
	)
	;; 構造体による文字列の定義
	(define-struct (!string !atom) (string)
	)
	;; 構造体によるシンボルの定義
	(define-struct (!symbol !atom)
	(name value function plist package)
	#:mutable
	)
	;; 構造体による NULL の定義
	(define-struct (!null !symbol) ()
	)
	;;; 構造体によるパッケージの定義
	(define-struct (!package !atom)
	(name hash)
	)
	;;; 構造体による関数の定義
	(define-struct (!function !atom) ()
	)
	;; 構造体による特殊オペレータの定義
	(define-struct (!special !function)
	(code)
	)
	;; 構造体による funcallable の定義
	(define-struct (!funcallable !function) ()
	)
	;; 構造体によるプリミティヴの定義
	(define-struct (!primitive !funcallable)
	(code)
	)
	;; 構造体によるクロージャの定義
	(define-struct (!closure !funcallable)
	(body parameters environment)
	)
	;; make-instance で構造体によるデータ型の作成(ショートカット)
	(define-syntax make-instance
	(syntax-rules
	(!object !atom !cons !number !string
	!symbol !package !special !primitive !closure)
	((_ !object)
	(make-!object (new-id)))
	((_ !atom)
	(make-!atom (new-id)))
	((_ !cons x y)
	(make-!cons (new-id) x y))
	((_ !number number)
	(make-!number (new-id) number))
	((_ !string string)
	(make-!string (new-id) string))
	((_ !symbol name value function plist package)
	(make-!symbol (new-id)
	name value function plist package))
	((_ !package name hash)
	(make-!package (new-id)
	name hash))
	((_ !special code)
	(make-!special (new-id) code))
	((_ !primitive code)
	(make-!primitive (new-id) code))
	((_ !closure body parameters environment)
	(make-!closure (new-id) body parameters environment))))
	;;; データ変換
	;; !Lisp のデータから PLT Scheme 上のデータへの変換
	(define (!CL->plt !obj)
	(cond ((!cons? !obj)
	(cons (!CL->plt (!cons-first !obj))
	(let ((tail (!cons-rest !obj)))
	(if (!null? tail)
	'()
	(!CL->plt tail)))))
	((!symbol? !obj)
	(string->symbol (!CL->plt (!symbol-name !obj))))
	((!string? !obj)
	(!string-string !obj))
	((!number? !obj)
	(!number-number !obj))
	((!object? !obj)
	!obj)
	(else
	#f)))
	;; PLT Scheme のデータから !Lisp 上のデータへの変換
	(define (plt->!CL obj)
	(cond ((pair? obj)
	(!cons! (plt->!CL (car obj)) (plt->!CL (cdr obj))))
	((null? obj)
	!nil)
	((symbol? obj)
	(!intern! (plt->!CL (string-upcase (symbol->string obj)))))
	((string? obj)
	(make-instance !string obj))
	((number? obj)
	(make-instance !number obj))
	(else
	#f)))
	;;; 手続き
	;; !make-symbol! の定義
	(define (!make-symbol! !str !pac)
	(make-instance !symbol !str #f #f #f !pac))
	;; null!? の定義
	(define (null!? !obj)
	(!eq? !obj !nil))
	;; !intern! の定義
	(define (!intern! !str (!pac !*package*))
	(let ((str (!string-string !str))
	(hash (!package-hash !pac)))
	(let ((!sym (hash-ref hash str #f)))
	(or !sym
	(let ((!symbol (!make-symbol! !str !pac)))
	(hash-set! hash str !symbol)
	!symbol)))))
	;; コンスの定義
	(define (!cons! x y)
	(make-instance !cons x y))
	;; 引数を評価しない手続き
	(define (noeval-args! !args)
	(let loop ((!args !args) (acc '()))
	(if (null!? !args)
	(reverse acc)
	(loop (!cons-rest !args)
	(cons (!cons-first !args) acc)))))
	;; 引数を評価する手続き
	(define (eval-args! !args local)
	(let loop ((!args !args) (acc '()))
	(if (null!? !args)
	(reverse acc)
	(loop (!cons-rest !args)
	(cons (!eval! (!cons-first !args) local) acc)))))
	;; funcall の定義
	(define (!funcall! !obj . args)
	(cond
	((!closure? !obj)
	(!eval! (!closure-body !obj)
	(let ((h (!closure-environment !obj)))
	(for-each (lambda (key val)
	(hash-set! h key val))
	(!closure-parameters !obj)
	args)
	h)))
	((!primitive? !obj)
	(apply (!primitive-code !obj) args))
	(else
	#f)))
	;; function の定義
	(define (!function! local !obj)
	(cond
	((!cons? !obj)
	(make-instance !closure
	(!cons-first (!cons-rest (!cons-rest !obj)))
	(noeval-args! (!cons-first (!cons-rest !obj)))
	local))
	((!symbol? !obj)
	(!symbol-function !obj))
	(else
	#f)))
	;; 外部ライブラリのロード用手続き
	(define (!lisp-load filename)
	(letrec ((!load
	(lambda (p)
	(let ((x (read p)))
	(cond ((eof-object? x)
	(close-input-port p))
	(else
	(!eval! (plt->!CL x))
	(!load p)))))))
	(call-with-input-file filename !load)))
	;;; 大域変数
	;; 大域変数としてのパッケージの定義
	(define !*package*
	(make-instance !package
	(plt->!CL "!CL-USER")
	(make-hash)))
	;; 大域変数としての nil の定義
	(define !nil
	(make-!null (new-id)
	(plt->!CL "NIL")
	#f
	#f
	#f
	!*package*))
	(set-!symbol-value! !nil !nil)
	(set-!symbol-plist! !nil !nil)
	;; 大域変数としてのパッケージの定義
	(hash-set! (!package-hash !*package*) "NIL" !nil)
	;; 大域変数としての t の定義
	(define !t (plt->!CL 't))
	(set-!symbol-value! !t !t)
	;; 大域変数としての pi の定義
	(define !pi (plt->!CL 'pi))
	(set-!symbol-value! !pi (plt->!CL pi))
	;; 大域変数としての lambda の定義
	(define !lambda (plt->!CL 'lambda))
	;;; !Lisp 本体
	;; REPL
	(define *version* "!Lisp Ver.1.0\n")
	(define (!lisp)
	(call/cc
	(lambda (k)
	(define (repl)
	(print-prompt) (!print! (!eval! (!read! k))) (newline))
	(define (loop exp)
	(loop (repl)))
	(display *version*)
	(loop (repl)))))
	(define (print-prompt)
	(display (string-append
	(!CL->plt (!package-name !*package*))
	"> ")))
	(define (!read! k)
	(let ((exp (read)))
	(if (and (list? exp)
	(memq (car exp)
	'(bye quit end exit)))
	(k 'GOOD-BYE)
	(plt->!CL exp))))
	(define (!print! !obj)
	(write (!CL->plt !obj))
	!obj)
	;; eval
	(define (!eval! !obj (local (make-hasheq)))
	(cond
	((!cons? !obj)
	(!apply! (!cons-first !obj) (!cons-rest !obj) local))
	((!symbol? !obj)
	(let ((binding (hash-ref local !obj #f)))
	(or binding
	(!symbol-value !obj))))
	(else
	!obj)))
	;; apply
	(define (!apply! !obj !args local)
	(cond
	((!funcallable? !obj)
	(apply !funcall!
	(cons !obj (eval-args! !args local))))
	((!special? !obj)
	(apply (!special-code !obj)
	(cons local
	(noeval-args! !args))))
	((!symbol? !obj)
	(!apply! (!symbol-function !obj) !args local))
	(else
	#f)))
	;;; 特殊オペレータの定義
	;; quote の定義
	(define (!quote! local !a1) !a1)
	;; if の定義
	(define (!if! local !condition !then !else)
	(if (null!? (!eval! !condition local))
	(!eval! !else local)
	(!eval! !then local)))
	;; setq の定義
	(define (!setq! local !sym !form)
	(let ((!value (!eval! !form local))
	(binding (hash-ref local !sym #f)))
	(cond (binding
	(set! binding !value)
	!value)
	(else
	(set-!symbol-value! !sym !value)
	!value))))
	;; defun の定義
	(define (!defun! local !name !parameters !body)
	(set-!symbol-function! !name
	(make-instance !closure
	!body
	(noeval-args! !parameters)
	local))
	!name)
	;;; 基本関数の定義
	;; eq? の定義
	(define (!eq!? !x !y)
	(if (!eq? !x !y) !t !nil))
	;; null? の定義
	(define (!null!? !x) (!eq!? !x !nil))
	;; atom? の定義
	(define (!atom!? !x)
	(cond ((!atom? !x) !t)
	((!null? !x) !t)
	(else !nil)))
	;; list? の定義
	(define (!list!? !x)
	(cond ((!cons? !x) !t)
	((!null? !x) !t)
	(else !nil)))
	;; + の定義
	(define (!+! . list-of-!numbers)
	(plt->!CL (apply + (map !CL->plt list-of-!numbers))))
	;; - の定義
	(define (!-! . list-of-!numbers)
	(and (pair? list-of-!numbers)
	(plt->!CL (apply - (map !CL->plt list-of-!numbers)))))
	;; * の定義
	(define (!*! . list-of-!numbers)
	(plt->!CL (apply * (map !CL->plt list-of-!numbers))))
	;; / の定義
	(define (!/! . list-of-!numbers)
	(and (pair? list-of-!numbers)
	(plt->!CL (apply / (map !CL->plt list-of-!numbers)))))
	;; eval の定義
	(define (!eval*! !form) (!eval! !form (make-hasheq)))
	;; consp の定義
	(define (!cons!? !obj) (if (!cons? !obj) !t !nil))
	;; stringp の定義
	(define (!string!? !obj) (if (!string? !obj) !t !nil))
	;;; 各定義のインストール
	;; quote のインストール
	(set-!symbol-function! (plt->!CL 'quote)
	(make-instance !special !quote!))
	;; if のインストール
	(set-!symbol-function! (plt->!CL 'if)
	(make-instance !special !if!))
	;; setq のインストール
	(set-!symbol-function! (plt->!CL 'setq)
	(make-instance !special !setq!))
	;; eq のインストール
	(set-!symbol-function! (plt->!CL 'eq)
	(make-instance !primitive !eq!?))
	;; null のインストール
	(set-!symbol-function! (plt->!CL 'null)
	(make-instance !primitive !null!?))
	;; atom のインストール
	(set-!symbol-function! (plt->!CL 'atom)
	(make-instance !primitive !atom!?))
	;; listp のインストール
	(set-!symbol-function! (plt->!CL 'listp)
	(make-instance !primitive !list!?))
	;; + のインストール
	(set-!symbol-function! (plt->!CL '+)
	(make-instance !primitive !+!))
	;; - のインストール
	(set-!symbol-function! (plt->!CL '-)
	(make-instance !primitive !-!))
	;; * のインストール
	(set-!symbol-function! (plt->!CL '*)
	(make-instance !primitive !*!))
	;; / のインストール
	(set-!symbol-function! (plt->!CL '/)
	(make-instance !primitive !/!))
	;; first のインストール
	(set-!symbol-function! (plt->!CL 'first)
	(make-instance !primitive !cons-first))
	;; rest のインストール
	(set-!symbol-function! (plt->!CL 'rest)
	(make-instance !primitive !cons-rest))
	;; cons のインストール
	(set-!symbol-function! (plt->!CL 'cons)
	(make-instance !primitive !cons!))
	;; read のインストール
	(set-!symbol-function! (plt->!CL 'read)
	(make-instance !primitive !read!))
	;; print のインストール
	(set-!symbol-function! (plt->!CL 'print)
	(make-instance !primitive !print!))
	;; symbol-name のインストール
	(set-!symbol-function! (plt->!CL 'symbol-name)
	(make-instance !primitive !symbol-name))
	;; symbol-value のインストール
	(set-!symbol-function! (plt->!CL 'symbol-value)
	(make-instance !primitive !symbol-value))
	;; symbol-function のインストール
	(set-!symbol-function! (plt->!CL 'symbol-function)
	(make-instance !primitive !symbol-function))
	;; symbol-plist のインストール
	(set-!symbol-function! (plt->!CL 'symbol-plist)
	(make-instance !primitive !symbol-plist))
	;; symbol-package のインストール
	(set-!symbol-function! (plt->!CL 'symbol-package)
	(make-instance !primitive !symbol-package))
	;; funcall のインストール
	(set-!symbol-function! (plt->!CL 'funcall)
	(make-instance !primitive !funcall!))
	;; function のインストール
	(set-!symbol-function! (plt->!CL 'function)
	(make-instance !special !function!))
	;; defun のインストール
	(set-!symbol-function! (plt->!CL 'defun)
	(make-instance !special !defun!))
	;; eval のインストール
	(set-!symbol-function! (plt->!CL 'eval)
	(make-instance !primitive !eval*!))
	;; consp のインストール
	(set-!symbol-function! (plt->!CL 'consp)
	(make-instance !primitive !cons!?))
	;; stringp のインストール
	(set-!symbol-function! (plt->!CL 'stringp)
	(make-instance !primitive !string!?))
	)

view raw bang-lisp-ver.1.0.ss hosted with ❤ by GitHub

	(defun car (x)
	(first x))
	(defun cadr (x)
	(car (cdr x)))
	(defun cddr (x)
	(cdr (cdr x)))
	(defun cdr (x)
	(rest x))
	(defun copy-list-aux (x)
	(if (atom x)
	x
	(cons (car x)
	(copy-list-aux (cdr x)))))
	(defun copy-list (lst)
	(cons (car lst) (copy-list-aux (cdr lst))))
	(defun copy-tree (tr)
	(if (atom tr)
	tr
	(cons (copy-tree (car tree))
	(copy-tree (cdr tree)))))
	(defun identity (x)
	x)
	(defun mapcar (fn lst)
	(if (null lst)
	nil
	(cons (funcall fun (car lst))
	(mapcar fun (cdr lst)))))
	(defun not (x)
	(eq x nil))
	(defun pair (lst)
	(if (null lst)
	nil
	(cons (cons (car lst) (cadr lst))
	(pair (cddr lst)))))
	(defun second (x)
	(cadr x))
	(defun third (x)
	(car (cdr (cdr x))))
	(defun 1+ (x)
	(+ x 1))
	(defun 1- (x)
	(- x 1))

view raw blisp.blisp hosted with ❤ by GitHub

vallog: macro while

vallog: macro while

do マクロの使い方を覚えられないクラスタです。

なかなかこれが、Schemeでは再帰ばっか練習するんで、doは意識して練習しないとdo嫌いに成りかねません。
まあ、以前も言ったんですけど、スタイル的には実はdoはnamed-letの変種です。Common Lispの内部では再帰とは全く違う破壊的な計算を行ないますが、かと言って、スタイルだけに注目すれば、実はnamed-letとはそんなに違いがないのです。
僕の中では

1. 横に広がるnamed-let


2. 縦に伸びるdo

とか言ってました。意味分かんないっすね(笑)。まあ、変数束縛の位置が、って事なんですけれども。あと、doがフグみたいに見える、ってんでフグ構文とか呼んでたりしました(笑)。

doの一般形は次のようになっています。

	(do (( <<変数1>> <<初期値1>> <<ステップ1>>)
	...
	( <<変数m>> <<初期値m>> <<ステップm>>))
	(<<終了条件>> <<式>>...<<式>>)
	<<式1>>
	...
	<<式n>>)

view raw basic-of-do.lisp hosted with ❤ by GitHub

ね、フグみたいでしょ(笑)?



Schemeのnamed-letの一般形は次の通りです。

	(let name ((<<変数1>> <<初期値1>>) ... (<<変数m>> <<初期値m>>))
	(cond (<<終了条件>>
	<<式>> ... <<式>>)
	(else
	(name <<ステップ1>> ... <<ステップm>>))))

view raw named-let.scm hosted with ❤ by GitHub

つまり、基本的には変数、初期値、ステップの配置が違うだけ、です。doだとまとめて記述する。named-letだとそうじゃない、って事ですね。

どっちがどっちより便利、って事は基本無いわけなんですけれども。

	;; ファイルを読み込んで行数を表示する手続き(Scheme)
	(define (count-lines filename)
	(call-with-input-file filename
	(lambda (p)
	(let loop ((c (read-char p))
	(count 0))
	(cond ((eof-object? c) (close-input-port p) count)
	(else (loop (read-char p) (if (char=? c #\newline)
	(+ count 1)
	count))))))))
	(define (count-lines/do filename)
	(call-with-input-file filename
	(lambda (p)
	(do ((c (read-char p) (read-char p))
	(count 0 (if (char=? c #\newline)
	(+ count 1)
	count)))
	((eof-object? c) (close-input-port p) count)))))

view raw named-let-ve-do.scm hosted with ❤ by GitHub

ただ、個人的には、ここで言う副作用とは、例えば入出力であるとか、そう言うケースですが、副作用が関わる式、特に出力を実行しなければならない場合、doの方がよりシンプルに書ける場合が多いとは思います。named-letだと、スッキリ決まらないケースが多くて、そう言う場合、doの方がシックリくる場合が多いような気がします。

	;; ファイルを読み込んで表示して、行数を表示する手続き(Scheme)
	(define (print-and-count-lines filename)
	(call-with-input-file filename
	(lambda (p)
	(let loop ((c (read-char p))
	(count 0))
	(cond ((eof-object? c) (close-input-port p) count)
	(else (display c) ; 基本 begin に頼って形式的には汚くなる
	(loop (read-char p) (if (char=? c #\newline)
	(+ count 1)
	count))))))))
	(define (print-and-count-lines/do filename)
	(call-with-input-file filename
	(lambda (p)
	(do ((c (read-char p) (read-char p))
	(count 0 (if (char=? c #\newline)
	(+ count 1)
	count)))
	((eof-object? c) (close-input-port p) count)
	(display c))))) ;ボディに出力命令がサッと置ける

view raw named-let-vs-do-2.scm hosted with ❤ by GitHub

上の例はあまり良くないんですが、と言うのも、named-letはcondを使って暗黙のbeginで上手い具合にみっともなさを回避してるんですが、基本、named-letのシンプルさはぶち壊れてるんです(笑)。目立ちませんが(笑)。
反面、後者のdoヴァージョンは本体部に「計算以外の余計な作業」をまとめられます。これはシンプル過ぎる例なんですが、長く余計な作業がある、って事はままあるんです。そう言う時、さすがの再帰構文でもシンプルに書けなくなる。いや、構造はシンプルなんですが、コード自体は汚く見える場合があるんですよね。

いや、すまない。いい例が思いつかなかった(爆)。ただ、普段は再帰で構わないけど、いざとなったらdoの方がシンプルに書ける場合があるんだよ、って事です。はい。

注:いや、ホントに下手な例でゴメン。というのも、doに関して言っても、カウンター内で出来る事は全てやってしまうのがスタイル的には美しいんですが、それで悩むんだったら素直に再帰した方が良い、ってのが事実。要するに再帰での「引数内のカウンター処理だけじゃどうしようもない」部分が出てきた場合、doの出番だ、って言い方の方が正しいかも。

さて、valvallowさんの記事によると、どうやら「NILじゃない返り値が欲しい」との事。まあ、これは当然でしょうね。
ポール・グレアムが何でマクロで書いたwhileでNIL以外の返り値を返すようにしなかったのか?想像するに、二つ程理由が考えられて、マクロの導入章(第7章なのに!)の辺りなんで、あんまややこしい例じゃなくってシンプルな例にしたかった事。あとは破壊的変更が前提のマクロなんで、返り値を返すとマズイ、って事があったんでしょうね。

グレアムのwhileは次のようにしてみれば面白い結果が出てきます。

	CL-USER> (defmacro my-while (test &body body)
	`(do ()
	((not ,test))
	,@body))
	MY-WHILE
	CL-USER> (let ((i 0))
	(my-while (< i 10)
	(print i)
	(incf i)) ; (setf i (+ i 1)) と同じ
	i) ; i を返してみる
	0
	1
	2
	3
	4
	5
	6
	7
	8
	9
	10 ;何と i は 10 になってる!
	CL-USER>

view raw graham's-do-example.lisp hosted with ❤ by GitHub

whileの指定はi < 10の筈なのに、何とiは10になっています。つまり、返り値になるのはこのiになるのは自明でしょう。これはマズいです(笑)。恐らく返り値は9であって欲しい、ってのが皆願う事でしょうから。
だから破壊的変更が前提なら、返り値をNILでもしとけば良い。堅実な判断ですよね。

さて、それでは返り値を、Common Lispらしく最後に実行された値を返すように改造していきましょう。まずは、LOLでお馴染みでしょうが、関数lastとbutlastってのを使ってみます。

	CL-USER> (last '(0 1 2 3 4 5))
	(5)
	CL-USER> (butlast '(0 1 2 3 4 5))
	(0 1 2 3 4)
	CL-USER>

view raw last-and-butlast.lisp hosted with ❤ by GitHub

関数lastはリストの最後の値のリストを返し、関数butlastはリストの最後の要素を除いたリストを返します。今何でこれを使おうと思ったのか、と言う理由は、繰り返しが何回実行されようと、必要なのは計算の最後の作業結果だという事だからです。
例えば、上のvalvallowさんの例だと、欲しいのは式をして実行された(print i)と(incf i)全体じゃなくって、あくまで(incf i)だけ、なんです。言い換えるとbodyの最後の計算結果さえ分かっていれば良い、と言う事です。
すなわち、bodyを二つに分けちゃう。最後と、それ以外、です。

このアイディアで雛形は一応次の通りになります。

	(defmacro my-while% (test &body body)
	;; var の初期値は nil で、(last body) は do のボディの式が評価されてから実行される
	`(do ((var nil ,@(last body)))
	((not, test) var)
	,@(butlast body))) ; body の最後尾以外の評価がボディの仕事

view raw my-while%.lisp hosted with ❤ by GitHub

では実行してみますか。

	CL-USER> (let ((i 0))
	(my-while% (< i 10)
	(print i)
	(incf i)))
	0
	1
	2
	3
	4
	5
	6
	7
	8
	9
	10 ; あれ!?やっぱり10になっている!
	CL-USER>

view raw evaluation-of-my-while%.lisp hosted with ❤ by GitHub

やっぱりダメだ(笑)!bodyを二つに分ける、ってアイディアは秀悦だとは思うんですが、返り値が10になってます。こりゃイカン。
この理由は、終了条件が調べられる前にvarが更新されちゃうから、なんです。つまり、テスト式に行く前にiが10になってしまう。ここを直さないとどーにもならん、わけです。
さて、ここでやっつけ仕事のハック。嫌でもvarが更新されちゃうんだったら、その前の状態を保存しとけばエエんちゃうの?ってのがアイディア。つまり、変数を二つ用意しちゃうんだ!!!一つは今まで通り(last body)の更新用。もうひとつは、前回のそれの保存用だ!これでどうだ。

	(defmacro my-while%% (test &body body)
	;; var0 の初期値は nil で、(last body) は do のボディの式が評価されてから実行される
	`(do ((var0 nil ,@(last body))
	;; var1 の初期値も nil で、更新値は「前回の」var0 の値
	(var1 nil var0))
	((not ,test) var1) ; 返り値は var1 になる
	,@(butlast body)))

view raw my-while%%.lisp hosted with ❤ by GitHub

では実行してみましょう。

	CL-USER> (let ((i 0))
	(my-while%% (< i 10)
	(print i)
	(incf i)))
	0
	1
	2
	3
	4
	5
	6
	7
	8
	9
	9 ; やった!返り値が 9 になった!
	CL-USER>

view raw evaluation-of-my-while%%.lisp hosted with ❤ by GitHub

上手く行きましたね。大成功！！！これで終わり……とはいかないんですよ、残念ながら(笑)。
実はこのマクロは次のような問題があるんです。

	CL-USER> (let ((var0 0))
	(my-while%% (< var0 10)
	(print var0)
	(incf var0)))
	; in: LAMBDA NIL
	; (LET ((VAR0 0))
	; (MY-WHILE%% (< VAR0 10) (PRINT VAR0) (INCF VAR0)))
	;
	; caught STYLE-WARNING:
	; The variable VAR0 is defined but never used.
	;
	; compilation unit finished
	; caught 1 STYLE-WARNING condition
	; Evaluation aborted.
	CL-USER> (let ((var1 0))
	(my-while%% (< var1 10)
	(print var1)
	(incf var1)))
	; in: LAMBDA NIL
	; (LET ((VAR1 0))
	; (MY-WHILE%% (< VAR1 10) (PRINT VAR1) (INCF VAR1)))
	;
	; caught STYLE-WARNING:
	; The variable VAR1 is defined but never used.
	;
	; compilation unit finished
	; caught 1 STYLE-WARNING condition
	; Evaluation aborted.
	CL-USER>

view raw error-of-my-while%%.lisp hosted with ❤ by GitHub

これが変数衝突ですね。つまり、my-while%%マクロの内部でvar0、var1って変数名を使ってるわけなんですけど、これが外部から与えられると途端にぶつかってしまってどうにもこうにも行かなくなる。
つまり、これを避けるのがgensymです。だから、こう書かないとなりません。

	(defmacro my-while (test &body body)
	;; テンプレートの外部で var0、var1 で gensym を束縛する
	(let ((var0 (gensym)) (var1 (gensym)))
	`(do ((,var0 nil ,@(last body))
	(,var1 nil ,var0))
	((not ,test) ,var1)
	,@(butlast body))))

view raw my-while.lisp hosted with ❤ by GitHub

これで安心してどんな変数名をmy-whileマクロ内に持たせても大丈夫です。

	CL-USER> (let ((i 0))
	(my-while (< i 10)
	(print i)
	(incf i)))
	0
	1
	2
	3
	4
	5
	6
	7
	8
	9
	9 ; 返り値は9!!!
	CL-USER> (let ((var0 0))
	(my-while (< var0 10)
	(print var0)
	(incf var0)))
	0
	1
	2
	3
	4
	5
	6
	7
	8
	9
	9 ; 多い日も安心!
	CL-USER> (let ((var1 0))
	(my-while (< var1 10)
	(print var1)
	(incf var1)))
	0
	1
	2
	3
	4
	5
	6
	7
	8
	9
	9 ; 横モレしない!
	CL-USER>

view raw evaluation-of-my-while.lisp hosted with ❤ by GitHub

gensymをいつ使うか?基本的にはいつでもです。意図してアナフォリックマクロを書く時以外はバンバン使って構わないと思います。あって困るもんじゃない。
基本的には、

• defmacroで引数として与えられた変数以外で、テンプレート内に「いきなり」現れる名前全部に対してgensymを使って構わない

と言うのが原則です。複雑なマクロでテンプレート内にバンバン新しい変数が現れる場合はgensymだらけになりますが、それで良い、のです。繰り返しますが、gensymはあって困るもんじゃない。むしろ無けりゃ困るんです。

まあ、もっともみっともなくなる可能性もありますが、その回避の為にOn Lispではwith-gensymsというコードが紹介されています。また、上のmy-whileはLOL流にdefmacro!を用いれば次のように記述されますね。

	(defmacro! my-while! (test &body body)
	`(do ((,g!var0 nil ,@(last body))
	(,g!var1 nil ,g!var0))
	((not ,test) ,g!var1)
	,@(butlast body)))

view raw my-while!.lisp hosted with ❤ by GitHub

ちなみに、再帰版は次のようになるでしょう。

	(defmacro my-while2 (test &body body)
	(let ((self (gensym)) (exp (gensym)) (acc (gensym)))
	`(labels
	((,self (,exp ,acc)
	(if (not, test)
	,acc
	(,self (progn ,@body) ,exp))))
	(,self (progn ,@body) nil))))
	(defmacro! my-while2! (test &body body)
	`(labels
	((,g!self (,g!exp ,g!acc)
	(if (not ,test)
	,g!acc
	(,g!self (progn ,@body) ,g!exp))))
	(,g!self (progn ,@body) nil)))

view raw recursive-my-whiles.lisp hosted with ❤ by GitHub

vallog: On Lisp memoize

vallog: On Lisp memoize

あああ、僕もうっかりしてました。

On Lispのmemoizeなんですけど。久々にGauche起動してValvallowさんに従って試してみたら、次のような結果になりました。

	gosh> (define (memoize fn)
	(let ((cache (make-hash-table 'equal?)))
	(lambda args
	(let ((val (hash-table-get cache args #f)))
	(if val val
	(hash-table-put! cache args (apply fn args)))))))
	memoize
	gosh> (define (fib n)
	(if (< n 2)
	1
	(+ (fib (- n 1))(fib (- n 2)))))
	fib
	gosh> (time (fib 35))
	;(time (fib 35))
	; real 2.451
	; user 2.450
	; sys 0.000
	14930352
	gosh> (time ((memoize fib) 35))
	;(time ((memoize fib) 35))
	; real 2.580
	; user 2.570
	; sys 0.000
	#<undef>
	gosh> (time ((memoize fib) 35))
	;(time ((memoize fib) 35))
	; real 2.438
	; user 2.430
	; sys 0.000
	#<undef>
	gosh>

view raw memoize-test.scm hosted with ❤ by GitHub

あれ、全然速くなっていない……。

考えてみれば当然で、手続きmemoizeは呼び出す度に新しくレキシカル環境を作ります。
と言う事は。cacheに保存される筈のハッシュテーブルは、手続きmemoizeが呼び出される度に新しくクロージャの中で作られて、そしてmemoizeの起動が終了する度にその寿命を全うするわけです。
従って、hash-table-getの返り値は毎度必ず#fになる、って事です。

これじゃあ意味無い。

んで、On Lispを良く見てみると、実は「敢えて」memoizeとそれが受け取る関数引数を合わせて大域環境に束縛しているんです。
これが手続きmemoizeの正しい使い方です。本に依ると、大域変数slowidに束縛されている以上、クロージャ、翻って使用されたハッシュテーブルが廃棄されません。

	gosh> (define slowid (memoize fib))
	slowid
	gosh> (time (slowid 35))
	;(time (slowid 35))
	; real 2.549
	; user 2.510
	; sys 0.000
	#<undef>
	gosh> (time (slowid 35))
	;(time (slowid 35))
	; real 0.000
	; user 0.000
	; sys 0.000
	14930352
	gosh>

view raw right-way-of-using-memoize.scm hosted with ❤ by GitHub

ご覧になれば分かるでしょうが、一回目の大域変数slowidに35を付けた時の呼び出しは遅いです。反面、クロージャ/ハッシュテーブルは依然と大域変数slowidに束縛されたまま、なんで、二回目の呼び出し時は高速なハッシュ検索により、時間が殆どかからず値を見つけ出している事が分かると思います。

これがmemoizeの使い方です。

Small-Lisp 実装を通して

感想文です。

まあ、前言った通り、

「Lispの実装をLispで行う？ネタ？それってオモロイのか？」

とか懐疑的だったんですけど。実際やってみると面白い(笑)。ハマりました(笑)。色んな意味ですけどね。

まあ、別に自分で0から考えて、ってわけじゃなくって、森北から出ているSchemeによる記号処理入門を見ながらやってたわけですけど。それで自分が気に入らないコーディングスタイルとか、あるいはこうだったら良いなあ、ってのを考えながら弄ってたわけですけれども。

でもマジに意外と面白かったです。ちょっとはSICPの第4章辺り読む自信付いたかな？

個人的には「こりゃ大変だ」とか思ったのがラムダ式(Small-Lispではfnと言う名前になってる)と=(Common Lispで言うsetf)の実装ですかね。あ、ifも大変だったな。中でもやっぱ一番大変だったのは=の実装ですかね。CLのsetfみたいな動作させたい、ってんで、CLでmacroexpandかけて調べてみたんですが、これが出てくるのがprimitiveであるrplacaとrplacdで。あんまこの二つ使った事が無いんで、Common Lisp 入門 (岩波コンピュータサイエンス)調べながら…と一番手間がかかりました。
結局、大域環境である*environment*をPLTのハッシュで実装してたんで、そこの内容をhash-set!で無理矢理書き換える、と。そう言う荒業を行って何とか解決。alistだったらこう上手くは行かなかったんだろうな。ハッシュテーブル様々です。

まあ、課題が多い実装なんですが。今思いつくトコをちょっとメモ。

1. ラムダ式のbodyに複数の式が置けない。


2. レキシカル・クロージャはどうやって実装する？


3. 一々quoteとか書きたくないんだけど、ショートカットである'の実装方法は？


4. マクロの実装方法は？

ってなトコですかね。
本の進み方によると、これはダイナミック・スコープにしかなり得ないと思うんで、そこの回避が謎ですね。まあ、この辺はSICP再挑戦して読んでみればわかるのかな？
quoteもみっともないですね。リーダマクロを実装すれば何とかなるのでしょうか。でもそこへ行くのが大変そう(笑)。
最後のマクロ実装。これは痛感しました。実は何を置いてもマクロを最初に実装しておくべきなのでは、と。
例えば、Small-Lispだとdefが特殊オペレータ扱いになってるんですよね。ところが、=とfnがあるんで、マクロさえあればその上に被せたレイヤー上に簡単に実装出来るわけです。マクロが無いからevalを直接弄って特殊オペレータとして実装しなきゃならない。これは無駄ですよね。
fnを実装している最中に「あ、これはマクロ書いてるっぽいな」とかちょっと思ったわけですけど、要するに直接evalを弄らずにショートカットできればいいのに。マクロは偉大です。自分でLispを実装してみるのがマクロ理解への一つの方策なのかもしれません。
が、マクロ実装を解説してあるような本ってあるんか(笑)。

その辺でcond実装するのも止めちゃったんだよね(笑)。マクロとifがあればcondなんてお茶の子さいさいで実装出来るのに。スカンタコ。

でもまあ、マジで面白いですよ。自分でプログラミング言語を曲りなりにも実装する、ってのは自信に繋がりますね。面白い。んで、ポール・グレアムのArcのコードも参考にしてたんですが、手探りでやってても色んな事が徐々に判ってくる。

ところで、CSの宿題で「LispでLispを実装しなきゃいけない」って言われて嫌々やってる人たちにちょっとヒントを。

applyとevalの仕事の区別なんて付けないで良い

いきなり怒られそうな事を書いてるんですけど(笑)。でも、やってみてここはそう思いました。
SICPなんかでは「Lispはevalとapplyの相互作用」とかエラソーな事書かれてたんですけど(笑)。実際、この辺は実装者のさじ加減でしょうね。
つまり、やりたけりゃ、特殊形式であるconsとか、特殊形式であるcarとかやってもいいわけです。「やっちゃいけない」ってワケじゃない。まあ、Lispのオーソドックスな実装上の流れから言ってevalとapplyに分けてる、って考えて良いでしょう。
一般には、次の役割がそれぞれあるわけですよ。

1. 特殊形式はeval内で実装する。


2. 基本関数はapply内で実装する。

これは要するに、REPLで打った時、引数にクオートが要らないのが前者、引数にクオートが必要になるのが後者、です。それだけ、なんです(笑)。マジな話で(笑)。
つまり、REPLで打った時に「引数いらねえ方が俺は好きだな」って場合は、堂々とeval内で実装しちゃいましょう(笑)。貴方のLispである以上、貴方の好みで良い筈です。それが例え「スチャラカな」実装だとしても。
実装形式上の話をすると、evalはexpressionを丸ごと一つとして受け取りますが、codeは分解された状態(function部とその引数部)でexpressionを受け取ります。このささいな違いがREPL上の引数の動作に影響を与える、のです。

メンド臭い実装はベースのLispに丸投げしちゃおう(笑)

これもそうですね。いくら「自分で実装する」とか言っても、基本的な関数で実装がメンド臭そうだったら、レイヤーの下で動いてるLispに丸投げするのも手、です。全部自分で造らなくても良い。もし、それが必要なら、アセンブリで実装する以上の事ってないわけですから。せっかくLispでLispを実装するんなら、余計な部分は下部で動いているLispに丸投げするのも手、です。恥ずかしがる必要はありません。
なお、ポール・グレアムのArcも読みながらやってたんですが、ポール・グレアムも面倒な部分は下部のPLTに丸投げしてました(笑)。Arcのソースコード内で逆引用符が使われているリストの部分は、どうやら下部のPLTに丸投げする為のハックの模様です。

caseを使いこなそう

どうも、あまりにもcondが優秀なのと、ミニマリズムのせいで、ついついSchemeでは存在が薄れがちなcaseですけど。ソースコードを短く、かつ、読みやすくする為にはcaseの多用が必要だ、と感じました。evalもapplyもコードが大きく成りかねないんで、それを避ける為には、

1. 手続きの分割


2. caseの多用

が肝です。
そもそも、Emacsの画面の半分以上を占めるようなコードを書くべきじゃない、と言う気がします。ショートカットになる為だったら色々と試してみるべきでしょう。同様に部分解が簡単に形成出来るんだったらdefine-syntax等のマクロも多用すべきだと思います。
Small-Lispだと、しょーもないマクロを3つ程作りましたが、それにより、コードの短縮化が可能になったんで、まあ良し、と思っています(もうちょっと上手く抽象化出来るかもしれない、って疑念もありますが)。

とまあ、感想文でした。
この続きはSICPに進むか、あるいはArcのソースをCLに移植するか。ちょっと楽しくなってきました。

Small-Lisp Ver.1.3

	#!/usr/bin/env bash
	mzscheme slisp.ss

view raw slisp hosted with ❤ by GitHub

	;; mzscheme slisp.ss
	#lang scheme
	(require "small-lisp-ver.1.3.ss")
	(slisp-load "slisp.slisp")
	(slisp)

view raw slisp.ss hosted with ❤ by GitHub

	;; Small-Lisp, based on the textbook "Schemeによる記号処理入門",
	;; implements now 15 Lisp functions such as null?, 1st, 2nd, 3rd, rst,
	;; cons, atom?, is?, +, -, *, /, >, < and fn as primitives.
	;; Version.1.3 has three special operators, if, = and def, which are all
	;; inspired by Paul Graham's Arc. = is setf of CL. def is defun of CL.
	;; Renamed some operators, because I like schemers' way better.
	;; Now Small-Lisp has a file-loading function, slisp-load, then it can
	;; load and evaluate some function-definition files, that define non-primitive
	;; functions defined in Small-Lisp style. "slisp.slisp" provides some functions
	;; such as car, cdr, cadr, caddr, last, append, length, and factorial, all built
	;; on Small-Lisp's primitives.
	;; Redefined some structures by using PLT's hashtables, instead
	;; of using a-lists; therefore, these codes here are heavily
	;; dependent on PLT Scheme.
	;; In addition, REPL is now more CL-like, and true/false is T/NIL, with upper-case.
	(module small-lisp-ver.1.3 scheme
	(provide (all-defined-out))
	;; (s-assoc 'a #hasheq((a . (1 2 3)) (b . 2))) ==> (1 2 3)
	(define (s-assoc x y)
	(hash-ref y x (lambda ()
	(error-message x)
	'())))
	(define (error-message x)
	(for-each display
	`(" **** Unknown expression : " ,x "\n")))
	;; eval 方面
	(define (atom? x)
	(not (pair? x)))
	(define (s-eval exp env)
	(if (atom? exp)
	(s-number? exp env)
	(let ((key (car exp)) (body (cdr exp)))
	(case key
	((if) (eval-if body env))
	((=) (eval-= body env))
	((def) (eval-def body env))
	((quote) (car body))
	(else (s-apply key
	(eval-args body env) env))))))
	;; (eval-args '(a b) #hasheq((a . 3) (b . 4))) ==> (3 4)
	(define (eval-args exp env)
	(map (lambda (x)
	(s-eval x env)) exp))
	(define-syntax s-assoc-helper
	(syntax-rules ()
	((_ exp env pred? proc)
	(let ((it (pred? exp)))
	(if it
	(s-assoc (not it) env)
	(proc exp))))))
	(define (s-number? exp env)
	(if (number? exp)
	exp
	(s-assoc exp env)))
	;; (define ht (make-hasheq))
	;; (hash-set! ht #t 'T)
	;; (hash-set! ht #f '())
	;; (hash-set! ht 'x '(1 2 3))
	;; (eval-if '((atom x) x (1st x)) ht) ==> 1
	;;
	(define (eval-if con env)
	(s-assoc-helper con env null?
	(lambda (x)
	(let ((head (car x)) (tail (cdr x)))
	(let ((eval-head (s-eval head env)))
	(cond ((null? tail) eval-head)
	((not (eq? '() eval-head)) (s-eval (car tail) env))
	(else (eval-if (cdr tail) env))))))))
	(define (eval-= exp env)
	(let ((head (car exp)) (val (s-eval (cadr exp) env)))
	(if (atom? head)
	(begin (hash-set! env head val) val)
	(let ((key (cadr head)))
	(let ((var (s-assoc key env)))
	(case (car head)
	((car) (hash-set! env key
	(cons val (cdr var)))
	(s-assoc key env))
	((cdr) (hash-set! env key
	(cons (car var)
	(if (pair? val)
	val
	`(,val))))
	(s-assoc key env))
	(else (error-message exp))))))))
	(define (eval-def exp env)
	(let ((name (car exp))
	(args (cadr exp))
	(body (third exp)))
	(hash-set! env name `(fn ,args ,body))
	name))
	;; apply 方面
	(define (s-null? foo env)
	(s-eval (null? foo) env))
	;; (s-atom? 4) ==> t
	(define (s-atom? foo env)
	(s-eval (not (pair? foo)) env))
	;; (s-is? 1 1) ==> t
	(define (s-is? foo bar env)
	(s-eval (eq? foo bar) env))
	(define-syntax operator-generator
	(syntax-rules ()
	((_ name foo bar acc pred? proc)
	(cond ((pred? foo)
	acc)
	((pred? bar)
	foo)
	(else
	(name (proc foo (car bar)) (cdr bar)))))))
	(define (s-+ foo bar)
	(operator-generator s-+ foo bar 0 null? +))
	(define (s-- foo bar)
	(operator-generator s-- foo bar 0 null? -))
	(define (s-* foo bar)
	(operator-generator s-* foo bar 1 null? *))
	(define (s-/ foo bar)
	(operator-generator s-/ foo bar 1 null? /))
	(define-syntax compare-helper
	(syntax-rules ()
	((_ name foo bar env pred? proc)
	(cond ((pred? foo)
	(error-message foo))
	((pred? bar)
	(s-assoc #t env))
	(else
	(let ((head (car bar)))
	(if (not (proc foo head))
	(s-assoc (proc foo head) env)
	(name head (cdr bar) env))))))))
	(define (s-> foo bar env)
	(compare-helper s-> foo bar env null? >))
	(define (s-< foo bar env)
	(compare-helper s-< foo bar env null? <))
	(define (s-apply func args env)
	(cond
	((null? func)
	(error-message args))
	((pair? func)
	(s-fn? func args env))
	(else
	(let ((head (s-assoc-helper args env null? car))
	(tail (s-assoc-helper args env null? cdr)))
	(let ((head-of-tail (s-assoc-helper tail env null? car)))
	;; 基本関数の処理
	(case func
	((null?) (s-null? head env))
	((1st) (s-assoc-helper head env null? car))
	((2nd) (s-assoc-helper head env (lambda (x) (< (length x) 2)) cadr))
	((3rd) (s-assoc-helper head env (lambda (x) (< (length x) 3)) caddr))
	((rst) (s-assoc-helper head env null? cdr))
	((cons) (cons head head-of-tail))
	((atom?) (s-atom? head env))
	((is?) (s-is? head head-of-tail env))
	((+) (s-+ head tail))
	((-) (s-- head tail))
	((*) (s-* head tail))
	((/) (s-/ head tail))
	((>) (s-> head tail env))
	((<) (s-< head tail env))
	;; 基本関数以外の関数に対する評価
	(else (s-apply (s-eval func env) args env))))))))
	;; lambda式の処理
	(define (s-fn? func args env)
	(if (eq? (car func) 'fn)
	(s-eval (third func)
	(pairlis->hash (cadr func) args env))
	(error-message args)))
	;; REPL
	;; プロンプトの表示とS式の読み込み
	(define (prompt)
	(begin (display "SL-USER> ")
	(read)))
	(define *version* "Small-Lisp Ver.1.3\n")
	(define (slisp)
	(define (loop exp)
	(if (and (list? exp) ;終了条件のチェック
	(memv (car exp)
	'(bye quit end exit)))
	'GOOD-BYE
	(let ((c (begin (display (null-environment? exp *environment*))
	(newline))))
	(loop (prompt)))))
	(display *version*)
	(init-environment) ;環境の初期設定
	(loop (prompt))) ;プロンプトの表示/S式の読み込み
	(define *environment* (make-hasheq)) ;大域変数の宣言
	(define (init-environment) ;環境の初期設定
	(hash-set! *environment* #t 't)
	(hash-set! *environment* #f '()))
	;; (define ht (make-hasheq))
	;; (hash-set! ht 'foo 3)
	;; (pairlis->hash '(i j k) '(a b c) ht) ==> #hasheq((foo . 3) (k . c) (j . b) (i . a))
	;; (define ht2 (make-hasheq))
	;; (pairlis->hash '(a b) '(1 2) ht2) ==> #hasheq((b . 2) (a . 1))
	;;
	(define (pairlis->hash x y z)
	(cond ((or (null? x) (null? y)) z)
	(else (hash-set! z (car x) (car y))
	(pairlis->hash (cdr x) (cdr y) z))))
	(define (null-environment? exp env)
	(let ((it (s-eval exp env)))
	(if (null? it)
	'NIL
	(capital-symbol it))))
	(define (capital-symbol exp)
	(cond ((symbol? exp)
	(string->symbol (string-upcase (symbol->string exp))))
	((list? exp)
	(map capital-symbol exp))
	(else
	exp)))
	;; 外部ライブラリのロード用手続き
	(define (slisp-load filename)
	(letrec ((s-load
	(lambda (p)
	(let ((x (read p)))
	(cond ((eof-object? x)
	(close-input-port p))
	(else
	(s-eval x *environment*)
	(s-load p)))))))
	(call-with-input-file filename s-load)))
	)

view raw small-lisp-ver.1.3.ss hosted with ❤ by GitHub

	;; basic Small-Lisp functions
	(def car (lst)
	(1st lst))
	(def cdr (lst)
	(rst lst))
	(def cadr (lst)
	(2nd lst))
	(def caddr (lst)
	(3rd lst))
	(def last (a)
	(if (null? (rst a))
	a
	(last (rst a))))
	(def append (x y)
	(if (null? x)
	y
	(cons (1st x) (append (rst x) y))))
	(def len (x)
	(len-aux x 0))
	(def len-aux (x acc)
	(if (null? x)
	acc
	(len-aux (rst x) (+ 1 acc))))
	(def factorial (x)
	(fact-aux x 1))
	(def fact-aux (x acc)
	(if (< x 1)
	acc
	(fact-aux (- x 1) (* x acc))))

view raw slisp.slisp hosted with ❤ by GitHub

Small-Lisp Ver.1.2

	#!/usr/bin/env bash
	mzscheme slisp.ss

view raw slisp hosted with ❤ by GitHub

	;; mzscheme slisp.ss
	#lang scheme
	(require "small-lisp-ver.1.2.ss")
	(slisp)

view raw slisp.ss hosted with ❤ by GitHub

	;; Small-Lisp, based on the textbook "Schemeによる記号処理入門",
	;; implements only 5 basic Lisp functions such as 1st, rst,
	;; cons, atom?, and is?. Also it has fn, the lambda expression
	;; as a primitive.
	;; Version.1.2 has three special operators, if, = and def, which are
	;; inspired by Paul Graham's Arc. = is setf of CL. def if defun of CL.
	;; Rename some operators, because I like schemers' way better.
	;; Redefined some structures by using PLT's hashtables, instead
	;; of using a-lists; therefore, these codes here are heavily
	;; dependent on PLT Scheme.
	;; In addition, REPL is now more CL-like, and true/false is T/NIL, with upper-case.
	(module small-lisp-ver.1.2 scheme
	(provide (all-defined-out))
	;; (s-assoc 'a #hasheq((a . (1 2 3)) (b . 2))) ==> (1 2 3)
	(define (s-assoc x y)
	(hash-ref y x (lambda ()
	(error-message x)
	'())))
	(define (error-message x)
	(for-each display
	`(" **** Unknown expression : " ,x "\n")))
	(define (atom? x)
	(not (pair? x)))
	(define (s-eval exp env)
	(cond ((atom? exp)
	(s-number? exp env))
	((eq? (car exp) 'if)
	(eval-if (cdr exp) env))
	((eq? (car exp) '=)
	(eval-= (cdr exp) env))
	((eq? (car exp) 'def)
	(eval-def (cdr exp) env))
	((eq? (car exp) 'quote)
	(cadr exp))
	(else (s-apply (car exp)
	(eval-args (cdr exp) env) env))))
	;; (eval-args '(a b) #hasheq((a . 3) (b . 4))) ==> (3 4)
	(define (eval-args exp env)
	(map (lambda (x)
	(s-eval x env)) exp))
	(define-syntax s-assoc-helper
	(syntax-rules ()
	((_ exp env proc)
	(let ((it (null? exp)))
	(if it
	(s-assoc (not it) env)
	(proc exp))))))
	(define (s-number? exp env)
	(if (number? exp)
	exp
	(s-assoc exp env)))
	;; (define ht (make-hasheq))
	;; (hash-set! ht #t 'T)
	;; (hash-set! ht #f '())
	;; (hash-set! ht 'x '(1 2 3))
	;; (eval-if '((atom x) x (1st x)) ht) ==> 1
	;;
	(define (eval-if con env)
	(s-assoc-helper con env
	(lambda (x)
	(let ((head (car x)) (tail (cdr x)))
	(let ((eval-head (s-eval head env)))
	(cond ((null? tail) eval-head)
	((not (eq? '() eval-head)) (s-eval (car tail) env))
	(else (eval-if (cdr tail) env))))))))
	(define (eval-= exp env)
	(let ((head (car exp)) (val (s-eval (cadr exp) env)))
	(if (atom? head)
	(begin (hash-set! env head val) val)
	(let ((key (cadr head)))
	(let ((var (s-assoc key env)))
	(case (car head)
	((car) (hash-set! env key
	(cons val (cdr var)))
	(s-assoc key env))
	((cdr) (hash-set! env key
	(cons (car var)
	(if (pair? val)
	val
	`(,val))))
	(s-assoc key env))
	(else (error-message exp))))))))
	(define (eval-def exp env)
	(let ((name (car exp))
	(args (cadr exp))
	(body (third exp)))
	(hash-set! env name `(fn ,args ,body))
	name))
	;; (s-atom? 4) ==> t
	(define (s-atom? foo env)
	(s-eval (not (pair? foo)) env))
	;; (s-is? 1 1) ==> t
	(define (s-is? foo bar env)
	(s-eval (eq? foo bar) env))
	(define (s-apply func args env)
	(cond
	((null? func)
	(error-message args))
	((pair? func)
	(s-fn? func args env))
	(else
	(let ((head (car args)) (tail (cdr args)))
	(let ((head-of-tail (s-assoc-helper tail env car)))
	;; 基本関数の処理
	(case func
	((1st) (s-assoc-helper head env car))
	((rst) (s-assoc-helper head env cdr))
	((cons) (cons head head-of-tail))
	((atom?) (s-atom? head env))
	((is?) (s-is? head head-of-tail env))
	;; 基本関数以外の関数に対する評価
	(else (s-apply (s-eval func env) args env))))))))
	;; lambda式の処理
	(define (s-fn? func args env)
	(if (eq? (car func) 'fn)
	(s-eval (third func)
	(pairlis->hash (cadr func) args env))
	(error-message args)))
	;; プロンプトの表示とS式の読み込み
	(define (prompt) (begin (display "SL-USER> ") (read)))
	(define *version* "Small-Lisp Ver.1.2\n")
	(define (slisp)
	(define (loop exp)
	(if (and (list? exp) ;終了条件のチェック
	(memv (car exp)
	'(bye quit end exit)))
	'GOOD-BYE
	(let ((c (begin (display (null-environment? exp *environment*))
	(newline))))
	(loop (prompt)))))
	(display *version*)
	(init-environment) ;環境の初期設定
	(loop (prompt))) ;プロンプトの表示/S式の読み込み
	(define *environment* (make-hasheq)) ;大域変数の宣言
	(define (init-environment) ;環境の初期設定
	(hash-set! *environment* #t 't)
	(hash-set! *environment* #f '()))
	;; (define ht (make-hasheq))
	;; (hash-set! ht 'foo 3)
	;; (pairlis->hash '(i j k) '(a b c) ht) ==> #hasheq((foo . 3) (k . c) (j . b) (i . a))
	;; (define ht2 (make-hasheq))
	;; (pairlis->hash '(a b) '(1 2) ht2) ==> #hasheq((b . 2) (a . 1))
	;;
	(define (pairlis->hash x y z)
	(cond ((or (null? x) (null? y)) z)
	(else (hash-set! z (car x) (car y))
	(pairlis->hash (cdr x) (cdr y) z))))
	(define (null-environment? exp env)
	(let ((it (s-eval exp env)))
	(if (null? it)
	'NIL
	(capital-symbol it))))
	(define (capital-symbol exp)
	(cond ((symbol? exp)
	(string->symbol (string-upcase (symbol->string exp))))
	((list? exp)
	(map capital-symbol exp))
	(else
	exp)))
	)

view raw small-lisp-ver.1.2.ss hosted with ❤ by GitHub

実行例:

	/home/cametan $ ./slisp
	Small-Lisp Ver.1.2
	SL-USER> (= x (quote (1 2 3)))
	(1 2 3)
	SL-USER> x
	(1 2 3)
	SL-USER> (rst x)
	(2 3)
	SL-USER> (cons (quote a) x)
	(A 1 2 3)
	SL-USER> x
	(1 2 3)
	SL-USER> (= (car x) (quote a))
	(A 2 3)
	SL-USER> (= (cdr x) (quote (b c)))
	(A B C)
	SL-USER> (def car (lst) (1st lst))
	CAR
	SL-USER> (car x)
	A
	SL-USER> (def 2nd (lst) (car (rst lst)))
	2ND
	SL-USER> (2nd x)
	B
	SL-USER> (2nd (quote ()))
	NIL
	SL-USER> (bye)
	GOOD-BYE
	/home/cametan $

view raw test.lisp hosted with ❤ by GitHub

Google 日本語入力 on Ubuntu 登場！ その名もMozc

もずくが美味しい季節がそろそろやってきますね。

待ち焦がれたGoogle日本語入力オープンソース版、その名もMozc。なかなか良いですよ。
ビルドが必要ですが、解説通りにやっておきゃまあOKです。
っつーか事実上、端末上へのコピペだよな（笑)。

解説は次のページで。

mozc

結構ビルドに時間かかるんですけどね。
Debian/Ubuntuユーザーは、Compilation飛ばして最後のBuild and install debian packageに飛んでください。CompilationはDebian/Ubuntuユーザー以外へのインストラクションなんで。

それと、多分、インストールしただけではiBusに認識されないと思います。認識させるには再起動かける必要があるのではないでしょうか。

Small-Lisp Ver.1.1

	#!/usr/bin/env bash
	mzscheme slisp.ss

view raw slisp hosted with ❤ by GitHub

	;; mzscheme slisp.ss
	#lang scheme
	(require "small-lisp-ver.1.1.ss")
	(slisp)

view raw slisp.ss hosted with ❤ by GitHub

	;; Small-Lisp, based on the textbook "Schemeによる記号処理入門",
	;; implements only 5 basic Lisp functions such as 1st, rst,
	;; cons, atom, and eq.
	;; Version.1.1 also implements a special operator if, which is
	;; inspired by if of Paul Graham's Arc, and fn, that is
	;; the lambda expression.
	;; Redefined some structures by using PLT's hashtables, instead
	;; of using a-lists; therefore, these codes here are heavily
	;; dependent on PLT Scheme.
	;; In addition, REPL is now more CL-like, and true/false is T/NIL, with upper-case.
	(module small-lisp-ver.1.1 scheme
	(provide (all-defined-out))
	;; (s-assoc 'a #hasheq((a . (1 2 3)) (b . 2))) ==> (1 2 3)
	(define (s-assoc x y)
	(hash-ref y x (lambda ()
	(error-message x)
	'())))
	(define (error-message x)
	(for-each display
	`(" **** Unknown expression : " ,x "\n")))
	(define (atom? x)
	(not (pair? x)))
	(define (s-eval exp env)
	(cond ((atom? exp)
	(s-number? exp env))
	((eq? (car exp) 'if)
	(eval-if (cdr exp) env))
	((eq? (car exp) 'quote)
	(cadr exp))
	(else (s-apply (car exp)
	(eval-args (cdr exp) env) env))))
	(define (s-number? exp env)
	(if (number? exp)
	exp
	(s-assoc exp env)))
	;; (eval-args '(a b) #hasheq((a . 3) (b . 4))) ==> (3 4)
	(define (eval-args exp env)
	(map (lambda (x)
	(s-eval x env)) exp))
	;; (s-atom? 4) ==> t
	(define (s-atom? foo env)
	(s-assoc (not (pair? foo)) env))
	;; (s-eq? 1 1) ==> t
	(define (s-eq? foo bar env)
	(s-assoc (eq? foo bar) env))
	(define-syntax s-assoc-helper
	(syntax-rules ()
	((_ exp env proc)
	(let ((it (null? exp)))
	(if it
	(s-assoc (not it) env)
	(proc exp))))))
	(define (s-apply func args env)
	(cond
	((null? func)
	(error-message args))
	((pair? func)
	(s-fn? func args env))
	(else
	(let ((head (car args)) (tail (cdr args)))
	(let ((head-of-tail (s-assoc-helper tail env car)))
	;; 基本関数の処理
	(case func
	((1st) (s-assoc-helper head env car))
	((rst) (s-assoc-helper head env cdr))
	((cons) (cons head head-of-tail))
	((atom) (s-atom? head env))
	((eq) (s-eq? head head-of-tail env))
	;; 基本関数以外の関数に対する評価
	(else (s-apply (s-eval func env) args env))))))))
	;; lambda式の処理
	(define (s-fn? func args env)
	(if (eq? (car func) 'fn)
	(s-eval (third func)
	(pairlis->hash (cadr func) args env))
	(error-message args)))
	;; プロンプトの表示とS式の読み込み
	(define (prompt) (begin (display "SL-USER> ") (read)))
	(define *version* "Small-Lisp Ver.1.1\n")
	(define (slisp)
	(define (loop exp)
	(if (and (list? exp) ;終了条件のチェック
	(memv (car exp)
	'(bye quit end exit)))
	'GOOD-BYE
	(let ((c (begin (display (s-eval exp *environment*))
	(newline))))
	(loop (prompt)))))
	(display *version*)
	(init-environment) ;環境の初期設定
	(loop (prompt))) ;プロンプトの表示/S式の読み込み
	(define *environment* (make-hasheq)) ;大域変数の宣言
	(define (init-environment) ;環境の初期設定
	(hash-set! *environment* #t 'T)
	(hash-set! *environment* #f 'NIL))
	;; (define ht (make-hasheq))
	;; (hash-set! ht 'foo 3)
	;; (pairlis->hash '(i j k) '(a b c) ht) ==> #hasheq((foo . 3) (k . c) (j . b) (i . a))
	;; (define ht2 (make-hasheq))
	;; (pairlis->hash '(a b) '(1 2) ht2) ==> #hasheq((b . 2) (a . 1))
	;;
	(define (pairlis->hash x y z)
	(cond ((or (null? x) (null? y)) z)
	(else (hash-set! z (car x) (car y))
	(pairlis->hash (cdr x) (cdr y) z))))
	;; (define ht (make-hasheq))
	;; (hash-set! ht #t 'T)
	;; (hash-set! ht #f 'NIL)
	;; (hash-set! ht 'x '(1 2 3))
	;; (eval-if '((atom x) x (1st x)) ht) ==> 1
	;;
	(define (eval-if con env)
	(s-assoc-helper con env
	(lambda (x)
	(let ((head (car x)) (tail (cdr x)))
	(let ((eval-head (s-eval head env)))
	(cond ((null? tail) eval-head)
	((not (eq? 'NIL eval-head)) (s-eval (car tail) env))
	(else (eval-if (cdr tail) env))))))))
	)

view raw small-lisp-ver.1.1.ss hosted with ❤ by GitHub

実行例:

	/home/cametan $ ./slisp
	Small-Lisp Ver.1.1
	SL-USER> ((fn (x) (if (atom x) x (rst x))) 100)
	100
	SL-USER> ((fn (x) (if (atom x) x (rst x))) (quote (1 2 3)))
	(2 3)
	SL-USER> (bye)
	GOOD-BYE
	/home/cametan $

view raw test.lisp hosted with ❤ by GitHub

Small-Lisp Ver.1.0

	#!/usr/bin/env bash
	mzscheme slisp.ss

view raw slisp hosted with ❤ by GitHub

	;; mzscheme slisp.ss
	#lang scheme
	(require "small-lisp-ver.1.0.ss")
	(slisp)

view raw slisp.ss hosted with ❤ by GitHub

	;; Small-Lisp, based on the textbook "Schemeによる記号処理入門",
	;; implements only 5 basic Lisp functions such as 1st, rst,
	;; cons, atom, and eq.
	;; Redefined some structures by using PLT's hashtables, instead
	;; of using a-lists; therefore, these codes here are heavily
	;; dependent on PLT Scheme.
	;; In addition, REPL is now more CL-like, and true/false is T/NIL, with upper-case.
	;; 1st and rst acts like CL; that is, (1st (quote ())) => NIL,
	;; and (rst (quote ())) => NIL
	(module small-lisp-ver.1.0 scheme
	(provide (all-defined-out))
	;; (s-assoc 'a #hasheq((a . (1 2 3)) (b . 2))) ==> (1 2 3)
	(define (s-assoc x y)
	(hash-ref y x (lambda ()
	(error-message x)
	'())))
	(define (error-message x)
	(for-each display
	`(" **** Unknown expression : " ,x "\n")))
	(define (atom? x)
	(not (pair? x)))
	(define (s-eval exp env)
	(cond ((atom? exp)
	(s-number? exp env))
	((eq? (car exp) 'quote)
	(cadr exp))
	(else (s-apply (car exp)
	(eval-args (cdr exp) env) env))))
	(define (s-number? exp env)
	(if (number? exp)
	exp
	(s-assoc exp env)))
	;; (eval-args '(a b) #hasheq((a . 3) (b . 4))) ==> (3 4)
	(define (eval-args exp env)
	(map (lambda (x)
	(s-eval x env)) exp))
	;; (s-atom? 4) ==> t
	(define (s-atom? foo env)
	(s-assoc (not (pair? foo)) env))
	;; (s-eq? 1 1) ==> t
	(define (s-eq? foo bar env)
	(s-assoc (eq? foo bar) env))
	(define-syntax s-assoc-helper
	(syntax-rules ()
	((_ proc exp env)
	(let ((it (null? exp)))
	(if it
	(s-assoc (not it) env)
	(proc exp))))))
	(define (s-apply func args env)
	(if (or (pair? func) (null? func))
	(error-message args)
	(let ((head (car args)) (tail (cdr args)))
	(let ((head-of-tail (s-assoc-helper car tail env)))
	;; 基本関数の処理
	(case func
	((1st) (s-assoc-helper car head env))
	((rst) (s-assoc-helper cdr head env))
	((cons) (cons head head-of-tail))
	((atom) (s-atom? head env))
	((eq) (s-eq? head head-of-tail env))
	;; 基本関数以外の関数に対する評価
	(else (s-apply (s-eval func env) args env)))))))
	;; プロンプトの表示とS式の読み込み
	(define (prompt) (begin (display "SL-USER> ") (read)))
	(define *version* "Small-Lisp Ver.1.0\n")
	(define (slisp)
	(define (loop exp)
	(if (and (list? exp) ;終了条件のチェック
	(memq (car exp)
	'(bye quit end exit)))
	'GOOD-BYE
	(let ((c (begin (display (s-eval exp *environment*))
	(newline))))
	(loop (prompt)))))
	(display *version*)
	(init-environment) ;環境の初期設定
	(loop (prompt))) ;プロンプトの表示/S式の読み込み
	(define *environment* (make-hasheq)) ;大域変数の宣言
	(define (init-environment) ;環境の初期設定
	(hash-set! *environment* #t 'T)
	(hash-set! *environment* #f 'NIL))
	)

view raw small-lisp-ver.1.0.ss hosted with ❤ by GitHub

実行例:

	cametan-laptop% ./slisp
	Small-Lisp Ver.1.0
	SL-USER> 1
	1
	SL-USER> (1st (quote (foo baz)))
	foo
	SL-USER> (rst (quote (foo baz)))
	(baz)
	SL-USER> (eq (quote (foo baz)) (quote (1 2)))
	NIL
	SL-USER> (atom (quote foo))
	T
	SL-USER> (atom (quote (1 2 3)))
	NIL
	SL-USER> (bye)
	GOOD-BYE
	cametan-laptop%

view raw test.lisp hosted with ❤ by GitHub

Arc のソース閲覧

@valvallowさんが

Lisp 系の書籍は、このネタ多いなー（笑）

とか記述していて、全くです、よね(笑)。

この辺のLisp on Lispと言うネタは散見してるんですが、実際僕もそんなにマジメにやった事がないです。マズいんでしょうけどね(笑)。
理由はいくつかあるんですけど、

• プログラムを作りたいんであってプログラミング言語を作りたいわけじゃない


• そもそも、それで作って効率的なの?

と言うのが大きな理由でしょうか。例えば、自分でマジメにLisp処理系をLisp上で書いて、それで果たして愛用出来るようなものになるんか、とか。単なるCSの宿題のネタじゃなかろうか、とか。マジメにLisp処理系を作ってる人はやっぱりCとかで書いてるんだろ?と。LispでLispを書くのが面白くて実用的であれば、ブートストラッピング的にこの世はLispで書かれたLisp処理系で溢れてるんじゃなかろうか、とかね。色々謎がある。

現存するLispで「Lispで書かれたLisp」としては、ポール・グレアムのArcがあります。他の言語で書かれたソースだと読めない可能性もある、んですが、一方、Schemeやってる層だったら比較的読みやすいのでは、と。CS的な意味で言っても、非常にオーソドックスな教科書的なコードなんじゃないのかな、って気がちょっとしますね。

いずれ、このソースを楽々読みこなせるようになりたいもの、です。

	; mzscheme -m -f as.scm
	; (tl)
	; (asv)
	; http://localhost:8080
	(require mzscheme) ; promise we won't redefine mzscheme bindings
	(require "ac.scm")
	(require "brackets.scm")
	(use-bracket-readtable)
	(aload "arc.arc")
	(aload "libs.arc")
	(tl)

view raw as.scm hosted with ❤ by GitHub

	; Arc Compiler.
	(module ac mzscheme
	(provide (all-defined))
	; uncomment the following require for mzscheme-4.x
	; much of Arc will work, but not mutable pairs.
	; (require rnrs/mutable-pairs-6)
	(require (lib "port.ss"))
	(require (lib "process.ss"))
	(require (lib "pretty.ss"))
	; compile an Arc expression into a Scheme expression,
	; both represented as s-expressions.
	; env is a list of lexically bound variables, which we
	; need in order to decide whether set should create a global.
	(define (ac s env)
	(cond ((string? s) (ac-string s env))
	((literal? s) s)
	((eqv? s 'nil) (list 'quote 'nil))
	((ssyntax? s) (ac (expand-ssyntax s) env))
	((symbol? s) (ac-var-ref s env))
	((ssyntax? (xcar s)) (ac (cons (expand-ssyntax (car s)) (cdr s)) env))
	((eq? (xcar s) 'quote) (list 'quote (ac-niltree (cadr s))))
	((eq? (xcar s) 'quasiquote) (ac-qq (cadr s) env))
	((eq? (xcar s) 'if) (ac-if (cdr s) env))
	((eq? (xcar s) 'fn) (ac-fn (cadr s) (cddr s) env))
	((eq? (xcar s) 'assign) (ac-set (cdr s) env))
	; the next three clauses could be removed without changing semantics
	; ... except that they work for macros (so prob should do this for
	; every elt of s, not just the car)
	((eq? (xcar (xcar s)) 'compose) (ac (decompose (cdar s) (cdr s)) env))
	((eq? (xcar (xcar s)) 'complement)
	(ac (list 'no (cons (cadar s) (cdr s))) env))
	((eq? (xcar (xcar s)) 'andf) (ac-andf s env))
	((pair? s) (ac-call (car s) (cdr s) env))
	(#t (err "Bad object in expression" s))))
	(define atstrings #f)
	(define (ac-string s env)
	(if atstrings
	(if (atpos s 0)
	(ac (cons 'string (map (lambda (x)
	(if (string? x)
	(unescape-ats x)
	x))
	(codestring s)))
	env)
	(unescape-ats s))
	(string-copy s))) ; avoid immutable strings
	(define (literal? x)
	(or (boolean? x)
	(char? x)
	(string? x)
	(number? x)
	(eq? x '())))
	(define (ssyntax? x)
	(and (symbol? x)
	(not (or (eqv? x '+) (eqv? x '++) (eqv? x '_)))
	(let ((name (symbol->string x)))
	(has-ssyntax-char? name (- (string-length name) 1)))))
	(define (has-ssyntax-char? string i)
	(and (>= i 0)
	(or (let ((c (string-ref string i)))
	(or (eqv? c #\:) (eqv? c #\~)
	(eqv? c #\+)
	;(eqv? c #\_)
	(eqv? c #\.) (eqv? c #\!)))
	(has-ssyntax-char? string (- i 1)))))
	(define (read-from-string str)
	(let ((port (open-input-string str)))
	(let ((val (read port)))
	(close-input-port port)
	val)))
	; Though graphically the right choice, can't use _ for currying
	; because then _!foo becomes a function. Maybe use <>. For now
	; leave this off and see how often it would have been useful.
	; Might want to make ~ have less precedence than +, because
	; ~foo+bar prob should mean (andf (complement foo) bar), not
	; (complement (andf foo bar)).
	(define (expand-ssyntax sym)
	((cond ((or (insym? #\: sym) (insym? #\~ sym)) expand-compose)
	((insym? #\+ sym) expand-and)
	; ((insym? #\_ sym) expand-curry)
	((or (insym? #\. sym) (insym? #\! sym)) expand-sexpr)
	(#t (error "Unknown ssyntax" sym)))
	sym))
	(define (expand-compose sym)
	(let ((elts (map (lambda (tok)
	(if (eqv? (car tok) #\~)
	(if (null? (cdr tok))
	'no
	`(complement ,(chars->value (cdr tok))))
	(chars->value tok)))
	(tokens (lambda (c) (eqv? c #\:))
	(symbol->chars sym)
	'()
	'()
	#f))))
	(if (null? (cdr elts))
	(car elts)
	(cons 'compose elts))))
	(define (expand-and sym)
	(let ((elts (map chars->value
	(tokens (lambda (c) (eqv? c #\+))
	(symbol->chars sym)
	'()
	'()
	#f))))
	(if (null? (cdr elts))
	(car elts)
	(cons 'andf elts))))
	; How to include quoted arguments? Can't treat all as quoted, because
	; never want to quote fn given as first. Do we want to allow quote chars
	; within symbols? Could be ugly.
	; If release, fix the fact that this simply uses v0... as vars. Should
	; make these vars gensyms.
	(define (expand-curry sym)
	(let ((expr (exc (map (lambda (x)
	(if (pair? x) (chars->value x) x))
	(tokens (lambda (c) (eqv? c #\_))
	(symbol->chars sym)
	'()
	'()
	#t))
	0)))
	(list 'fn
	(keep (lambda (s)
	(and (symbol? s)
	(eqv? (string-ref (symbol->string s) 0)
	#\v)))
	expr)
	expr)))
	(define (keep f xs)
	(cond ((null? xs) '())
	((f (car xs)) (cons (car xs) (keep f (cdr xs))))
	(#t (keep f (cdr xs)))))
	(define (exc elts n)
	(cond ((null? elts)
	'())
	((eqv? (car elts) #\_)
	(cons (string->symbol (string-append "v" (number->string n)))
	(exc (cdr elts) (+ n 1))))
	(#t
	(cons (car elts) (exc (cdr elts) n)))))
	(define (expand-sexpr sym)
	(build-sexpr (reverse (tokens (lambda (c) (or (eqv? c #\.) (eqv? c #\!)))
	(symbol->chars sym)
	'()
	'()
	#t))
	sym))
	(define (build-sexpr toks orig)
	(cond ((null? toks)
	'get)
	((null? (cdr toks))
	(chars->value (car toks)))
	(#t
	(list (build-sexpr (cddr toks) orig)
	(if (eqv? (cadr toks) #\!)
	(list 'quote (chars->value (car toks)))
	(if (or (eqv? (car toks) #\.) (eqv? (car toks) #\!))
	(err "Bad ssyntax" orig)
	(chars->value (car toks))))))))
	(define (insym? char sym) (member char (symbol->chars sym)))
	(define (symbol->chars x) (string->list (symbol->string x)))
	(define (chars->value chars) (read-from-string (list->string chars)))
	(define (tokens test source token acc keepsep?)
	(cond ((null? source)
	(reverse (if (pair? token)
	(cons (reverse token) acc)
	acc)))
	((test (car source))
	(tokens test
	(cdr source)
	'()
	(let ((rec (if (null? token)
	acc
	(cons (reverse token) acc))))
	(if keepsep?
	(cons (car source) rec)
	rec))
	keepsep?))
	(#t
	(tokens test
	(cdr source)
	(cons (car source) token)
	acc
	keepsep?))))
	(define (ac-global-name s)
	(string->symbol (string-append "_" (symbol->string s))))
	(define (ac-var-ref s env)
	(if (lex? s env)
	s
	(ac-global-name s)))
	; quasiquote
	(define (ac-qq args env)
	(list 'quasiquote (ac-qq1 1 args env)))
	; process the argument of a quasiquote. keep track of
	; depth of nesting. handle unquote only at top level (level = 1).
	; complete form, e.g. x or (fn x) or (unquote (fn x))
	(define (ac-qq1 level x env)
	(cond ((= level 0)
	(ac x env))
	((and (pair? x) (eqv? (car x) 'unquote))
	(list 'unquote (ac-qq1 (- level 1) (cadr x) env)))
	((and (pair? x) (eqv? (car x) 'unquote-splicing) (= level 1))
	(list 'unquote-splicing
	(list 'ar-nil-terminate (ac-qq1 (- level 1) (cadr x) env))))
	((and (pair? x) (eqv? (car x) 'quasiquote))
	(list 'quasiquote (ac-qq1 (+ level 1) (cadr x) env)))
	((pair? x)
	(map (lambda (x) (ac-qq1 level x env)) x))
	(#t x)))
	; (if) -> nil
	; (if x) -> x
	; (if t a ...) -> a
	; (if nil a b) -> b
	; (if nil a b c) -> (if b c)
	(define (ac-if args env)
	(cond ((null? args) ''nil)
	((null? (cdr args)) (ac (car args) env))
	(#t `(if (not (ar-false? ,(ac (car args) env)))
	,(ac (cadr args) env)
	,(ac-if (cddr args) env)))))
	(define (ac-dbname! name env)
	(if (symbol? name)
	(cons (list name) env)
	env))
	(define (ac-dbname env)
	(cond ((null? env) #f)
	((pair? (car env)) (caar env))
	(#t (ac-dbname (cdr env)))))
	; translate fn directly into a lambda if it has ordinary
	; parameters, otherwise use a rest parameter and parse it.
	(define (ac-fn args body env)
	(if (ac-complex-args? args)
	(ac-complex-fn args body env)
	(ac-nameit
	(ac-dbname env)
	`(lambda ,(let ((a (ac-denil args))) (if (eqv? a 'nil) '() a))
	,@(ac-body* body (append (ac-arglist args) env))))))
	; does an fn arg list use optional parameters or destructuring?
	; a rest parameter is not complex
	(define (ac-complex-args? args)
	(cond ((eqv? args '()) #f)
	((symbol? args) #f)
	((and (pair? args) (symbol? (car args)))
	(ac-complex-args? (cdr args)))
	(#t #t)))
	; translate a fn with optional or destructuring args
	; (fn (x (o y x) (o z 21) (x1 x2) . rest) ...)
	; arguments in top-level list are mandatory (unless optional),
	; but it's OK for parts of a list you're destructuring to
	; be missing.
	(define (ac-complex-fn args body env)
	(let* ((ra (ar-gensym))
	(z (ac-complex-args args env ra #t)))
	`(lambda ,ra
	(let* ,z
	,@(ac-body* body (append (ac-complex-getargs z) env))))))
	; returns a list of two-element lists, first is variable name,
	; second is (compiled) expression. to be used in a let.
	; caller should extract variables and add to env.
	; ra is the rest argument to the fn.
	; is-params indicates that args are function arguments
	; (not destructuring), so they must be passed or be optional.
	(define (ac-complex-args args env ra is-params)
	(cond ((or (eqv? args '()) (eqv? args 'nil)) '())
	((symbol? args) (list (list args ra)))
	((pair? args)
	(let* ((x (if (and (pair? (car args)) (eqv? (caar args) 'o))
	(ac-complex-opt (cadar args)
	(if (pair? (cddar args))
	(caddar args)
	'nil)
	env
	ra)
	(ac-complex-args
	(car args)
	env
	(if is-params
	`(car ,ra)
	`(ar-xcar ,ra))
	#f)))
	(xa (ac-complex-getargs x)))
	(append x (ac-complex-args (cdr args)
	(append xa env)
	`(ar-xcdr ,ra)
	is-params))))
	(#t (err "Can't understand fn arg list" args))))
	; (car ra) is the argument
	; so it's not present if ra is nil or '()
	(define (ac-complex-opt var expr env ra)
	(list (list var `(if (pair? ,ra) (car ,ra) ,(ac expr env)))))
	; extract list of variables from list of two-element lists.
	(define (ac-complex-getargs a)
	(map (lambda (x) (car x)) a))
	; (a b . c) -> (a b c)
	; a -> (a)
	(define (ac-arglist a)
	(cond ((null? a) '())
	((symbol? a) (list a))
	((symbol? (cdr a)) (list (car a) (cdr a)))
	(#t (cons (car a) (ac-arglist (cdr a))))))
	(define (ac-body body env)
	(map (lambda (x) (ac x env)) body))
	; like ac-body, but spits out a nil expression if empty
	(define (ac-body* body env)
	(if (null? body)
	(list (list 'quote 'nil))
	(ac-body body env)))
	; (set v1 expr1 v2 expr2 ...)
	(define (ac-set x env)
	`(begin ,@(ac-setn x env)))
	(define (ac-setn x env)
	(if (null? x)
	'()
	(cons (ac-set1 (ac-macex (car x)) (cadr x) env)
	(ac-setn (cddr x) env))))
	; trick to tell Scheme the name of something, so Scheme
	; debugging and profiling make more sense.
	(define (ac-nameit name v)
	(if (symbol? name)
	(let ((n (string->symbol (string-append " " (symbol->string name)))))
	(list 'let `((,n ,v)) n))
	v))
	; = replaced by set, which is only for vars
	; = now defined in arc (is it?)
	; name is to cause fns to have their arc names for debugging
	(define (ac-set1 a b1 env)
	(if (symbol? a)
	(let ((b (ac b1 (ac-dbname! a env))))
	(list 'let `((zz ,b))
	(cond ((eqv? a 'nil) (err "Can't rebind nil"))
	((eqv? a 't) (err "Can't rebind t"))
	((lex? a env) `(set! ,a zz))
	(#t `(namespace-set-variable-value! ',(ac-global-name a)
	zz)))
	'zz))
	(err "First arg to set must be a symbol" a)))
	; given a list of Arc expressions, return a list of Scheme expressions.
	; for compiling passed arguments.
	(define (ac-args names exprs env)
	(if (null? exprs)
	'()
	(cons (ac (car exprs)
	(ac-dbname! (if (pair? names) (car names) #f) env))
	(ac-args (if (pair? names) (cdr names) '())
	(cdr exprs)
	env))))
	; generate special fast code for ordinary two-operand
	; calls to the following functions. this is to avoid
	; calling e.g. ar-is with its &rest and apply.
	(define ac-binaries
	'((is ar-is2)
	(< ar-<2)
	(> ar->2)
	(+ ar-+2)))
	; (foo bar) where foo is a global variable bound to a procedure.
	(define (ac-global-call fn args env)
	(cond ((and (assoc fn ac-binaries) (= (length args) 2))
	`(,(cadr (assoc fn ac-binaries)) ,@(ac-args '() args env)))
	(#t
	`(,(ac-global-name fn) ,@(ac-args '() args env)))))
	; compile a function call
	; special cases for speed, to avoid compiled output like
	; (ar-apply _pr (list 1 2))
	; which results in 1/2 the CPU time going to GC. Instead:
	; (ar-funcall2 _pr 1 2)
	; and for (foo bar), if foo is a reference to a global variable,
	; and it's bound to a function, generate (foo bar) instead of
	; (ar-funcall1 foo bar)
	(define direct-calls #f)
	(define (ac-call fn args env)
	(let ((macfn (ac-macro? fn)))
	(cond (macfn
	(ac-mac-call macfn args env))
	((and (pair? fn) (eqv? (car fn) 'fn))
	`(,(ac fn env) ,@(ac-args (cadr fn) args env)))
	((and direct-calls (symbol? fn) (not (lex? fn env)) (bound? fn)
	(procedure? (namespace-variable-value (ac-global-name fn))))
	(ac-global-call fn args env))
	((= (length args) 0)
	`(ar-funcall0 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
	((= (length args) 1)
	`(ar-funcall1 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
	((= (length args) 2)
	`(ar-funcall2 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
	((= (length args) 3)
	`(ar-funcall3 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
	((= (length args) 4)
	`(ar-funcall4 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
	(#t
	`(ar-apply ,(ac fn env)
	(list ,@(map (lambda (x) (ac x env)) args)))))))
	(define (ac-mac-call m args env)
	(let ((x1 (apply m (map ac-niltree args))))
	(let ((x2 (ac (ac-denil x1) env)))
	x2)))
	; returns #f or the macro function
	(define (ac-macro? fn)
	(if (symbol? fn)
	(let ((v (namespace-variable-value (ac-global-name fn)
	#t
	(lambda () #f))))
	(if (and v
	(ar-tagged? v)
	(eq? (ar-type v) 'mac))
	(ar-rep v)
	#f))
	#f))
	; macroexpand the outer call of a form as much as possible
	(define (ac-macex e . once)
	(if (pair? e)
	(let ((m (ac-macro? (car e))))
	(if m
	(let ((expansion (ac-denil (apply m (map ac-niltree (cdr e))))))
	(if (null? once) (ac-macex expansion) expansion))
	e))
	e))
	; macros return Arc lists, ending with NIL.
	; but the Arc compiler expects Scheme lists, ending with '().
	; what to do with (is x nil . nil) ?
	; the first nil ought to be replaced with 'NIL
	; the second with '()
	; so the rule is: NIL in the car -> 'NIL, NIL in the cdr -> '().
	; NIL by itself -> NIL
	(define (ac-denil x)
	(cond ((pair? x) (cons (ac-denil-car (car x)) (ac-denil-cdr (cdr x))))
	(#t x)))
	(define (ac-denil-car x)
	(if (eq? x 'nil)
	'nil
	(ac-denil x)))
	(define (ac-denil-cdr x)
	(if (eq? x 'nil)
	'()
	(ac-denil x)))
	; is v lexically bound?
	(define (lex? v env)
	(memq v env))
	(define (xcar x)
	(and (pair? x) (car x)))
	; #f and '() -> nil for a whole quoted list/tree.
	; Arc primitives written in Scheme should look like:
	; (xdef foo (lambda (lst)
	; (ac-niltree (scheme-foo (ar-nil-terminate lst)))))
	; That is, Arc lists are NIL-terminated. When calling a Scheme
	; function that treats an argument as a list, call ar-nil-terminate
	; to change NIL to '(). When returning any data created by Scheme
	; to Arc, call ac-niltree to turn all '() into NIL.
	; (hash-table-get doesn't use its argument as a list, so it doesn't
	; need ar-nil-terminate).
	(define (ac-niltree x)
	(cond ((pair? x) (cons (ac-niltree (car x)) (ac-niltree (cdr x))))
	((or (eq? x #f) (eq? x '())) 'nil)
	(#t x)))
	; The next two are optimizations, except work for macros.
	(define (decompose fns args)
	(cond ((null? fns) `((fn vals (car vals)) ,@args))
	((null? (cdr fns)) (cons (car fns) args))
	(#t (list (car fns) (decompose (cdr fns) args)))))
	(define (ac-andf s env)
	(ac (let ((gs (map (lambda (x) (ar-gensym)) (cdr s))))
	`((fn ,gs
	(and ,@(map (lambda (f) `(,f ,@gs))
	(cdar s))))
	,@(cdr s)))
	env))
	(define err error)
	; run-time primitive procedures
	;(define (xdef a b)
	; (namespace-set-variable-value! (ac-global-name a) b)
	; b)
	(define-syntax xdef
	(syntax-rules ()
	((xxdef a b)
	(let ((nm (ac-global-name 'a))
	(a b))
	(namespace-set-variable-value! nm a)
	a))))
	(define fn-signatures (make-hash-table 'equal))
	; This is a replacement for xdef that stores opeator signatures.
	; Haven't started using it yet.
	(define (odef a parms b)
	(namespace-set-variable-value! (ac-global-name a) b)
	(hash-table-put! fn-signatures a (list parms))
	b)
	(xdef sig fn-signatures)
	; versions of car and cdr for parsing arguments for optional
	; parameters, that yield nil for nil. maybe we should use
	; full Arc car and cdr, so we can destructure more things
	(define (ar-xcar x)
	(if (or (eqv? x 'nil) (eqv? x '()))
	'nil
	(car x)))
	(define (ar-xcdr x)
	(if (or (eqv? x 'nil) (eqv? x '()))
	'nil
	(cdr x)))
	; convert #f from a Scheme predicate to NIL.
	(define (ar-nill x)
	(if (or (eq? x '()) (eq? x #f))
	'nil
	x))
	; definition of falseness for Arc if.
	; must include '() since sometimes Arc functions see
	; Scheme lists (e.g. . body of a macro).
	(define (ar-false? x)
	(or (eq? x 'nil) (eq? x '()) (eq? x #f)))
	; call a function or perform an array ref, hash ref, &c
	; Non-fn constants in functional position are valuable real estate, so
	; should figure out the best way to exploit it. What could (1 foo) or
	; ('a foo) mean? Maybe it should mean currying.
	; For now the way to make the default val of a hash table be other than
	; nil is to supply the val when doing the lookup. Later may also let
	; defaults be supplied as an arg to table. To implement this, need: an
	; eq table within scheme mapping tables to defaults, and to adapt the
	; code in arc.arc that reads and writes tables to read and write their
	; default vals with them. To make compatible with existing written tables,
	; just use an atom or 3-elt list to keep the default.
	(define (ar-apply fn args)
	(cond ((procedure? fn)
	(apply fn args))
	((pair? fn)
	(list-ref fn (car args)))
	((string? fn)
	(string-ref fn (car args)))
	((hash-table? fn)
	(ar-nill (hash-table-get fn
	(car args)
	(if (pair? (cdr args)) (cadr args) #f))))
	; experiment: means e.g. [1] is a constant fn
	; ((or (number? fn) (symbol? fn)) fn)
	; another possibility: constant in functional pos means it gets
	; passed to the first arg, i.e. ('kids item) means (item 'kids).
	(#t (err "Function call on inappropriate object" fn args))))
	(xdef apply (lambda (fn . args)
	(ar-apply fn (ar-apply-args args))))
	; special cases of ar-apply for speed and to avoid consing arg lists
	(define (ar-funcall0 fn)
	(if (procedure? fn)
	(fn)
	(ar-apply fn (list))))
	(define (ar-funcall1 fn arg1)
	(if (procedure? fn)
	(fn arg1)
	(ar-apply fn (list arg1))))
	(define (ar-funcall2 fn arg1 arg2)
	(if (procedure? fn)
	(fn arg1 arg2)
	(ar-apply fn (list arg1 arg2))))
	(define (ar-funcall3 fn arg1 arg2 arg3)
	(if (procedure? fn)
	(fn arg1 arg2 arg3)
	(ar-apply fn (list arg1 arg2 arg3))))
	(define (ar-funcall4 fn arg1 arg2 arg3 arg4)
	(if (procedure? fn)
	(fn arg1 arg2 arg3 arg4)
	(ar-apply fn (list arg1 arg2 arg3 arg4))))
	; replace the nil at the end of a list with a '()
	(define (ar-nil-terminate l)
	(if (or (eqv? l '()) (eqv? l 'nil))
	'()
	(cons (car l) (ar-nil-terminate (cdr l)))))
	; turn the arguments to Arc apply into a list.
	; if you call (apply fn 1 2 '(3 4))
	; then args is '(1 2 (3 4 . nil) . ())
	; that is, the main list is a scheme list.
	; and we should return '(1 2 3 4 . ())
	; was once (apply apply list (ac-denil args))
	; but that didn't work for (apply fn nil)
	(define (ar-apply-args args)
	(cond ((null? args) '())
	((null? (cdr args)) (ar-nil-terminate (car args)))
	(#t (cons (car args) (ar-apply-args (cdr args))))))
	(xdef cons cons)
	(xdef car (lambda (x)
	(cond ((pair? x) (car x))
	((eqv? x 'nil) 'nil)
	((eqv? x '()) 'nil)
	(#t (err "Can't take car of" x)))))
	(xdef cdr (lambda (x)
	(cond ((pair? x) (cdr x))
	((eqv? x 'nil) 'nil)
	((eqv? x '()) 'nil)
	(#t (err "Can't take cdr of" x)))))
	(define (tnil x) (if x 't 'nil))
	; (pairwise pred '(a b c d)) =>
	; (and (pred a b) (pred b c) (pred c d))
	; pred returns t/nil, as does pairwise
	; reduce?
	(define (pairwise pred lst)
	(cond ((null? lst) 't)
	((null? (cdr lst)) 't)
	((not (eqv? (pred (car lst) (cadr lst)) 'nil))
	(pairwise pred (cdr lst)))
	(#t 'nil)))
	; not quite right, because behavior of underlying eqv unspecified
	; in many cases according to r5rs
	; do we really want is to ret t for distinct strings?
	; for (is x y)
	(define (ar-is2 a b)
	(tnil (or (eqv? a b)
	(and (string? a) (string? b) (string=? a b))
	(and (ar-false? a) (ar-false? b)))))
	; for all other uses of is
	(xdef is (lambda args (pairwise ar-is2 args)))
	(xdef err err)
	(xdef nil 'nil)
	(xdef t 't)
	(define (all test seq)
	(or (null? seq)
	(and (test (car seq)) (all test (cdr seq)))))
	(define (arc-list? x) (or (pair? x) (eqv? x 'nil) (eqv? x '())))
	; Generic +: strings, lists, numbers.
	; Return val has same type as first argument.
	(xdef + (lambda args
	(cond ((null? args) 0)
	((char-or-string? (car args))
	(apply string-append
	(map (lambda (a) (ar-coerce a 'string))
	args)))
	((arc-list? (car args))
	(ac-niltree (apply append (map ar-nil-terminate args))))
	(#t (apply + args)))))
	(define (char-or-string? x) (or (string? x) (char? x)))
	(define (ar-+2 x y)
	(cond ((char-or-string? x)
	(string-append (ar-coerce x 'string) (ar-coerce y 'string)))
	((and (arc-list? x) (arc-list? y))
	(ac-niltree (append (ar-nil-terminate x) (ar-nil-terminate y))))
	(#t (+ x y))))
	(xdef - -)
	(xdef * *)
	(xdef / /)
	(xdef mod modulo)
	(xdef expt expt)
	(xdef sqrt sqrt)
	; generic comparison
	(define (ar->2 x y)
	(tnil (cond ((and (number? x) (number? y)) (> x y))
	((and (string? x) (string? y)) (string>? x y))
	((and (symbol? x) (symbol? y)) (string>? (symbol->string x)
	(symbol->string y)))
	((and (char? x) (char? y)) (char>? x y))
	(#t (> x y)))))
	(xdef > (lambda args (pairwise ar->2 args)))
	(define (ar-<2 x y)
	(tnil (cond ((and (number? x) (number? y)) (< x y))
	((and (string? x) (string? y)) (string<? x y))
	((and (symbol? x) (symbol? y)) (string<? (symbol->string x)
	(symbol->string y)))
	((and (char? x) (char? y)) (char<? x y))
	(#t (< x y)))))
	(xdef < (lambda args (pairwise ar-<2 args)))
	(xdef len (lambda (x)
	(cond ((string? x) (string-length x))
	((hash-table? x) (hash-table-count x))
	(#t (length (ar-nil-terminate x))))))
	(define (ar-tagged? x)
	(and (vector? x) (eq? (vector-ref x 0) 'tagged)))
	(define (ar-tag type rep)
	(cond ((eqv? (ar-type rep) type) rep)
	(#t (vector 'tagged type rep))))
	(xdef annotate ar-tag)
	; (type nil) -> sym
	(define (ar-type x)
	(cond ((ar-tagged? x) (vector-ref x 1))
	((pair? x) 'cons)
	((symbol? x) 'sym)
	((null? x) 'sym)
	((procedure? x) 'fn)
	((char? x) 'char)
	((string? x) 'string)
	((integer? x) 'int)
	((number? x) 'num) ; unsure about this
	((hash-table? x) 'table)
	((output-port? x) 'output)
	((input-port? x) 'input)
	((tcp-listener? x) 'socket)
	((exn? x) 'exception)
	((thread? x) 'thread)
	(#t (err "Type: unknown type" x))))
	(xdef type ar-type)
	(define (ar-rep x)
	(if (ar-tagged? x)
	(vector-ref x 2)
	x))
	(xdef rep ar-rep)
	; currently rather a joke: returns interned symbols
	(define ar-gensym-count 0)
	(define (ar-gensym)
	(set! ar-gensym-count (+ ar-gensym-count 1))
	(string->symbol (string-append "gs" (number->string ar-gensym-count))))
	(xdef uniq ar-gensym)
	(xdef ccc call-with-current-continuation)
	(xdef infile open-input-file)
	(xdef outfile (lambda (f . args)
	(open-output-file f
	'text
	(if (equal? args '(append))
	'append
	'truncate))))
	(xdef instring open-input-string)
	(xdef outstring open-output-string)
	; use as general fn for looking inside things
	(xdef inside get-output-string)
	(xdef stdout current-output-port) ; should be a vars
	(xdef stdin current-input-port)
	(xdef stderr current-error-port)
	(xdef call-w/stdout
	(lambda (port thunk)
	(parameterize ((current-output-port port)) (thunk))))
	(xdef call-w/stdin
	(lambda (port thunk)
	(parameterize ((current-input-port port)) (thunk))))
	(xdef readc (lambda str
	(let ((c (read-char (if (pair? str)
	(car str)
	(current-input-port)))))
	(if (eof-object? c) 'nil c))))
	(xdef readb (lambda str
	(let ((c (read-byte (if (pair? str)
	(car str)
	(current-input-port)))))
	(if (eof-object? c) 'nil c))))
	(xdef peekc (lambda str
	(let ((c (peek-char (if (pair? str)
	(car str)
	(current-input-port)))))
	(if (eof-object? c) 'nil c))))
	(xdef writec (lambda (c . args)
	(write-char c
	(if (pair? args)
	(car args)
	(current-output-port)))
	c))
	(xdef writeb (lambda (b . args)
	(write-byte b
	(if (pair? args)
	(car args)
	(current-output-port)))
	b))
	(define explicit-flush #f)
	(define (printwith f args)
	(let ((port (if (> (length args) 1)
	(cadr args)
	(current-output-port))))
	(when (pair? args)
	(f (ac-denil (car args)) port))
	(unless explicit-flush (flush-output port)))
	'nil)
	(xdef write (lambda args (printwith write args)))
	(xdef disp (lambda args (printwith display args)))
	; sread = scheme read. eventually replace by writing read
	(xdef sread (lambda (p eof)
	(let ((expr (read p)))
	(if (eof-object? expr) eof expr))))
	; these work in PLT but not scheme48
	(define char->ascii char->integer)
	(define ascii->char integer->char)
	(define (iround x) (inexact->exact (round x)))
	(define (ar-coerce x type . args)
	(cond
	((ar-tagged? x) (err "Can't coerce annotated object"))
	((eqv? type (ar-type x)) x)
	((char? x) (case type
	((int) (char->ascii x))
	((string) (string x))
	((sym) (string->symbol (string x)))
	(else (err "Can't coerce" x type))))
	((integer? x) (case type
	((num) x)
	((char) (ascii->char x))
	((string) (apply number->string x args))
	(else (err "Can't coerce" x type))))
	((number? x) (case type
	((int) (iround x))
	((char) (ascii->char (iround x)))
	((string) (apply number->string x args))
	(else (err "Can't coerce" x type))))
	((string? x) (case type
	((sym) (string->symbol x))
	((cons) (ac-niltree (string->list x)))
	((num) (or (apply string->number x args)
	(err "Can't coerce" x type)))
	((int) (let ((n (apply string->number x args)))
	(if n
	(iround n)
	(err "Can't coerce" x type))))
	(else (err "Can't coerce" x type))))
	((pair? x) (case type
	((string) (apply string-append
	(map (lambda (y) (ar-coerce y 'string))
	(ar-nil-terminate x))))
	(else (err "Can't coerce" x type))))
	((eqv? x 'nil) (case type
	((string) "")
	(else (err "Can't coerce" x type))))
	((null? x) (case type
	((string) "")
	(else (err "Can't coerce" x type))))
	((symbol? x) (case type
	((string) (symbol->string x))
	(else (err "Can't coerce" x type))))
	(#t x)))
	(xdef coerce ar-coerce)
	(xdef open-socket (lambda (num) (tcp-listen num 50 #t)))
	; the 2050 means http requests currently capped at 2 meg
	; http://list.cs.brown.edu/pipermail/plt-scheme/2005-August/009414.html
	(xdef socket-accept (lambda (s)
	(let ((oc (current-custodian))
	(nc (make-custodian)))
	(current-custodian nc)
	(call-with-values
	(lambda () (tcp-accept s))
	(lambda (in out)
	(let ((in1 (make-limited-input-port in 100000 #t)))
	(current-custodian oc)
	(associate-custodian nc in1 out)
	(list in1
	out
	(let-values (((us them) (tcp-addresses out)))
	them))))))))
	(xdef new-thread thread)
	(xdef kill-thread kill-thread)
	(xdef break-thread break-thread)
	(xdef current-thread current-thread)
	(define (wrapnil f) (lambda args (apply f args) 'nil))
	(xdef sleep (wrapnil sleep))
	; Will system "execute" a half-finished string if thread killed
	; in the middle of generating it?
	(xdef system (wrapnil system))
	(xdef pipe-from (lambda (cmd)
	(let ((tf (ar-tmpname)))
	(system (string-append cmd " > " tf))
	(let ((str (open-input-file tf)))
	(system (string-append "rm -f " tf))
	str))))
	(define (ar-tmpname)
	(call-with-input-file "/dev/urandom"
	(lambda (rstr)
	(do ((s "/tmp/")
	(c (read-char rstr) (read-char rstr))
	(i 0 (+ i 1)))
	((>= i 16) s)
	(set! s (string-append s
	(string
	(integer->char
	(+ (char->integer #\a)
	(modulo
	(char->integer (read-char rstr))
	26))))))))))
	; PLT scheme provides only eq? and equal? hash tables,
	; we need the latter for strings.
	(xdef table (lambda args
	(let ((h (make-hash-table 'equal)))
	(if (pair? args) ((car args) h))
	h)))
	;(xdef table (lambda args
	; (fill-table (make-hash-table 'equal)
	; (if (pair? args) (ac-denil (car args)) '()))))
	(define (fill-table h pairs)
	(if (eq? pairs '())
	h
	(let ((pair (car pairs)))
	(begin (hash-table-put! h (car pair) (cadr pair))
	(fill-table h (cdr pairs))))))
	(xdef maptable (lambda (fn table) ; arg is (fn (key value) ...)
	(hash-table-for-each table fn)
	table))
	(define (protect during after)
	(dynamic-wind (lambda () #t) during after))
	(xdef protect protect)
	; need to use a better seed
	(xdef rand random)
	(xdef dir (lambda (name)
	(ac-niltree (map path->string (directory-list name)))))
	; Would def mkdir in terms of make-directory and call that instead
	; of system in ensure-dir, but make-directory is too weak: it doesn't
	; create intermediate directories like mkdir -p.
	(xdef file-exists (lambda (name)
	(if (file-exists? name) name 'nil)))
	(xdef dir-exists (lambda (name)
	(if (directory-exists? name) name 'nil)))
	(xdef rmfile (wrapnil delete-file))
	(xdef mvfile (lambda (old new)
	(rename-file-or-directory old new #t)
	'nil))
	; top level read-eval-print
	; tle kept as a way to get a break loop when a scheme err
	(define (arc-eval expr)
	(eval (ac expr '())))
	(define (tle)
	(display "Arc> ")
	(let ((expr (read)))
	(when (not (eqv? expr ':a))
	(write (arc-eval expr))
	(newline)
	(tle))))
	(define last-condition* #f)
	(define (tl)
	(display "Use (quit) to quit, (tl) to return here after an interrupt.\n")
	(tl2))
	(define (tl2)
	(display "arc> ")
	(on-err (lambda (c)
	(set! last-condition* c)
	(display "Error: ")
	(write (exn-message c))
	(newline)
	(tl2))
	(lambda ()
	(let ((expr (read)))
	(if (eqv? expr ':a)
	'done
	(let ((val (arc-eval expr)))
	(write (ac-denil val))
	(namespace-set-variable-value! '_that val)
	(namespace-set-variable-value! '_thatexpr expr)
	(newline)
	(tl2)))))))
	(define (aload1 p)
	(let ((x (read p)))
	(if (eof-object? x)
	#t
	(begin
	(arc-eval x)
	(aload1 p)))))
	(define (atests1 p)
	(let ((x (read p)))
	(if (eof-object? x)
	#t
	(begin
	(write x)
	(newline)
	(let ((v (arc-eval x)))
	(if (ar-false? v)
	(begin
	(display " FAILED")
	(newline))))
	(atests1 p)))))
	(define (aload filename)
	(call-with-input-file filename aload1))
	(define (test filename)
	(call-with-input-file filename atests1))
	(define (acompile1 ip op)
	(let ((x (read ip)))
	(if (eof-object? x)
	#t
	(let ((scm (ac x '())))
	(eval scm)
	(pretty-print scm op)
	(newline op)
	(newline op)
	(acompile1 ip op)))))
	; compile xx.arc to xx.arc.scm
	; useful to examine the Arc compiler output
	(define (acompile inname)
	(let ((outname (string-append inname ".scm")))
	(if (file-exists? outname)
	(delete-file outname))
	(call-with-input-file inname
	(lambda (ip)
	(call-with-output-file outname
	(lambda (op)
	(acompile1 ip op)))))))
	(xdef macex (lambda (e) (ac-macex (ac-denil e))))
	(xdef macex1 (lambda (e) (ac-macex (ac-denil e) 'once)))
	(xdef eval (lambda (e)
	(eval (ac (ac-denil e) '()))))
	; If an err occurs in an on-err expr, no val is returned and code
	; after it doesn't get executed. Not quite what I had in mind.
	(define (on-err errfn f)
	((call-with-current-continuation
	(lambda (k)
	(lambda ()
	(with-handlers ((exn:fail? (lambda (c)
	(k (lambda () (errfn c))))))
	(f)))))))
	(xdef on-err on-err)
	(define (disp-to-string x)
	(let ((o (open-output-string)))
	(display x o)
	(close-output-port o)
	(get-output-string o)))
	(xdef details (lambda (c)
	(disp-to-string (exn-message c))))
	(xdef scar (lambda (x val)
	(if (string? x)
	(string-set! x 0 val)
	(set-car! x val))
	val))
	(xdef scdr (lambda (x val)
	(if (string? x)
	(err "Can't set cdr of a string" x)
	(set-cdr! x val))
	val))
	; When and if cdr of a string returned an actual (eq) tail, could
	; say (if (string? x) (string-replace! x val 1) ...) in scdr, but
	; for now would be misleading to allow this, because fails for cddr.
	(define (string-replace! str val index)
	(if (eqv? (string-length val) (- (string-length str) index))
	(do ((i index (+ i 1)))
	((= i (string-length str)) str)
	(string-set! str i (string-ref val (- i index))))
	(err "Length mismatch between strings" str val index)))
	; Later may want to have multiple indices.
	(xdef sref
	(lambda (com val ind)
	(cond ((hash-table? com) (if (eqv? val 'nil)
	(hash-table-remove! com ind)
	(hash-table-put! com ind val)))
	((string? com) (string-set! com ind val))
	((pair? com) (nth-set! com ind val))
	(#t (err "Can't set reference " com ind val)))
	val))
	(define (nth-set! lst n val)
	(set-car! (list-tail lst n) val))
	; rewrite to pass a (true) gensym instead of #f in case var bound to #f
	(define (bound? arcname)
	(namespace-variable-value (ac-global-name arcname)
	#t
	(lambda () #f)))
	(xdef bound (lambda (x) (tnil (bound? x))))
	(xdef newstring make-string)
	(xdef trunc (lambda (x) (inexact->exact (truncate x))))
	(xdef exact (lambda (x)
	(tnil (and (integer? x) (exact? x)))))
	(xdef msec current-milliseconds)
	(xdef current-process-milliseconds current-process-milliseconds)
	(xdef current-gc-milliseconds current-gc-milliseconds)
	(xdef seconds current-seconds)
	(print-hash-table #t)
	(xdef client-ip (lambda (port)
	(let-values (((x y) (tcp-addresses port)))
	y)))
	; make sure only one thread at a time executes anything
	; inside an atomic-invoke. atomic-invoke is allowed to
	; nest within a thread; the thread-cell keeps track of
	; whether this thread already holds the lock.
	(define ar-the-sema (make-semaphore 1))
	(define ar-sema-cell (make-thread-cell #f))
	(xdef atomic-invoke (lambda (f)
	(if (thread-cell-ref ar-sema-cell)
	(ar-apply f '())
	(begin
	(thread-cell-set! ar-sema-cell #t)
	(protect
	(lambda ()
	(call-with-semaphore
	ar-the-sema
	(lambda () (ar-apply f '()))))
	(lambda ()
	(thread-cell-set! ar-sema-cell #f)))))))
	(xdef dead (lambda (x) (tnil (thread-dead? x))))
	; Added because Mzscheme buffers output. Not a permanent part of Arc.
	; Only need to use when declare explicit-flush optimization.
	(xdef flushout (lambda () (flush-output) 't))
	(xdef ssyntax (lambda (x) (tnil (ssyntax? x))))
	(xdef ssexpand (lambda (x)
	(if (symbol? x) (expand-ssyntax x) x)))
	(xdef quit exit)
	; there are two ways to close a TCP output port.
	; (close o) waits for output to drain, then closes UNIX descriptor.
	; (force-close o) discards buffered output, then closes UNIX desc.
	; web servers need the latter to get rid of connections to
	; clients that are not reading data.
	; mzscheme close-output-port doesn't work (just raises an error)
	; if there is buffered output for a non-responsive socket.
	; must use custodian-shutdown-all instead.
	(define custodians (make-hash-table 'equal))
	(define (associate-custodian c i o)
	(hash-table-put! custodians i c)
	(hash-table-put! custodians o c))
	; if a port has a custodian, use it to close the port forcefully.
	; also get rid of the reference to the custodian.
	; sadly doing this to the input port also kills the output port.
	(define (try-custodian p)
	(let ((c (hash-table-get custodians p #f)))
	(if c
	(begin
	(custodian-shutdown-all c)
	(hash-table-remove! custodians p)
	#t)
	#f)))
	(define (ar-close . args)
	(map (lambda (p)
	(cond ((input-port? p) (close-input-port p))
	((output-port? p) (close-output-port p))
	((tcp-listener? p) (tcp-close p))
	(#t (err "Can't close " p))))
	args)
	(map (lambda (p) (try-custodian p)) args) ; free any custodian
	'nil)
	(xdef close ar-close)
	(xdef force-close (lambda args
	(map (lambda (p)
	(if (not (try-custodian p))
	(ar-close p)))
	args)
	'nil))
	(xdef memory current-memory-use)
	(xdef declare (lambda (key val)
	(let ((flag (not (ar-false? val))))
	(case key
	((atstrings) (set! atstrings flag))
	((direct-calls) (set! direct-calls flag))
	((explicit-flush) (set! explicit-flush flag)))
	val)))
	(putenv "TZ" ":GMT")
	(define (gmt-date sec) (seconds->date sec))
	(xdef timedate
	(lambda args
	(let ((d (gmt-date (if (pair? args) (car args) (current-seconds)))))
	(ac-niltree (list (date-second d)
	(date-minute d)
	(date-hour d)
	(date-day d)
	(date-month d)
	(date-year d))))))
	(xdef sin sin)
	(xdef cos cos)
	(xdef tan tan)
	(xdef asin asin)
	(xdef acos acos)
	(xdef atan atan)
	(xdef log log)
	(define (codestring s)
	(let ((i (atpos s 0)))
	(if i
	(cons (substring s 0 i)
	(let* ((rest (substring s (+ i 1)))
	(in (open-input-string rest))
	(expr (read in))
	(i2 (let-values (((x y z) (port-next-location in))) z)))
	(close-input-port in)
	(cons expr (codestring (substring rest (- i2 1))))))
	(list s))))
	; First unescaped @ in s, if any. Escape by doubling.
	(define (atpos s i)
	(cond ((eqv? i (string-length s))
	#f)
	((eqv? (string-ref s i) #\@)
	(if (and (< (+ i 1) (string-length s))
	(not (eqv? (string-ref s (+ i 1)) #\@)))
	i
	(atpos s (+ i 2))))
	(#t
	(atpos s (+ i 1)))))
	(define (unescape-ats s)
	(list->string (letrec ((unesc (lambda (cs)
	(cond
	((null? cs)
	'())
	((and (eqv? (car cs) #\@)
	(not (null? (cdr cs)))
	(eqv? (cadr cs) #\@))
	(unesc (cdr cs)))
	(#t
	(cons (car cs) (unesc (cdr cs))))))))
	(unesc (string->list s)))))
	)

view raw ac.scm hosted with ❤ by GitHub

	; From Eli Barzilay, eli@barzilay.org
	;> (require "brackets.scm")
	;> (use-bracket-readtable)
	;> ([+ _ 1] 10)
	;11
	(module brackets mzscheme
	; main reader function for []s
	; recursive read starts with default readtable's [ parser,
	; but nested reads still use the curent readtable:
	(define (read-square-brackets ch port src line col pos)
	`(fn (_)
	,(read/recursive port #\[ #f)))
	; a readtable that is just like the builtin except for []s
	(define bracket-readtable
	(make-readtable #f #\[ 'terminating-macro read-square-brackets))
	; call this to set the global readtable
	(provide use-bracket-readtable)
	(define (use-bracket-readtable)
	(current-readtable bracket-readtable))
	; these two implement the required functionality for #reader
	;(define (*read inp)
	; (parameterize ((current-readtable bracket-readtable))
	; (read inp)))
	(define (*read . args)
	(parameterize ((current-readtable bracket-readtable))
	(read (if (null? args) (current-input-port) (car args)))))
	(define (*read-syntax src port)
	(parameterize ((current-readtable bracket-readtable))
	(read-syntax src port)))
	; and the need to be provided as `read' and `read-syntax'
	(provide (rename *read read) (rename *read-syntax read-syntax))
	)

view raw brackets.scm hosted with ❤ by GitHub

#9LISP How to use ASDF

What the FUCK is the prerequisite of LOL?

LOLの調子は如何でしょうか?僕は引っかかりまくりながらやっています(笑)。色んな意味で(笑)。

あの本は想定読者がちょっと微妙なところがあります(実際、プログラミング関係の本だとマトモな編集者が介在してるのか分かんないケースが多々あって、想定読者が絞りきれていず、結果、著作者の独りよがりな本を良く見かけますが(※1))。例えば最初の数章が割に冗長なんですけど、先に進んでいくと今度はCommon Lispに精通していなければ意味が分からない部分が散見してたりして。

これ、ホント誤解して欲しくないんですけど、敢えて言っておきます。LOLの評価に関して言うとCommon Lispに精通している人の意見なんて聞いてもしょーがないです。彼らは、そもそも、Lispの本の出版数自体が少ない(C言語/Java/JavaScriptに比べたら圧倒的に少ない!)んで、Lispの本が出ただけで「これは名著だ!」って言いたがる傾向がある、んです。当たり前ですよね。マイナーなアニメのファンブックが出版されたようなモンですから(笑)。中身はともかくとして、ファンなら買って絶賛するよな(笑)。行動パターンがマイナーアニメのファン層と結構カブるので眉に唾付けとかないとなんない(笑)。

第二の問題として、LOLを絶賛しかねない層と言うのは、LOLなんて買わなくてもマクロに精通している層だと言う可能性がある、からです。当然既にCommon Lispに精通しているわけですから、LOLを斜め読みして、

「う～ん、これは良くまとまってるし分かりやすい。」

とか言うでしょう。当たり前です。それは既にCommon Lispの全貌を殆ど把握している人ですから。ところが、こう言う人たちは大体見逃してるんですよね。マクロ初学者に対して適切に構成されてるのか?とか言う視点に欠けてる。「自分が分かれば良い本だ！」とはならないのが難しいトコなんです。本当の事を言うと。

もちろん、ある程度Common Lispを使っていた事がある、と言うのが前提なのかもしれません。しかしそうだとすると、最初の数章の冗長さは何なんだ、って話になる。unit-of-timeマクロなんてあまりにバカバカしい例だと思いませんかね?幼稚な例、と言えばあまりにも幼稚な例です。これ使ってマクロの基礎を解説される層ってどう言う層なんですかね?そもそもCLでマクロを使った事が無い層が対象読者として想定されてなければこんな例ってあり得ないでしょう。

つまるところ、LOLの真のprerequisiteって何なんだって話なんですけどね。LOLはOn Lispを良く引き合いに出してますが、読者的な立場から言うと本当のprerequisiteってのは別のところにある。っつーかそう解釈しないと構成自体に疑問が出ざるを得ない、のです。特に #9LISP みたいに「SchemeからCLに突如移動する」とでもなった場合、この辺の構成の不具合ってのが全面に出てきちゃうのです。

まあ、個人的には、LOLの内容としては、記述されているマクロ自体の価値はともかくとして、本自体は同人誌だとしか思ってないんですけどね。不具合はあって当然(同人誌だから・笑!)なんであんま苛める気は無いんですけど、ただ、権威的な書籍だと思われたら困るだろ、って事だけは言っておきたい。あくまで一書籍として考えた場合、って事です。一方、 #9LISP みたいな勉強会を行ってる建前上、不具合があった方が良い、ってのもまた事実なんですよね(笑)。独学/自習で全て理解出来てしまうような優秀な本だったらそもそも勉強会を開く口実が無くなってしまう(笑)。プログラミングやってる人たちの間で勉強会が多いのは、穿った見方をすると、プログラミング関係の書籍には構成がマズい本がどーゆーわけか多い(※2)と言う事実の裏返しかもしれません(笑)。ちゃうかもしんねえけどよ(笑)。

※1: 実はプログラミング関係の書籍だけ、じゃなくって最近の理工系出版物全般的な傾向なんじゃないか、と思います。編集者が仕事していない。

もちろん、

「編集者は文系出身だから専門的な内容を理解出来ない。」

なんて意見もあるんですが、フザけんな、とか思います(笑)。仮にも編集者はプロでしょうし、そもそもプロの編集者が理解出来ない原稿を書いてる時点で何なんだ、とか思いますし(笑)。だったら紙資源の節約の為、出版なんてせずに論文書いてるべきですね。査定側は同業者でしょうし。わざわざ出版なんかして地球の森林資源を大規模に無駄にする必要もない。

最近の理工系の本がダメダメになってきてるのは、殆ど出版物が事実上ケータイ小説のレベルになってきてる、って事です。だったら新潮社辺りから出版すりゃあエエんちゃうんか(笑)。

※2: SICP、とか(笑)?

Anything relies on ASDF

とか色々文句書いたんですけど(笑)、どう言う経緯を経てそのプログラミング言語を扱ってるのか、と言うのは想定が難しい、と言うのも事実なんですよね。読者が千差万別のバックグラウンドを持っているから、です。

#9LISP のメンバーでもそうかもしれないし、そうじゃないかもしれませんが、CLにあんま明るくない人が最初に躓くのは、恐らくLOLの第3章辺りでいきなり導入されてるCL-PPCREの存在じゃないか、って思います。もちろん、これはANSI仕様書範囲外のトピックです。すなわち、

「CL-PPCREって外部ライブラリ?っぽいんだけど…。それはいいとしてどーやってインストールすんの?これ。LOLには何も書いてないじゃん。」

そう。何も書いてない(笑)。いきなり読者置いてきぼりの第一撃が放たれるのです。特にWindows使ってプログラミングしている人(そう言う人の方が多い)は放置プレイですよ。困ったもんだ。

以前、#9LISP LOL 第2章 メモにも書いておいたんですが、こーゆー場合に使うのがASDF-installです。言わばCommon LispのCPANです。まあ、gemでもいいんですけど(笑)。

使い方をおさらいしておきましょうか(※1)。REPLで流れを書いておきます。

	CL-USER> (require :asdf) ; asdf を呼び出す
	NIL
	CL-USER> (require :asdf-install) ; asdf-install を呼び出す
	("ASDF-INSTALL")
	CL-USER> (asdf-install:install :cl-ppcre) ; cl-ppcre を asdf-install:install を使ってインストールする
	Install where?
	1) System-wide install:
	System in /usr/lib/sbcl/site-systems/
	Files in /usr/lib/sbcl/site/
	2) Personal installation:
	System in /home/cametan/.sbcl/systems/
	Files in /home/cametan/.sbcl/site/
	-->

view raw using-asdf-install.lisp hosted with ❤ by GitHub

2番のPersonal installationを利用すれば良いでしょう。その後、鍵の認証を求められますが、無視して大丈夫です。その後、

	CL-USER> (asdf:operate 'asdf:load-op :cl-ppcre) ; cl-ppcre を asdf:load-op を利用してロードする
	; loading system definition from
	; /usr/share/common-lisp/systems/cl-ppcre.asd into #<PACKAGE "ASDF0">
	; registering #<SYSTEM :CL-PPCRE {B16B109}> as CL-PPCRE
	; registering #<SYSTEM :CL-PPCRE-TEST {B30F529}> as CL-PPCRE-TEST
	NIL
	CL-USER> (use-package :cl-ppcre) ; use-package を利用して、 cl-ppcre の機能を用いる
	T
	CL-USER>

view raw how-to-use-cl-ppcre.lisp hosted with ❤ by GitHub

とすれば、無事、REPL上でCL-PPCREの提供する全機能を使う事が出来ます。やったね!!!

それはさておき。疑問がある人はあるでしょう。

「オーケー。asdf-installってのはPerlで言うCPAN、Rubyで言うgemなわけね。そこは了承した。何かライブラリをインストールしなきゃなんない、って場合はこれ使えばいいわけだ。何かヘンに括弧があるし、コロンだらけだし、要素が多いんで記述がメンド臭そう(※2)なんだけど一応分かった。

でもさ。そもそもASDFって何なのよ?あとさ。不思議の呪文use-packageって一体何なの?これ無いとダメなのかね?普通はロードしたら即ready-to-rock'n-rollなんじゃねえの?手順が多すぎるんだよな。単にファイル持ってきて手作業でロードした方が良かったりして。」

全くもってその通りです。が、ASDF(Another System Definition Facilities)と言うわざとらしい名前のブツ(※3)が無いとちょっとメンド臭い事象が起こる、って事を書いてみます。現象面から見ていった方が分かりやすいCL独特のメンド臭さがある、のです。

※1: もちろんこれはLinux系OSを使ってない人の場合で、Linux、例えばDebian系ディストロUbuntuだと、レポジトリでCL-PPCREを提供してたりするんで、

sudo aptitude install cl-ppcre

と端末から入力した方がラクだったりする。

また、以前書いた通り、GNU CLISPにはASDFがデフォルトで同梱されてなかったりするんで、最初に別途インストールが必要。ただし、Lispboxの場合、最初からASDFが同梱されているので、面倒が減る。

※2: 確かに長い。ただし、LispboxやあるいはEmacs + SLIMEを利用してる場合は、ライブラリさえインストールしていれば手順は簡略化可能。REPL上でコンマ(,)を打つと、候補が表示される。その中にload-systemと言う項目があって、それが(asdf:operate 'asdf:load-op ...)にあたり、これを選択して、パッケージ名(この場合はCL-PPCRE)を入力してEnterを押せば良い。

もっとも、正直な話をすると、選択肢表示がSLIMEの機能だったのかどうか自信がない。@rubikitchさんがメインテナンスをしているanything.elの機能だったかもしれない。色々入れすぎていて、既に何だか不明なのだ(笑)。

詳しくは@rubikitchさんに訊くか、あるいはこの辺を参考にして欲しい。既にanythingはEmacsの必須ツールとなっている。これ無しでは、Emacsでプログラミングなんてメンド臭くてやってられない、って程だ。

また、Emacs Wikiの方でSLIME用のanything-slime.elが公開されている。これも合わせて環境にインストールしておこう。

※3: 言うまでもないが、a、s、d、fは全て、QWERTY配列キーボードの上から3段目の左から順に並んでいるキーである。

What the FUCK caught ERROR?

まず最初に言っておくと、ASDF自体が新しい、って事です。かつこれは仕様範囲外なんですよね。そして、それをマトモに取り扱ってる書籍が無いです。

そこで、簡単な例を上げてみます。LOLの原著サイトの方で、本に書かれてあるコード(正確に言うと、若干改良したもの)がProduction Codeとして上げられています。考え方としては当然、

「う～ん、本を読みながらコード打ち込んで行くのもいいけど、取りあえず全コードを入手して、それを実際動かしながら調べていく、ってのもアリかな?」

と言うのはアリでしょう。アリですよね(笑)?あるいは、LOLの秘密兵器、defmacro!だけが必要で、他の御託は聞きたくない、とか(笑)。そう言う人も居るはずです(笑)。いてもおかしくない(笑)。

いずれにせよ、そう言ったシナリオを考えてみて、そこのコードをコピペしてlol-production-code.lispと言ったファイルを作ったとしましょう。そしてそれをコンパイル/ロードするとする(Lispbox/SLIMEだったらC-c C-kですか)。ハテサテ、これで上手く行く筈、と思ったら、何とエラー表示。次のようなエラーが表示されると思います。

	cd ~/
	2 compiler notes:
	lol-production-code.lisp:265:1:
	error:
	(during macroexpansion of (DEFMACRO! DLAMBDA ...))
	The function O!-SYMBOL-P is undefined.
	lol-production-code.lisp:357:17:
	read-error:
	SB-INT:SIMPLE-READER-ERROR at 8903 (line 357, column 17) on #<SB-SYS:FD-STREAM for "file /home/cametan/lol-production-code.lisp" {B138C51}>:
	no dispatch function defined for #\`
	Compilation failed.
	; compiling file "/home/cametan/lol-production-code.lisp" (written 06 MAY 2010 02:18:39 PM):
	; file: /home/cametan/lol-production-code.lisp
	; in: DEFMACRO! DLAMBDA
	; (DEFMACRO! DLAMBDA (&REST DS)
	; `(LAMBDA (&REST ,G!ARGS)
	; (CASE (CAR ,G!ARGS) (SB-IMPL::BACKQ-COMMA-AT (MAPCAR # DS)))))
	;
	; caught ERROR:
	; (during macroexpansion of (DEFMACRO! DLAMBDA ...))
	; The function O!-SYMBOL-P is undefined.
	;
	; compilation unit aborted
	; caught 1 fatal ERROR condition
	; caught 1 ERROR condition
	; compilation aborted because of fatal error:
	; READ failure in COMPILE-FILE:
	; SB-INT:SIMPLE-READER-ERROR at 8903 (line 357, column 17) on #<SB-SYS:FD-STREAM for "file /home/cametan/lol-production-code.lisp" {B138C51}>:
	; no dispatch function defined for #\`
	; compilation aborted after 0:00:00.306

view raw compilation-failed.lisp hosted with ❤ by GitHub

「え?何でやねん?」

とか思う筈です。あせります。そもそも公式サイトから取ってきたコードなわけですから書き間違いでエラーが出る筈がない。ところが実際、コンパイルは失敗してエラーが出てる。おかしくないのか?

んで、ちょっと落ち着いてエラー表示を読んでみます。次のような事が書いてあります

defmacro!によるdlambdaの定義のマクロ展開時に於いて、エラーが発生。関数o!-symbol-pが定義されていない。

ここで「おかしいな?」となるでしょう。慌ててファイルlol-production-code.lispをチェックしてみる。Doug Hoyteの野郎、o!-symbol-pの定義書き忘れたんじゃねえの?……いや、でもファイル内をインクリメンタル検索してみるとo!-symbol-pはファイル内でキチンと定義されているのです。何じゃこりゃ、Common Lispがぶっ壊れている???

Macro-expansion before Compilation

実際、このテの一見意味不明なエラーは、原則インタプリタであるSchemeじゃお目にかかりません。Scheme慣れしていると皆目見当が付かない現象なんです。しかし、これはCLの仕様から言うとCL特有の、かつ当たり前の現象なんですよね。起こってるのは次のような事です。

CLの仕様によると、マクロはソースコードのコンパイル時に展開される事になっています。しかし、より正確に言うと、マクロは実際にソースコードをコンパイルする前に展開されるわけです。ここがポイント。何故なら、マクロはLispプログラミング上のコードのショートカットを目論んでいる機能ですから、マクロ定義に従って、マクロのソースコードをバンバン置換していかないとならない。つまり、それこそがマクロ展開であって、これが終了しない事にはファイル自体がコンパイル出来ないわけなんです。

と言う事は、マクロ展開中には、ファイルに定義されている関数が利用されてた場合、当然その関数はまだ存在してないって事なんです。上に紹介した現象に従うと、マクロdlambdaは同じファイル内に定義されているdefmacro!を用いて定義されてるんですが、そのdefmacro!は同じファイル内に存在しているo!-symbol-pに依存しています。しかしながら、マクロ展開中にはまだo!-symbol-pは存在していません。何故ならo!-symbol-p自体の評価もコンパイルもまだ行われてないから、です。そこで、Lispのコンパイラはこれを異常と検知し、コンパイルを中断してエラーを返しているのです。

いやはや、言われてみると「なるほどな」ってんで納得するでしょうけど、同時に何てメンドくせえんだとも思うでしょう(笑)。実際僕自身がハマってましたから(笑)。

そして、もっと言うと、Lispコンパイラはたまたま最初に見つけたo!-symbol-pが発見出来なかった、ってんで警告を発してコンパイルを中断したワケなんですけど、良く良く考えてみると、LOLと言う本の性質から考えて、あらゆるマクロ/関数はファイル内部で依存しあってるのは自明です。o!-symbol-pだけ最初に評価しとけば済む、って話じゃないわけです。考えただけでアタマがクラクラしてきますね(笑)。他にもまだ潜在的に色々な障害があるってのが予想出来ますから。

一体このマクロ展開とコンパイル自体のタイムラグはどうやって修正すんの?

Eval-When?

テキスト勉強中にしこしこREPLにコード打ち込んて動かしたり、あるいは、テキストエディタにLispコードを書いて部分的にS式を評価して実行する以上、上に書いたようなコンピレーションの問題は具現化しません。しかしそれじゃ面白くない。

ポール・グレアムがOn Lispと言う言葉で表現したかったのは、Lispでプログラムを書く、と言う事は裸のLispの上にレイヤーを構築していって、思い通りの言語体系を築き上げて、目的のアプリケーションを書くのに使う、と言う事です。と言う事は他の言語に比べてもフレームワーク作成の重要性が極めて高い、と言う事でもあり、何て事のない小さなプログラムを書いてもいずれ大きなアプリケーションの一部になる可能性が常にある、と言う事でもあります。

つまり、Lisp程コードの再利用が重要な言語もないわけです。かつ、コードを再利用する、と言う事はファイルに記述して保存しておかないとならない。しかし、単純にファイルに記述して保存した途端、上に挙げたようなコンパイル時のトラブルが待ち構えています。困ったもんだ。

もう一回上の例を鑑みて状況を整理すると、あるマクロ展開時にそのマクロに必要な関数が評価されていれば問題は起こらないと言う事です。つまり、恣意的に一部分の関数が先行評価されていれば良い。その方法は?と言うのがここでの議題なんです。

LOLはマクロ記述の為の指南書なんですが、残念ながらその手の方法に付いては全く記述していません。つまり、それなりにCommon Lispの知識を持ってるのが前提なんですが、ところが、先に書いたようにその割には最初の数章がロクにCLに付いて知識が無い人間を前提にしたような記述をしている。想定読者が意味不明だ、って言った理由が分かるでしょ(笑)?んで、この手のトラブル対処法を知ってる人なら当然マクロに付いても既に豊富な知識がある筈だって事を言ってたわけなんです。

さて、この問題に対処する為には暫定的には次の三つの対応策が考えられます。

1. 常にREPL上で必要な関数をメンド臭くても先に評価しておく。


2. eval-whenを使う。


3. ASDFを用いてシステムとしてパッケージ化してしまう。

テキストの例に上がっているコードをREPLでシコシコ評価して勉強している以上、1番の方策は当然アリです。が、考えただけでもメンド臭いですよね(笑)。じゃあ、何かのマクロを書いて、それに必要な関数は別なファイルに纏めておいて、先にCLにロードして評価してしまう、ってのもアリかもしれません。が、いずれにせよちとメンド臭い。後々の事を考えると当然ですよね。defmacro!を利用する為に別のファイルにわざわざまとめておいたg!-symbol-pやo!-symbol-pを先にロードする……まあ、やっても良いかもしれませんし、悪くは無いんですが、頻繁にそれ、ってのも困ります。特にコードの再利用を考えると手順はメンド臭くない方が良いわけです。

2番目のeval-whenを使う、と言うのがまさに直接的な回答かもしれません。まさしくこれが、恣意的に先行評価を起こさせる特殊オペレータだから、です。ところが、問題は…手元の資料を見る限り、解説されてないんですよね(笑)。使い方が(笑)。今までの流れを考えると、これだけ大事な特殊オペレータなんですが、ほぼシカトされています(笑)。Common Lispの本書く人は「Lispは実用に使える言語だ!」って前書き辺りで強調するケースが多いんですが、見てきた通り、ファイルに纏めると問題発生、しかもその解決策を書いてないんだったら絵に描いた餅だろう、とか思うんですけど(笑)。

唯一、eval-whenに付いてマトモにページを割いてるのは実践Common Lispくらいですね。この著者はさすが著書に「実践」って名づけるだけあって、アプリケーション作成に於いて何が問題になるのか良く知っています。抽象論にしていない。

原書サイトで解説書いてあるんで、読んでみても良いでしょう。一部日本語訳から抜粋してみます。今まで記述してきた問題点を端的に表現しています。

DEFMACROの展開形にはEVAL-WHENが含まれているので、そのファイル内でマクロを定義した直後から使うことができる。しかしマクロを定義しているファイルでマクロを使うには、マクロだけでなく、マクロが使っている関数もすべて定義されている必要がある。ところがDEFUNでは、通常はコンパイル時に関数が有効にならない。そこでマクロが使うヘルパー関数のDEFUNをすべて:compile-toplevel付きのEVAL-WHENで包むことにより、マクロの展開関数が走るときにその定義が使えるようになる。場合によっては:load-toplevelと:executeを付けてもよいだろう。ファイルのコンパイルやロードの後、もしくはコンパイルする代わりにファイルをロードする場合は、関数の定義が必要になるからだ。

実践Common Lisp

ぶっちゃけ、僕も実践Common Lispは読んだ事は読んでたんですが、すっかり失念していました(笑)。プログラミングでは実際にトラブルに見舞われないと、重要な示唆がどれだけ重要か、って実感出来ないんですよね。困ったもんです。

なお、eval-whenはMacLisp由来だそうで、確かに同じくMacLispの直系の子孫であるEmacs Lispのファイルではeval-when-compileと言う記述を良く見かけます。Emacs Lispを書いている人にはひょっとしてお馴染みなのかもしれません。

Altanative 3: ASDF

さて、第3の選択肢で、ここで扱うのがASDFです。eval-when自体がロクな解説が無いんで嫌ってたんですけど、実はASDFに関しては輪をかけて解説が書いてある書籍が無いです。

じゃあ何でASDFなんだ?それ以前にASDFって一体何なの?端的に表現すると、ASDFとはCommon Lisp用のMakefileです。つまり、ファイル同士の依存関係をハッキリさせて順序良くコンパイルしてロードするように指定する仕組み、なんです。と言う事は、(asdf:operate 'asdf:load-op ...)と言うのは、言わば、GNUのツールで言うmakeなんです。

そして概念的にはMakefileだ、と言う事は、当然eval-whenが必要になるような場面でも、明示的にeval-whenを指定しなくても全て解決してくれる、と言う事です。非常に有難い仕組みなんですよ。使う分にはね。少なくともLinux系のOSでアプリケーションのインストールでmakeを使うよりゃメンド臭くない。

@valvallowさんがブログでOn Lisp と Let Over Lambda のコードって一挙に紹介してたんですけど、僕が何故これやらなかったのか、と言うと、前述の通り、ファイルのコンパイル/ロードで面倒な事になる、って知ってたから、です。と言うかこの記事が上がる前に既になってた(笑)。そして、何故Debian配布のOn Lispのコードにこだわってたのか、と言うのも、この手のコンパイル/ロードに関して言うと面倒が無いから、です。debヴァージョンはASDF化してる。使う分にはラクチンで殆ど何も考えなくて良いのがASDFと言うシステムなんです。

反面、自分でMakefileを作る、もとい、ASDFを設定する、ってのはメンド臭いです。何せ資料となる書籍が無い、んで。僕自身も過去何度か挑戦したんですが、失敗してメンド臭くなっちゃった(笑)。ASDFに付いて少しでも記述してるのがまたもや実践Common Lispだけ、と言う有り体なんですが、そこでもこんな事が書いてあります。

ASDファイルの他の例については、Webで入手できる本書のソースコードが参考になるはずだ。実践の各章で使ったコードは、適切な内部システム依存関係と一緒に、システムとしてASDファイルに記述されている。

実質これしか書いてないんです。事実上、ｸﾞｸﾞﾚｶｽと言ってるわけですよ(笑)。とは言っても日本語で読めるASDFの解説なんて知りませんし、結局英語のマニュアル読まなアカンのか(笑)。うげえメンドくせえ。そもそもマニュアルなんて母国語でさえ読みたくねえシロモノなのに(笑)。そうだろ、皆の衆(笑)?

とは言っても、Lisp勉強していくうちに、そのうちCommon Lispで書かれたアプリケーションを配布したい、と言うような野望がある人もいる事でしょう。CLでのexecutablesの作り方、ってのは謎の部分が多いんですが(マジで多い)、それに比べればASDFはまだ敷居が低そうに見えます。なんせ所詮Makefileですし。しかも前項までの問題、要するにeval-whenにまつわる問題も解決してくれる。一石二鳥です。

てなわけで実践Common Lispの配布コードと首っ引きになってASDFの設定方法を分析していました。再度挑戦です。ここいらでASDFにカタ付けといても良いだろ、と言う個人的動機と、日本語で書かれたASDFの説明がほぼない、って辺りで良いイントロダクションになれば良いな、と言う二つの目的があります。まあ、専門家じゃないんで勘違いもあるかもしれませんが、そこはブログ記事なんで、適当に補完出来る人はより正確な記事を書いてみてください。あとは任せた(笑)。

ところで、ASDFに入る前にCLのパッケージと言われるシステムに付いて軽く解説しておきます。本当はやりたくねえんだけど(笑)、これ解説しとかないとワケワカメなんでしょーがない。

What the FUCK are Packages?

パッケージとは、端的に言うとCommon Lisp上での名前空間を分離/分割する仕組みです。そしてこの存在に絡んでCLerとSchemerがまた喧嘩してんですよね(笑)。んなもんどーでもいいだろ、とか第三者的には思うんですが(笑)。当然、CLにはパッケージがあるけどSchemeには無い(※1)。そしてCLerに言わせると、このパッケージと言う仕組みがCLの設計の根幹を握っているらしい。

余談ですが、ポール・グレアムは独自に新しいLisp方言Arcを設計しています。んで、このArcには名前空間を分割する為のパッケージ、って仕組みが入ってない模様です。んで、当然の如く、Arcを試した層から「Arcにはパッケージが無いの?」と言う質問を受けたらしい。ポール・グレアムはそれに付いてこんな感じで回答していました。

パッケージが必要になったらArcに組み入れようとは思っている。ただ、個人的にはパッケージが必要だ、って思った事は一度もないんだ。

まあ、前にも指摘したんですが、ポール・グレアムはCommon Lispに関しても、自分の好きな機能にはページを多く割く傾向があって、反面自分が好きじゃない機能に関してはページをそんなに割きません(笑)。ANSI Common Lisp読んでも、パッケージに関する解説はちょっとばっかし、です。あんま使ってないんでしょうね(笑)。同様に構造体は好きだけどCLOSはあんま好きじゃない、って事も分かります(笑)。この辺、色んな意味で実践Common Lispの著者、Peter Seibelと極めて対照的です。

さて、本題に戻ると。Common Lispはちょっとしたデータベースのような仕組みになっています。例えば次のようにREPLに入力する。

	CL-USER> 'hoge
	HOGE
	CL-USER>

view raw reaction-of-repl.lisp hosted with ❤ by GitHub

hogeと言うシンボルをREPLに入力するとHOGEと表示する。Schemeなんかを鑑みても、Lisp系の言語だと当たり前の反応なんですが、実はこの時点でCommon Lispでは背後でHOGEと言うシンボルをデータベースに登録しています。このデータベースはシンボル専用のデータベースで、平たく言うとこれがパッケージです。そして、ここで使われているパッケージがCL-USER(本当はCOMMON-LISP-USERと言う名称)のパッケージです。プロンプトに表示されているCL-USERと言うのはこのデータベース、もとい、パッケージ名を表しているんです。

つまり、REPLでシンボルを入力する度に新しいシンボルだったらCommon Lispはパッケージと呼ばれるシンボル用データベースにそのシンボルを登録していきます。これをCLではシンボルをパッケージにインターンすると言います。もし登録済みのシンボルだったら、当然その中身を調べるわけですよね。つまり変数なのか関数なのか、はたまた属性リストなのか、と。端的に言うとこれがCLがユーザーに見えない部分で行っている事で、Schemeに比べると遥に複雑な事をやってるわけです。

ついでに言うと、表面的にはSchemeで言うstring->symbolとCLのinternは結果だけ見ると似たようなモノに見えるんですが、実は意味が違うんです。Schemeのstring->symbolは字面が表している通り単に文字列をシンボルと言う型に変換してるんですが、CLのinternの目的と言うのは、もちろん文字列をシンボルに直すんですが、むしろ明示的にパッケージにシンボルを登録する事、なんです。

	CL-USER> (intern "HOGE")
	HOGE
	:INTERNAL
	CL-USER>

view raw experiment-about-intern.lisp hosted with ❤ by GitHub

internは見た通り、多値関数です。返り値が二つある。最初の返り値は"HOGE"をシンボルに直した表現が表示されていますが、二つ目の返り値は:INTERNALとなっている。これはつまり、「CL-USERと言うパッケージには登録済みのシンボルだよ」と教えている。何故かと言うと、先ほどREPLでhogeと入力していますからね。新規にinternすると、この部分はnilと表示される筈です。

そしてここで分かる事が一つあります。現時点REPLではCL-USERと言うパッケージを対象にしていました。当然CL-USERだけが唯一無二のパッケージ、ってわけじゃあない。他にもパッケージが存在する(※2)し、また独自にパッケージを作る事さえ出来ます。このパッケージ作成の為のマクロをdefpackageと言います。

以降、比較的Common Lisp入門の例が分かりやすいんでそれに準じてみます。

	CL-USER> (defpackage :東京 (:use :common-lisp)) ;東京パッケージを定義
	#<PACKAGE "東京">
	CL-USER> (in-package :東京) ;東京パッケージに変更
	#<PACKAGE "東京">
	東京> '支店長 ;シンボル支店長を東京パッケージにインターン
	支店長
	東京>

view raw tokyo-package.lisp hosted with ❤ by GitHub

上の例では、最初にdefpackageで東京パッケージを定義しています。本体部に(:use :common-lisp)と記述しているのは、CLの基本機能を提供しているCOMMON-LISPパッケージを利用しろ、と言う指定です。(CL-USERとはまた別物。ちなみに短縮形はCL。)これが無いと東京パッケージに入った途端にCommon Lispの全機能が使えなくなると言うようなおマヌケな事態に陥るので忘れないようにしましょう(笑)。言わば要請されたデフォです(笑)。

二つ目の(in-package :東京)でCL-USERから東京パッケージに入っています。in-packageと言うのがパッケージ間を行き来する為のマクロです。ここが実行されるとプロンプトが東京に変更されたのが分かるでしょうか?Lispbox/Emacs + SLIMEは親切な事に現時点どのパッケージにいるのか表示してくれます。

そして、三つ目のREPLでの支店長の評価により、シンボル支店長は東京パッケージへとインターンされます。

続いて、次のようにしてみます。

	東京> (defpackage :大阪 (:use :cl)) ;大阪パッケージを定義
	#<PACKAGE "大阪">
	東京> (in-package :大阪) ;大阪パッケージに変更
	#<PACKAGE "大阪">
	大阪> '支店長 ;シンボル支店長を大阪パッケージにインターン
	支店長
	大阪>

view raw osaka-package.lisp hosted with ❤ by GitHub

殆ど同じなんですが、三つ目に注目してください。先ほどはシンボル支店長は東京パッケージにインターンされました。今度はシンボル支店長は大阪パッケージにインターンされています。これが何を意味してるか、と言うと東京の支店長と大阪の支店長は全く違うシンボルだと言う事です。全然別人だ、と言う事ですね(笑)。これを次のようにして確かめてみます。

	大阪> (defparameter 支店長 1) ;大阪の支店長を 1 と定義
	支店長
	大阪> (in-package :東京) ;東京へ移動
	#<PACKAGE "東京">
	東京> (defparameter 支店長 '(a b c)) ;東京の支店長を (a b c) と定義
	支店長
	東京> (in-package :大阪) ;大阪へ移動
	#<PACKAGE "大阪">
	大阪> 支店長 ;大阪の支店長を評価すると 1 になる
	1
	大阪> (in-package :東京) ;東京へ移動
	#<PACKAGE "東京">
	東京> 支店長 ;東京の支店長を評価すると (a b c) になる
	(A B C)
	東京>

view raw each-shitencho.lisp hosted with ❤ by GitHub

東京の支店長と大阪の支店長が全くの別人、もとい、別のシンボルになってる、って事がお分かりでしょうか。

では東京パッケージから大阪の支店長を参照する事が出来るのでしょうか?出来ますが、原則そう言う場合はシンボルをエクスポートしないとなりません。その為には関数exportを用います。

	東京> (in-package :大阪) ;大阪へ移動
	#<PACKAGE "大阪">
	大阪> (export '支店長) ;シンボル支店長をエクスポートする
	T
	大阪> (in-package :東京) ;東京へ移動
	#<PACKAGE "東京">
	東京> 大阪:支店長 ;大阪の支店長を参照する
	1
	東京>

view raw example-of-export.lisp hosted with ❤ by GitHub

実はASDF自体がパッケージで、asdf:operateとかasdf:load-opとか、やたら名称が長くまたコロンが多用されているのもこれらがexportされたシンボルだから、なんです。CL-USERと言うデフォルトのパッケージでASDFと言う別パッケージのシンボルを利用するにはああ言う記述方法を用いる必要があり、パッケージに於いてはコロンは「～パッケージの」と言う意味になってるわけです。

しかし、場合によっては、コロン多用による記述がメンド臭い場合があります。そう言う場合、次のようにして明示的にシンボルをインポートしたパッケージを定義出来ます。

	東京> (defpackage :名古屋 (:use :cl) ;名古屋パッケージを定義
	(:import-from :大阪 :支店長)) ;大阪パッケージからシンボル支店長をインポート
	#<PACKAGE "名古屋">
	東京> (in-package :名古屋) ;名古屋へ移動
	#<PACKAGE "名古屋">
	名古屋> 支店長 ;名古屋の支店長は大阪の支店長と同一人物?
	1
	名古屋> (in-package :大阪) ;大阪へ移動
	#<PACKAGE "大阪">
	大阪> 支店長 ;大阪の支店長は名古屋の支店長と同じ値を返す
	1
	大阪> (in-package :名古屋) ;名古屋へ移動
	#<PACKAGE "名古屋">
	名古屋> (eq '支店長 '大阪:支店長) ;名古屋の支店長と大阪の支店長は同一人物!
	T
	名古屋> (in-package :東京) ;東京へ移動
	#<PACKAGE "東京">
	東京> (eq '支店長 '大阪:支店長) ;東京の支店長は大阪の支店長とは別人!
	NIL
	東京>

view raw example-of-import-from.lisp hosted with ❤ by GitHub

また、あるパッケージの全機能を使いたい場合、次のようにしてパッケージを定義すれば良いです。

	東京> (defpackage :京都 (:use :cl :大阪)) ; cl の他に大阪パッケージを use するように指定
	#<PACKAGE "京都">
	東京> (in-package :京都) ;京都へ移動
	#<PACKAGE "京都">
	京都> 支店長 ;大阪からエクスポートされた全シンボルは京都パッケージに共有される
	1
	京都> (symbol-package '支店長) ;京都の支店長は大阪の支店長であることが分かる
	#<PACKAGE "大阪">
	京都>

view raw kyoto-package.lisp hosted with ❤ by GitHub

これでパッケージの使い方の基本は全部見ました。パッケージとは要するに名前保護の為のシステムであり、また、明示的にあるパッケージからシンボルをインポートしたりエクスポートしたり、と言う事が出来るのです。Schemeと比べると遥に複雑ですし、最初からこれを真っ正面から取り上げている本は、それこそCommon Lisp入門くらいしかない、んですが、これを煩わしいと感じるか否か、ってのも正直人に依るとは思います。しかしASDFを取り上げる以上、このシステムは避けて通れないのは事実、なんです。んで、ぶっちゃけた話、ポール・グレアムがANSI Common Lispを記述した1995年辺りでは、ASDFそのものが恐らく存在してなかったんでしょう。パッケージ自体の歴史は長いにも関わず、ASDFのせいで近年異様にパッケージの重要度が上がってきた、と思います。

最後に一つだけ。CLerとSchemerの諍いの大体の元凶はマクロに付いて、なんです。LOLでもSchemeの衛生的マクロが批判されていましたが、両者ともマクロの事になるとアツくなる。特に名前の衝突に付いての話になると両者とも譲らないのです(笑)。

ここはパッケージの話を書いてる筈なのに何でいきなりマクロ、しかも名前の衝突、なんて話が出てくるんだ?と思う人もいるでしょうが、実はCLerはこのパッケージと言う仕組みそのものがCLのマクロを支えている、と考えている。そして極論を言うと、Schemeはパッケージを持たない辺りがダメなんだ、と考えている。その部分だけちょっと説明しておきます。

最初にREPLでシンボルを入力するとパッケージにインターンされる、と言う話をしました。その途端そのシンボルはパッケージに保護されるわけです。つまり、どのシンボルでも何らかの形でどっかのパッケージにインターンされてるわけです。たった一つの例外を除いては。それがgensymで生成されるシンボルなんです。

つまり、原則的にどのシンボルでもどっかのパッケージにインターンされて、何らかの方法で参照出来る、と言う建前があるが故に、どのパッケージにもインターンされない、つまり参照出来ないシンボルが生成出来ると言うカラクリが成り立つわけですよ。これがなかなか上手い手を考えたもんだな、と(笑)。CLerの主張とは、こう言った上手い手無しにマクロが書けるか?とSchemeを非難してるわけですね(笑)。

LOLで書いてたgensymの説明、と言うのは、今までやってたパッケージの動作とシンボルのインターン、と言うコンセプトを掴めばより分かりやすいのではないか、と思います。抜粋してみます。

Common Lispでは、シンボル(名前)はパッケージに結び付けられる。パッケージはシンボルの集合であり、与えられた文字列、つまりそのシンボルのsymbol-name文字列を使って、パッケージからシンボルを指すポインタが得られる。このポインタ(通常単にシンボルと呼ばれる)の最も重要な性質は、同じsymbol-nameでそのパッケージから探索された他の全ポインタ(シンボル)との比較が、eqで行われることである。gensymはいかなるパッケージにも属さないシンボルであり、そのシンボルとeqになるシンボルを得られるsymbol-nameは存在しない。名前を付ける必要なしに、1つの式の中で、あるシンボルが他のシンボルとeqとなるようLispに指示したい場合、gensymを使う。プログラマが名前付けを一切行わないため、名前の衝突は発生し得ない。

※1: もちろん、処理系によってはパッケージを持ってるSchemeもあります。中でも印象に残ってるのはScheme48と言う処理系です。CLばりのパッケージを持っていて、何とSRFIを使おうとしてもシンボルが保護されていてインポートしないと使えない、と言うのが強烈でした(笑)。

この辺のライブラリの扱いに対しても、処理系作成者の解釈/判断の余地が大きく、結局処理系間でポータブルなコードを書くのが難しくなる、と言うのがSchemeの特徴です。

移植性のあるSchemeのコードを書くのはCommon Lispで書くのより骨が折れる。

実践Common Lisp

※2: ではデフォルトでは一体いくつくらいパッケージがあるのでしょう?CLHSによると、仕様で標準として最低限要求されているパッケージは次の三つです。

• COMMON-LISP: Common Lispの中核機能が定義されたパッケージ


• COMMON-LISP-USER: デフォルトでユーザーと対話するパッケージ


• KEYWORD: キーワード(アタマにコロンが付いてるシンボル)がインターンされるパッケージ

この3つが最低限要求されているパッケージなんですが、逆に言うと、これさえ満たしていれば、実装次第でもっとパッケージを追加しても良い、と言う事です。つまり、CL処理系の背後では様々なパッケージが動いている、と言う事になります。

処理系で使われている全てのパッケージを一覧するにはlist-all-packagesと言う関数を用います。これは今現在使用されている全てのパッケージ名をリストにして返します。

なお、SBCLの場合ですが、デフォルトの状態で次のようにREPLに入力

(loop for i in (list-all-packages) counting i)

してみると、49と言う数値を返してきます。つまり、SBCLのREPLの裏では49個ものパッケージが連帯しながらCL-USERパッケージを通じてユーザーと対話しているのです。

BASIC OF ASDF

と言うわけで、前項のパッケージの基本を踏まえてASDFの作成方法を記述していきます。ここでは、Lispプログラムとしてはマジでクダラないコードを扱う事にします。それこそ、Hello, World!って表示される程度でいい、と。その方がASDFの記述方法に集中出来るってなもんです。つまり、

(defun hello-world ()
  (princ "Hello, World!"))

を対象のコードとします。

ASDFのファイル構成は次の三つが基本、です。

1. packages.lisp


2. プログラム本体のlispファイル


3. asdファイル

これら三つのファイルがシステム定義を構成していて、これらの外枠のディレクトリ(あるいはフォルダ)内に存在すればいいわけです。ここではHello, World!と表示されるだけのプログラムとも言えないプログラムを用いてるんで、単純にhelloディレクトリをHOMEディレクトリ内に作る形とします。

まずはpackages.lispから。これは前項見た通り、プログラムが所属する(正確に言うと、プログラムが用いているシンボルがインターンされる)パッケージを定義します。雛形は次のような形です。

	(in-package :cl-user)
	(defpackage :パッケージ名
	(:use :common-lisp) ; common-lisp 以外でも使いたいパッケージがあれば指定
	;; (:export :プログラムファイル内で使ってるエクスポートしたいシンボル名
	;; :複数列挙化)
	)

view raw template-of-packages.lisp hosted with ❤ by GitHub

第一行目は、取りあえずこのパッケージ定義がどのパッケージ内で読まれるのか指定しています。デフォルトでCL-USERで読まれればまあ問題が生じないんで、CL-USERに移動しておきます。三行目以降でプログラム本体で使われているシンボルがインターンするべきパッケージを定義します。ここでCOMMON-LISPパッケージをuseするのを忘れないようにしましょう。もう一回繰り返しますが、COMMON-LISPパッケージがCLの中核の機能を定義しているパッケージなんで、これがないとCLの全機能が使えません(笑)。あと、exportはお好きなように。この例のHello, World!を表示するだけのようなクダラないプログラムでは、本体定義であるhello-worldと言うシンボルをエクスポートします。

	(in-package :cl-user)
	(defpackage :hello
	(:use :common-lisp)
	(:export :hello-world))

view raw packages.lisp hosted with ❤ by GitHub

このパッケージ定義を受けて2番目の本体のプログラムは次のようになります。

	(in-package #:hello)
	(defun hello-world ()
	(princ "Hello, World!"))

view raw hello-world.lisp hosted with ❤ by GitHub

第一行にシンボルをインターンさせたいパッケージに移動する旨を定義します。この場合は当然、明示的にpackages.lispで定義されたパッケージ(helloパッケージ)へと移動する、って事ですね。そこさえ書いておけばプログラム本体はフツーに書いて構わない。

なお、この例(hello-world.lisp)ではin-package指定の部分に#を含んでいますが何故かは知りません(笑)。単に実践Common Lispの公式サイトで配布しているソースコードを調べた際に含まれていたんで従ったまで、です(笑)。CL-PPCREも調べてみたんですが、そっちには付いてませんでしたね。もう一つ言うと、一応ASDFのマニュアルもザーっと眺めてみたんですが、特に何も書いてませんでした(笑)。だから、あってもなくても構わないんじゃねえのかな(笑)?良く分からんわ(笑)。

さて、この時点で一つ分かる事があります。それはhello-world.lispはpackages.lispに依存していると言う事です。これは当然ですよね。hello-world.lispはあるパッケージへと移動する旨があるのに、最初にそのパッケージが生成されてなければ意味がないから、です。逆に言うと、最初にパッケージが定義されてからプログラム本体が読み込まれないとならない。この手の依存関係を指定するのがasdファイルです。

asdファイルの雛形は次の通り。

	(defpackage :システムパッケージ名 (:use :asdf :cl)) ;システムパッケージを定義
	(in-package :システムパッケージ名) ;システムパッケージへ移動
	(defsystem システム名
	:name "システム名" ;システム名表示
	:author "" ;著作者名表示
	:version "" ;ヴァージョン番号表示
	:maintainer "" ;メンテナ名表示
	:licence "" ;ライセンス表示
	:description "" ;短い解説表示
	:long-description "" ;詳細な解説表示
	:components ;システム内のファイル設定
	((:file "packages") ;packages.lisp の読み込み
	(:file "" :depends-on ("packages")) ;プログラム本体ファイルの読み込み( packages.lisp に依存)
	;; 複数列挙可
	)
	;; :depends-on () ;依存する外部システム
	)

view raw template-of.asd hosted with ❤ by GitHub

一行目でシステムとしてのパッケージ名を定義します。これは先ほどpackages.lispで定義したパッケージとはまた別です。が、簡便性を優先して、packages.lispで作成したパッケージ名に-systemでも付けた形にしておけば良いでしょう。packages.lispでhelloと言うパッケージを定義してたらasdではhello-systemと言うように。

もう一つ重要なのは、このパッケージではclパッケージ(つまりCOMMON-LISPパッケージ)をuseするのは当然として、ついでにasdfパッケージもuseする事を指定します。これは当然、ここではasdfパッケージで定義された全機能を用いなければならないから、です。ついでに言うと、雛形では四行目以降でdefsystemと言う関数が用いられていますが、これはANSI仕様にはない関数で、ASDFパッケージで定義されているもの、です。従って、これを使う以上ASDFで定義されてエクスポートされたシンボルを全てインポートしないとならない。

正しくシステムパッケージを定義しておいて、二行目でそのシステムパッケージに移動しています。ここはまあ、いいですね。

四行目以降からdefsystemを用いて、色んな情報(ファイルの依存情報や外部システムへの依存情報を含む)を記述していきます。システム名は先ほど同ファイル内に定義したシステムパッケージ名とは別です。原理的にはpackages.lispで定義したパッケージ名とも別です。そして、ここがASDFにシステム名として認識されます。お好きなキャッチーな名前を付けましょう(そして、それがasdファイルの名前になるでしょう)。ここではシンプルにhelloシステム、と名づけます。

以降、:name～:long-descriptionはどーでもいいです(笑)。あっても無くても構いません。与えるものが文字列だ、って事さえ気をつければどう書いても構いません。

重要なのは:componentsです。ここでシステムに必要なファイル群とそれらの間の依存関係を指定します。つまり、今の場合はhelloディレクトリに含まれる3つのファイルのうち、packages.lispとhello.lispの二つのファイルの依存関係がどうなってるのか銘記しないといけません。そしてどのみち、システムを構成し、プログラム自体が記述された全.lispファイルはpackages.lispに依存するだろう事は分かりきっています(何故なら、それがプログラム本体で使われる全シンボルのインターン先を定義してるから、です)。

また、:componentsで指定するファイルには特に拡張子は付けません。

それで、結果としてhello.asdは次のようになります。

	(defpackage :hello-system (:use :asdf :cl))
	(in-package :hello-system)
	(defsystem hello
	:name "hello"
	:author ""
	:version ""
	:maintainer ""
	:licence ""
	:description ""
	:long-description ""
	:components
	((:file "packages")
	(:file "hello-world" :depends-on ("packages")))) ;hello-world.lisp は packages.lisp に依存

view raw hello.asd hosted with ❤ by GitHub

これで完成、です。UNIX系OSだったら

ln -s hello/hello.asd ~/ 

とでもして、hello.asdのシンボリックリンクをHOMEディレクトリに作成します。Windowsだったらasdf:*central-registry*で示唆されているフォルダ内にhello.asdへのショートカットを作成すれば良いでしょう。そしてREPLで(asdf:operate 'asdf:load-op :hello)とすれば(※)、

	CL-USER> (asdf:operate 'asdf:load-op :hello)
	; loading system definition from /home/cametan/hello.asd into
	; #<PACKAGE "ASDF0">
	; registering #<SYSTEM HELLO {AB3F071}> as HELLO
	NIL
	CL-USER>

view raw asdf-load-op-of-hello.lisp hosted with ❤ by GitHub

と表示されてシステムhelloは無事コンパイル/ロードされます。use-packageでhello-worldが使えるのか見てみましょう。

	CL-USER> (use-package :hello)
	T
	CL-USER> (hello-world)
	Hello, World!
	"Hello, World!"
	CL-USER> (symbol-package 'hello-world)
	#<PACKAGE "HELLO">
	CL-USER>

view raw test-of-hello-system.lisp hosted with ❤ by GitHub

上手い具合に動いていますね。シンボルhello-worldはエクスポートされてるんで、use-packageすればCL-USER内でhello-worldを参照出来る、と言う事です。

以上がASDFの基本的な定義方法の紹介です。

※: 繰り返しますが、Lipbox/Emacs + SLIMEだったらREPLでカンマ(,)、load-system、Enter、hello、Enter、です。

":depends on" in :components of a System

さて、今まで見てきた通り、これがASDFの定義方法の全て、です。んで、蛇足になり兼ねないんですが、システム内に一つのasdファイル、一つのpackages.lispファイルはともかくとして、本体のプログラムは複数の*.lispファイルに分散される場合がある、と言う事は自明だと思います。当たり前ですよね。

単純に、複数の*.lispファイルがある場合は、asdファイルの:componentsの欄に拡張子を外したファイル名を列挙すれば良い、って事です。必ずpackages.lispに依存している事を明記して。ただ、問題はそれら本体のファイル同士が何らかの形で依存している場合、です。

例えば、またクダラない例ですけど、hello-worldと言うプログラムが次のような二つのファイルに分散されている例を考えてみます。

	(in-package #:hello)
	(defparameter *h* "Hello, World!")

view raw string-of-hello-world.lisp hosted with ❤ by GitHub

	(in-package #:hello)
	(defun hello-world ()
	(princ *h*))

view raw body-of-hello-world.lisp hosted with ❤ by GitHub

body-of-hello-world.lispではプログラムhello-worldが定義されていますが、本体内で大域変数*h*が参照されています。そしてその*h*はこのファイル内では定義されていません。*h*は別のファイルであるstring-of-hello-world.lispで定義されている。つまり、言い方を変えると、body-of-hello-world.lispはstring-of-hello-world.lispに依存していると言う事です。

こう言う場合、asdファイルの:componentsの欄は次のように記述します。

	(defpackage :hello-system (:use :asdf :cl))
	(in-package :hello-system)
	(defsystem hello
	:name "hello"
	:author ""
	:version ""
	:maintainer ""
	:licence ""
	:description ""
	:long-description ""
	:components
	((:file "packages")
	(:file "string-of-hello-world" :depends-on ("packages"))
	;; body-of-hello-world.lisp は packages.lisp と string-of-hello-world.lisp に依存している
	(:file "body-of-hello-world" :depends-on ("packages" "string-of-hello-world"))))

view raw hello.asd hosted with ❤ by GitHub

:componentsの:fileの:depends-onはリストを取り、そこには複数の依存先ファイルを列挙出来ます。複数のファイルに依存する場合は、馬鹿正直に複数の依存先ファイル名を列挙すればO.K.です。

またREPLでhelloシステムが上手く動いているのかどうか見てみましょう。

	CL-USER> (asdf:operate 'asdf:load-op :hello)
	; loading system definition from /home/cametan/hello/hello.asd into
	; #<PACKAGE "ASDF0">
	; registering #<SYSTEM HELLO {B4E73E1}> as HELLO
	NIL
	CL-USER> (use-package :hello)
	T
	CL-USER> (hello-world)
	Hello, World!
	"Hello, World!"
	CL-USER> (symbol-package 'hello-world)
	#<PACKAGE "HELLO">
	CL-USER>

view raw test-of-hello-system.lisp hosted with ❤ by GitHub

上手い具合に動いてます。かつ、この時点ではpackages.lispに特に変更を加えていません。つまり、シンボルhello-worldはエクスポートされていますが、一方、大域変数*h*はエクスポートされていません。従って、CL-USERでhelloパッケージをuse-packageしても*h*は参照不可能です(※)。

	CL-USER> *h*
	The variable *H* is unbound.
	[Condition of type UNBOUND-VARIABLE]
	; Evaluation aborted.
	CL-USER>

view raw error.lisp hosted with ❤ by GitHub

もう一つ依存パターンを考えてみます。body-of-hello-world.lispには特に変更は加えませんが、string-of-hello-world.lispが別の二つのファイル、a.lispとb.lispに依存しているもの、とします。つまり、次の3つのファイルがpackages.lisp、body-of-hello-world.lisp、hello.asdと共にhelloディレクトリ内にある、とする。

	(in-package #:hello)
	(defparameter *a* "hello, ")

view raw a.lisp hosted with ❤ by GitHub

	(in-package #:hello)
	(defparameter *b* "World!")

view raw b.lisp hosted with ❤ by GitHub

	(in-package #:hello)
	(defparameter *h* (concatenate 'string *a* *b*))

view raw string-of-hello-world.lisp hosted with ❤ by GitHub

a.lispは大域変数*a*を定義、b.lispは大域変数*b*を定義していて、これらの間には相互依存関係はありません。一方、string-of-hello-world.lispは大域変数*a*と*b*を結合している。つまり、string-of-hello-world.lispはa.lispとb.lispに依存してるわけです。そしてbody-of-hello-world.lispはstring-of-hello-world.lispに依存してるんですけど、言い換えるとa.lispとb.lispに間接的に依存しているわけです。

こう言う場合のasdはどうなるのか、と言うと、次のようになります。

	(defpackage :hello-system (:use :asdf :cl))
	(in-package :hello-system)
	(defsystem hello
	:name "hello"
	:author ""
	:version ""
	:maintainer ""
	:licence ""
	:description ""
	:long-description ""
	:components
	((:file "packages")
	(:file "a" :depends-on ("packages"))
	(:file "b" :depends-on ("packages"))
	;; string-of-hello-world は packages.lisp、a.lisp、b.lispに依存している
	(:file "string-of-hello-world" :depends-on ("packages" "a" "b"))
	;; body-of-hello-world.lisp は packages.lisp と string-of-hello-world.lisp に依存している
	;; しかし、a.lisp と b.lisp への依存は明示しなくて良い
	(:file "body-of-hello-world" :depends-on ("packages" "string-of-hello-world"))))

view raw hello.asd hosted with ❤ by GitHub

ご覧のように、間接的に依存しているファイル名は明示しなくて構いません。あくまでpackages.lispのように、直接的に依存しているファイル以外は無視して結構です。従って、string-of-hello-world.lispの依存関係が解消された時点で、body-of-hello-world.lispはstring-of-hello-world.lispだけに依存している、と言うわけです。

※: 嘘です。ホントは無理矢理参照可能です。ただし、パッケージ、と言う名前保護のシステムの目的を考えると「エクスポートされていないシンボルを無理矢理参照する」と言うのは望ましくありませんし、実際、非推奨になっています。参照可能なシンボルは常にエクスポートされてる筈だ、と言う事で、ここでは「無理矢理参照する」方法は明記しません。

:depends-on the Other Systems

さて、今度はHOMEディレクトリにprint-name-of-functionと言うディレクトリを作成してみます。そこに次の三つのファイルを置いてみます。

	(in-package :cl-user)
	(defpackage :p-n-f
	(:use :common-lisp)
	(:export :print-name-of-function))

view raw packages.lisp hosted with ❤ by GitHub

	(in-package #:p-n-f)
	(defmacro print-name-of-function (str)
	(let ((name (map 'string #'(lambda (x)
	(if (string= x " ")
	#\-
	x))
	(remove-if-not #'(lambda (x)
	(or (string= x " ")
	(and (string<= "A" x)
	(string<= x "Z"))))
	(string-upcase str)))))
	`(defun ,(intern name) ()
	(princ ,str))))

view raw print-name-of-function.lisp hosted with ❤ by GitHub

	(defpackage :print-name-of-function-system (:use :asdf :cl))
	(in-package :print-name-of-function-system)
	(defsystem p-n-f
	:name "p-n-f"
	:author ""
	:version ""
	:maintainer ""
	:licence ""
	:description ""
	:long-description ""
	:components
	((:file "packages")
	(:file "print-name-of-function" :depends-on ("packages"))))

view raw p-n-f.asd hosted with ❤ by GitHub

前項までで見た通り、packages.lispではp-n-fと言う名前のパッケージを定義します。エクスポートするシンボルはprint-name-of-function.lispで使われるシンボル、print-name-of-functionです。

print-name-of-function.lispでは、関数を生成するマクロprint-name-of-functionを定義しています。このマクロは凄くクダラないんで、あんま解説したくないんですが(笑)、要するに適当な文字列を受けとると、

1. 文字列を全部大文字に変換する。


2. スペースと大文字のアルファベット以外を全て削除する。


3. スペースをハイフンに変換してこれを関数名としてインターンして、元々与えられた文字列を出力する関数を定義する。

だけです。クダラないんで、まあいいでしょう(笑)。これはこれとして(笑)。

p-n-f.asdもまあいいでしょう。基本的な設定方法にしか従ってません。またもや、UNIX系OSだったら、このp-n-f.asdのシンボリックリンクをHOMEディレクトリに張り(Windowsだったらasdf:*central-registry*で指定されたフォルダにショートカットを作り)、p-n-fシステムをREPLに読み込んでみます。

	; loading system definition from /home/cametan/p-n-f.asd into
	; #<PACKAGE "ASDF0">
	; registering #<SYSTEM P-N-F {B3F2391}> as P-N-F
	CL-USER> (use-package :p-n-f)
	T
	CL-USER> (macroexpand-1 '(print-name-of-function "Hello, World!"))
	(DEFUN HELLO-WORLD () (PRINC "Hello, World!"))
	T
	CL-USER> (print-name-of-function "Hello, World!")
	HELLO-WORLD
	CL-USER> (hello-world)
	Hello, World!
	"Hello, World!"
	CL-USER> (symbol-package 'hello-world)
	#<PACKAGE "COMMON-LISP-USER">
	CL-USER> (symbol-function 'hello-world)
	#<FUNCTION HELLO-WORLD>
	CL-USER> (symbol-package 'print-name-of-function)
	#<PACKAGE "P-N-F">
	CL-USER>

view raw test-of-print-name-of-function.lisp hosted with ❤ by GitHub

上手い具合に動いているようですね。ご覧になった通り、p-n-fパッケージにインターンされているシンボルを持つマクロprint-name-of-functionは受け取った文字列(この場合は"Hello, World!")を関数名に相応しいように修正し、それを今いるCL-USERパッケージ(「今いる」パッケージをカレント・パッケージと言います)にインターンして関数hello-worldを自動生成します。

もっとも、"Hello, World!"を印字する関数を作る為だけのマクロとしてはコード量がクソ多いんですけどね(笑)。全くしょーもない(笑)。でもこんな事も出来るわけです。

	CL-USER> (print-name-of-function "Fuck off!!!")
	FUCK-OFF
	CL-USER> (fuck-off)
	Fuck off!!!
	"Fuck off!!!"
	CL-USER>

view raw fuck-off.lisp hosted with ❤ by GitHub

くだんねえ(爆)。あんまりにもクダんないんで涙が出てきた(笑)。

ま、いっか(笑)。何故こんなクダラないマクロを作ったのか、と言うと、このprint-name-of-functionが定義されたp-n-fシステムをどうやってhelloシステムから呼び出すか、と言うネタが以降のネタなのです。要するに、システム同士の依存ってのが次のテーマです。

まず、helloディレクトリ内の改訂版packages.lispは次のようになります。

	(in-package :cl-user)
	(defpackage :hello
	(:use :common-lisp :p-n-f) ;パッケージ p-n-f も使用するように指定する
	(:export :hello-world))

view raw packages.lisp hosted with ❤ by GitHub

ここはまあいいですよね。ずーっと上の方にも書きましたが、ここでCOMMON-LISP以外にも必要になるパッケージがあったらそれも合わせてuseするって事です。今はp-n-fパッケージ(システムではない)が要り用になるのが前提なんで、p-n-fパッケージも指定しておきます。

次はプログラム本体部のコードです。今回はp-n-fパッケージに含まれているprint-name-of-functionマクロを使うのが前提なんで、ファイルhello-world.lispは次のようになっています。

	(in-package #:hello)
	(print-name-of-function "Hello, World!")

view raw hello.world.lisp hosted with ❤ by GitHub

簡単に定義出来ますが、もう一回次の二点を確認しておいてください。

1. packages.lispでhelloパッケージを定義している。そのパッケージは外部パッケージp-n-fからエクスポートしている全シンボルをuseしてるのが前提である。


2. hello.lispは一行目でhelloパッケージ内に移動する事を指定している。helloパッケージはp-n-fがエクスポートしている全シンボルを共有しているので、p-n-fパッケージで定義されているprint-name-of-functionマクロを使用可能である。

この二点が前提の為、ここでprint-name-of-functionを利用して関数hello-worldを定義出来るわけです。

最後にhello.asdです。それはこう言う風になります。

	;; hello-system 「自体で」 :p-n-f パッケージが要り用になるわけではない事に注意
	(defpackage :hello-system (:use :asdf :cl))
	(in-package :hello-system)
	(defsystem hello
	:name "hello"
	:author ""
	:version ""
	:maintainer ""
	:licence ""
	:description ""
	:long-description ""
	:components
	((:file "packages")
	(:file "hello-world" :depends-on ("packages")))
	;; 外部システムへの依存は :components 内ではなく、その外側の :depends-on で指定する
	;; 実際にここで指定してるのはシステムそのものではなく、外部システムの asd である
	:depends-on ("p-n-f"))

view raw hello.asd hosted with ❤ by GitHub

注釈を付けておきましたが、hello-systemと言うパッケージ自体がp-n-fパッケージに依存しているわけじゃありません。システム定義を良く考えてみたら分かりますけど、ここのパッケージはhelloパッケージにさえも依存していない、のです。あくまで、プログラムとしてのシステム全体を操作してるわけじゃなくって、単にファイルの読み込み順序や必要になる外部パッケージを指定してるのが、このシステムパッケージの役目だ、と言う事を覚えておいてください。

そして、必要になる外部パッケージは:components内で指定するのではなく、それとは別に:depends-onで指定します。ここで指定されてるのは外部システムそのものではなく、外部システム内に存在するasdファイルです。つまり、システムを纏めてあるディレクトリ自体を指定してるわけじゃあない、って事です。また、パス指定なんて高度な事をやってるわけでもありません。従って、要り用になる外部システムのasdファイルもasdf:*central-registry*にシンボリックリンクが張られている必要があります。この例だと、hello.asdのシンボリックリンクもp-n-f.asdのシンボリックリンクも(UNIX系OSでは)HOMEディレクトリ内に存在していないといけません。ASDFがhello.asdを呼び出した時、そこに書かれている定義に従って、asdf:*central-registry*内で、p-n-f.asdを探します。見つかったら、今度そこに書かれてある定義に従って、p-n-fパッケージをコンパイル/ロードします。見つからなかったらエラーを返す、と言う算段です(※)。

これで、(asdf:operate 'asdf:load-op :hello)したら、依存したシステムも合わせてコンパイル/ローディングされてCLに読み込まれます。

	; loading system definition from /home/cametan/hello.asd into
	; #<PACKAGE "ASDF0">
	; registering #<SYSTEM HELLO {B3DF161}> as HELLO
	; loading system definition from /home/cametan/hello.asd into
	; #<PACKAGE "ASDF0">
	; loading system definition from /home/cametan/p-n-f.asd into
	; #<PACKAGE "ASDF0">
	; registering #<SYSTEM P-N-F {AD9A771}> as P-N-F
	; compiling file "/home/cametan/hello/packages.lisp" (written 08 MAY 2010 11:33:31 AM):
	; compiling (IN-PACKAGE :CL-USER)
	; compiling (DEFPACKAGE :HELLO ...)
	; /var/cache/common-lisp-controller/1000/sbcl/local/home/cametan/hello/packages.fasl written
	; compilation finished in 0:00:00.114
	; compiling file "/home/cametan/hello/hello-world.lisp" (written 08 MAY 2010 11:35:41 AM):
	; compiling (IN-PACKAGE #:HELLO)
	; compiling (PRINT-NAME-OF-FUNCTION "Hello, World!")
	; /var/cache/common-lisp-controller/1000/sbcl/local/home/cametan/hello/hello-world.fasl written
	; compilation finished in 0:00:00.003
	CL-USER> (use-package :hello)
	T
	CL-USER> (hello-world)
	Hello, World!
	"Hello, World!"
	CL-USER> (symbol-package 'hello-world)
	#<PACKAGE "HELLO">
	CL-USER> (symbol-function 'hello-world)
	#<FUNCTION HELLO-WORLD>
	CL-USER>

view raw test-of-hello.lisp hosted with ❤ by GitHub

先ほど、直接REPLでprint-name-of-functionを使ってみた時と違い、定義された関数のシンボルhello-worldはパッケージhelloにインターンされている事に注目してください。関数internはカレントパッケージへとシンボルをインターンします。マクロprint-name-of-functionで関数hello-worldを生成したのはhelloパッケージ内、でした。従って関数生成時点では、カレントパッケージであるhelloへとシンボルhello-worldがインターンされたわけです。

※: ぶっちゃけ、Common LispでもSchemeでもパスの概念が丸っきりないんじゃないかって思う。歴史的に言うと、多分その通りで、そもそもこの二つはUNIX前提で生まれたわけではない。当然、ディレクトリ・ツリーなんて言うアイディアも元々UNIXのものなんで、そう言う概念には縛られてないのだろう。

特にCommon Lispの場合、そもそもこの規格がLisp OSのサブセットにあたる、と言う話である。かつ、「どのOSのシステムとも迎合化しない汎用のシステム」を目指したらしい。ワケ分かんね(笑)。

従って、良く分からないシステムを相手にする場合、この手のファイルのパス指定は、OS側に素直に任せておいて(例えばバッチスクリプト/シェルスクリプトを書く、シンボリックリンクを張る、とか)、CLやScheme内で解決しようとしない方が得策な感じがする。Rubyだったらこうはならねえんだろうな(笑)。

この辺に関しての話も、実践Common Lispの第14章や第15章辺りに記述が成されている。興味のある人はご一読を。

なお、ポール・グレアムがArcを作ろうと思った理由の一つは、現存主流OSとのこの手の相性の悪さにイライラしたから、らしい。また、ポール・グレアムはLispは好きだけどLisp OS嫌いで、Arc製作の段では「UNIXが勝った!」と気を吐いていた。いずれにせよ、Arcの目的の一つは、Perl/Rubyのように「UNIX系OSに密着した」Lispを作りたかった、と言う事らしい。

Well, that's almost all

まあ、これでASDFの殆ど全て、だと思います。知ってる範囲内では、と言う事ですけど。いずれにせよ、LOLやあるいはOn Lispを読んで勉強していきながら、どんどんASDFとして纏めて行った方がコードの再利用性を考えると得策だろう、と思います。ずーっとREPL開きっぱなしにしてるわけにも行かないしね(笑)。

最初の方にも書きましたが、CLでのexecutableの作り方、ってのは依然謎が多いです。個人的にはまだ良く分かっていません。経験上、executableを実験的に作って成功したのは、PLT Schemeのみ、と言う有様です(それでも謎が多いんですけど)。しかし、ソースファイルを含んだディレクトリをtarball(あるいはzip)に落としてアプリケーションを配布する、って夢に関して言えば、ASDFを用いればかなり近づける、とは思います。これは武器ですね。

最後に。アプリケーションを書く際、ディレクトリの中にサブディレクトリを配置して、それぞれをASDFに纏めるとする。でも全体で一つのアプリケーションとして動かしたい場合どうするか?その場合、トップディレクトリにアプリケーション名を冠したasdファイルを置いておけば暫定的に解決は出来るだろ、って事だけは言っときます。asdファイルは別のasdファイルを呼ぶことが出来るってのがヒントです。:componentとして、って事ですけれども。重要なのは全てのasdファイルがasdf:*central-registry*にシンボリックリンクを張っている、って事だけです。

LOL SEGMENT-READER

第3章。リードマクロよりSEGMENT-READER。
これも書くんなら、末尾再帰の方がエエんちゃうの?と思ったケース。

	;;; SEGMENT-READER
	;; Scheme-style
	(defun segment-reader (stream ch n &optional (acc nil))
	(labels ((iter (chars curr)
	(if (char= ch curr)
	(coerce (reverse chars) 'string)
	(iter (cons curr chars) (read-char stream)))))
	(if (< n 1)
	(reverse acc)
	(segment-reader stream ch (1- n)
	(cons (iter nil (read-char stream)) acc)))))

view raw segment-reader.lisp hosted with ❤ by GitHub

Doug Hoyte氏は「効率」を考えてdoを使ってんのかな?と思わせておいて、いきなり普通に再帰する、と言うワケの分からん事をする。この人のスタイルは、ぶっちゃけ支離滅裂なんだよな(苦笑)。
例えば、まあ、冗談として聞いて欲しいんですが、マジメに効率考えてdoを使え、ってのなら徹底して次のようにして書く事も可能なんです。

	;;; SEGMENT-READER with DO
	(defun segment-reader (stream ch n)
	(do ((n n (1- n))
	(acc nil
	(push
	(do ((curr (read-char stream)
	(read-char stream))
	(chars nil (push curr chars)))
	((char= ch curr) (coerce (nreverse chars) 'string)))
	acc)))
	((< n 1) (nreverse acc))))

view raw segment-reader-with-do.lisp hosted with ❤ by GitHub

冗談ですけどね(笑)。こんなコード読むの大変ですし。書くのも大変。ただ、分かって欲しいのは、そもそもdoの性質からしてletが要らないだろって事です。letが要らなければ本体部も要らない、っつー事です。

	CL-USER> (segment-reader t #\/ 3)
	あいう/えおか/きくけ/
	("あいう" "えおか" "きくけ")
	CL-USER>

view raw evaluation-of-segment-reader.lisp hosted with ❤ by GitHub

LOL SHARP-DOUBLE-QUOTE と SHARP-GREATER-THAN

実験も兼ねて。

valvallowさんを真似て、github使ってみようかな、と。
まあ、単に今のままでは、ブログにコード貼り付けると、<pre>タグ使っててもインデントがズレて嫌なわけですよ。どうにかなんねえのかな、とか思ってて。
んで、valvallowさんがgist使ってうまい具合にやってるんで、それを真似してみよう、って思ったわけです。で、まあ、gitそのものは要らなかったよね(笑)。gistとgitって違うみてえ(笑)。レポジトリ、なんて作らんで良かった、って話なんですが(笑)。単にアカウント取れば良かっただけの話、と言うオチ(笑)。

それはさておき。LOLをvalvallowさんに続いて読んでるわけですが。他の人の意見はともかくとして読みづれえ。
いや、地の文体がどーの、って話じゃないです。単にコードが読みづらいって話なんだよな(苦笑)。精読試みると引っかかっていけねえや。
第3章、リードマクロからもうこれが破壊的操作の嵐でさ(苦笑)。こんなんここまでやる必要あんのか?とかぶっちゃけ思ってしまいました。もちろん、効率性考えれば必要になるケースってのがあるんですが、僕が思うトコ、この著者って美的観点ってのが全くねえんじゃねえの、とか思ってるのです(笑)。不遜ですけどね。
いやね、実際問題。無頓着にコード書いてるようにしか見えないし、心情的にはSchemerの筈のポール・グレアムも「こりゃあねえだろ」と思うんじゃねえのかな、と(笑)。そこまでいかんでも、ここに列挙されてるコードを他の言語のユーザーが見たら

「不必要に括弧が多すぎ！これだからLisperはよお。」

とか思うんじゃねえのか、と(笑)。ケンケンガクガクですよ(笑)。マジな話でさ。

リードマクロって考え方自体は単純ですよね。単に関数書いてやって、それをset-dispatch-macro-characterで文字指定してやってその関数と関連付けちゃえばおしまい、です。普通にマクロ書くよりラクかもしれませんね。set-dispatch-macro-characterって長ったらしい名前もEmacs + SLIMEだったらEsc-Tabで補完しちゃえばラクラク記述可能です。Viva! Emacs!
問題はその関数の書き方だ。個人的には川合史朗さんが何でも再帰で記述してたような「ローカル関数を設計」してやった方が見た目スッキリすんじゃねえの?とか思うんですけどねえ。生粋のCLerだと違うのかな。doは副作用使う時は確かに便利なんですけど、このケースじゃそんなの多用する必然性がそんなねえんじゃねえの、って思いました。

	;;; SHARP-DOUBLE-QUOTE
	;; Scheme-style
	(defun |#"-reader| (stream sub-char numarg)
	(declare (ignore sub-char numarg))
	(labels ((iter (chars prev)
	(let ((curr (read-char stream)))
	(if (and (char= prev #\") (char= curr #\#))
	(reverse chars)
	(iter (cons prev chars) curr)))))
	(coerce (iter nil (read-char stream)) 'string)))
	(set-dispatch-macro-character
	#\# #\" #'|#"-reader|)

view raw sharp-double-quote.lisp hosted with ❤ by GitHub

まず最初。LOLのSHARP-DOUBLE-QUOTEを書き直したものです。多分Schemeやってる人はこっちの方が見やすいのでは、と思います。オリジナルのコードは破壊的操作しまくりですが、そのテの操作は一切止めています(笑)。
そもそも、Doug Hoyteって人はdefunの「暗黙のprogn」アテにし過ぎだろ、って気もしますしね。これは本読むと、結局欲しいのは(coerce (nreverse chars) 'string)なんですけど、これは単にdoの返り値にした方がいいんじゃねえの、って謎がまずあって。要するにオリジナルのコードはcharを破壊的にdoで弄くっていって、それはそれでほっといて、最後に(coerce (nreverse chars) 'string)なわけですよ。何じゃそりゃ、とか思って(笑)。Lispがどうの、って以前にそれじゃあ手続き型言語のfor文の書き方だろ(笑)。
一方、ignoreはCLHS見ても良く分かんなかったんで、そのまま挿入しています。ロジック考えると必ずしも必要である、とは思えないんですけどね。多分。ま、いいや、その辺はCLの流儀、と言う事で。

	CL-USER> #" " と \. を含みます。"#
	" \" と \\. を含みます。"
	CL-USER>

view raw evaluation-of-sharp-double-quote.lisp hosted with ❤ by GitHub

ってな感じで「Schemeっぽく」書いても問題なく動きますね。では次。

	;;; SHARP-GREATER-THAN
	;; Scheme-style
	(defun |#>-reader| (stream sub-char numarg)
	(declare (ignore sub-char numarg))
	(labels ((foo (chars curr)
	(if (char= #\newline curr)
	(reverse chars)
	(foo (cons curr chars) (read-char stream))))
	(bar (curr pattern pointer output)
	(if (null pointer)
	(reverse (nthcdr (length pattern) output))
	(bar (read-char stream) pattern
	(if (char= (car pointer) curr)
	(cdr pointer)
	pattern) (cons curr output)))))
	(let ((pattern (foo nil (read-char stream))))
	(coerce (bar (read-char stream) pattern pattern nil) 'string))))
	(set-dispatch-macro-character
	#\# #\> #'|#>-reader|)

view raw sharp-greater-than.lisp hosted with ❤ by GitHub

これも原版のコード見ても何が何だか……(苦笑)。いやあ、凹みましたよ(笑)。これもDoug Hoyte氏の手癖か何だか知らないんですが、やっぱりdefunの暗黙のprogn頼みのコードで。かつ破壊的操作をしまくりなんで、何が目的でどう操作してるのか、流れが掴み辛い。あんなにインデントが深くなる必要って全然ない、と思うんですけど。これも再帰に書き換えて、引数内処理した方がスッキリ決まるんじゃないか、って思いました。
暗黙のprogn頼みが何なのか、と言うと。要するに、データをループ回して操作して。それを置き去りにしてまた別にデータ持ってきてループ回してるわけです。それを逐次処理するってのがオリジナルのコードの狙いなわけですが。必要か、それ?とか思ってさ(笑)。
しかも脱出条件が良く分からん。何で(null pointer)が二ヶ所に渡って分散してんだか、皆目見当が付かなかった(笑)。「何じゃこりゃ?」ってのが正直なトコで。破壊的操作を無自覚に使ってるからそーなるんだとしか思えなかった(笑)。
そこで、上の関数ではローカル関数fooとbarを二つ作って凌いでいます。根本的に、この二つの関数って「独立」で構わないんですよ。オリジナルのコードでも最初のループって、結局一種のフラグ作りなんですよね。本当にやりたい事は後者のループが握ってるんです。だから、シンプルにfooでフラグを作って、barで本操作をする、って設計にしました。やりようによってはもっとシンプルに書けるやもしれません。

	CL-USER> #>END
	ここには何でも置けますよ: "、\、"#、や ># だって
	置けちゃう。この文字列の読み込みを終わらせるには...END
	"ここには何でも置けますよ: \"、\\、\"#、や ># だって
	置けちゃう。この文字列の読み込みを終わらせるには..."
	CL-USER>

view raw evaluation-of-sharp-greater-than.lisp hosted with ❤ by GitHub

#9LISP 014 メモ

#9LISP はいよいよマクロを通してCommon Lispに突入するそうです。ぶっちゃけ「良かったな」と(笑)。

@valvallowさんと、

「LOLを参考にして、Forth実装を通してPostScriptがSchemeで実装出来たらいいね。」

とか言ってたんですが。無茶苦茶メンド臭い。ハッキリ言って「無理じゃね?」とか思って来てました。多分僕はヘタレなのでしょう。ええ、間違いなく。それは否定しない。

まあ、でも多分一番問題なのは、Schemeには標準仕様としてmacroexpandが定義されていないに尽きると思います。手探りでマクロ展開形を想像しながらやる、ってのはシャレにならんのですよ。CLerが

「Schemeの仕様は貧弱だ」

と言う批判をするのは、この辺に付いては妥当だと思います。マクロ書くのに展開形が見れない、ってのはLisp系言語仕様設計としてはポイントがズレまくってます。困ったもんだ。

そんなわけで、「CLで伝統的マクロやる?万歳！」とか思ったんですね。率直な感想です。

※1: もっとも「あらゆる実装でmacroexpandが無い」と言う気はありません。むしろ実装依存ならあるって言った方が正しいです。

が。こう言う重要な機能が実装依存だ、ってのがぶっちゃけ納得出来ません。話によれば衛生的マクロのmacroexpandは実装が難しい、と言う話なんですが、だったら片手落ちにも程があるだろ、と。いや、納得せんぞ(笑)。その辺実装者側に投げて良い、って事もねえだろ、と。

Gaucheにはmacroexpandがあって、Guileはザーっとマニュアル見た限り存在せず、PLT Schemeはワケワカメです。

※2: 余談ですが、PLT のメーリングリストにも「PLTにはmacroexpandがないの?」ってトピックがあって、回答者側の一人が

「DrSchemeのMacro Stepper使ってみろよ?macroexpandなんて使う気にならなくなるから。」

とかとても能天気な事を書いています(笑)。

実際、狙ったマクロ「だけ」を展開出来て、一見優れものに見えるんですが、

• 実はPLTのメイン処理系であるMzSchemeでは動かない。Emacsで使う場合はわざわざMzSchemeを止めて、もう一つの処理系MrEdを呼び出さないと使えない。


• その上、一々ライブラリとして(require macro-debugger/expand)しないといけない。


• 構文が
  

  
  (syntax->datum
   (expand-only #'展開したい式
         (list #'展開したいマクロ名<複数列挙可>))))
  

  
  と打つのがメンド臭い程長い。
  

と三重苦です。マジな話やってられません。

Common Lisp実装

んで、次回までANSI Common Lisp処理系を入れようと言う話です。 #9LISP で話に上がったANSI CL処理系は次の4つ。メモしておきます。

• CMUCL: 米国カーネギー・メロン大学で開発されたANSI Common Lisp処理系(だからそのままCarnegie Mellon University Common Lisp)。ただし、現時点での開発継続は有志による筈。LOL一押しの処理系。CLのフリー実装としては1、2位を誇る処理速度を叩きだし、同じくフリー処理系のSBCL(後述)や商用のScieneer Common Lispのルーツである。
  
  ただし、基本的にWindowsはサポートしていない、UNIX用に特化した処理系と考えて良い。また、UNICODEもサポートしていない。
  


• SBCL: CMUCLから友好的にフォークしたフリーのANSI Common Lisp処理系。CMUCLに独自に拡張を加えたもの、として考えて良い。CMUCLもSBCLもコンパイラはPythonと呼ばれるネイティヴコンパイラを使用している(LLのPythonとは無関係で、CMUCL/SBCLのユーザーは「あっちが後だ！」とたまに話を蒸し返す・笑)。
  
  最大の特徴はCMUCLと違い、UNICODEが扱える事。従って、次のようなコードを書いても良い。
  

  
  CL-USER> (defun のりピー (symb)
      (eq symb '酒井法子))
  のりピー
  CL-USER> (のりピー '酒井法子)
  T
  CL-USER> (のりピー '小倉優子)
  NIL
  CL-USER> 
  

  
  日本語が扱えるフリーの最速処理系だと思われる。また、実験的だがWindows版も提供している。
  
  なお、SBCLはSteel Bank Common Lisp(鉄鋼-銀行 Common Lisp)の意。カーネギー・メロン大学の創設者の一人、アンドリュー・カーネギーが鉄鋼で財を成し、もう一人のアンドリュー・メロンは銀行業で財を成した事に由来する。
  


• GNU CLISP: ドイツ製ANSI Common Lispのフリー処理系。1987年にATARI STで開発されたものが初版。readlineの使用に関してFSFのリチャード・ストールマンと揉め、後にGNUに寄贈される。
  
  特徴は、ソースのコンパイルを行うと、ネイティヴ・コードではなく、バイト・コードへとコンパイルする。故に実行速度よりオブジェクトコードの移植性を重視した実装となっている。スピードはCMUCL/SBCLに劣るが、竹内関数でのベンチマークを試してみると、コンパイルされたコードの実行速度はScheme実装Gaucheとさほど変わらなかった。故に、SchemeのGaucheが速い、と感じるなら、問題は特に無いと思われる。また、UNICODEにも対応している。
  
  WindowsだろうとUNIXだろうとどこでも動くので、世界で一番使われているフリー実装だと思われる。また、ポール・グレアムが作ったVia WebはCLISPを使っていた。Arcの最初の実装もCLISPで書いたらしい。
  
  開発はまあまあ活発で、ヴァージョンアップは大体定期的で、一年に一回くらい。


• ABCL: Armed Bear Common Lisp。JavaによるANSI Common Lispのフリー実装。開発が活発なのかそうじゃないのか、いまいち良く分からない。
  
  ちなみに一時期、Ubuntu 7.04～7.10辺りのレポジトリに入っていたが、今は消えてしまった。人気がないのか?良く分からん実装である。

とまあ、主観交えて書けばこんな感じでしょうか。お勧めはPC-UNIXだったらSBCL、Windowsだったら素直にCLISPにしとけば基本問題無い、と思います。Macは良く知らん。

どの実装を選ぶか、ってのは頭が痛い問題なんで、ぶっちゃけ、オールインワンのLispbox入れときゃ充分なんじゃねえの?とか思います。その方が設定で面倒臭い思いしなくて済みますしね。

	OS X (10.4/PPC)	OS X (10.4/Intel)	GNU/Linux x86	GNU/Linux x86-64	Windows
Allegro	8.1	8.1	8.1	8.1	8.1
SBCL	0.9.7	—	0.9.7	—	—
Clozure CL	1.0	1.0	—	—	—
CLISP	2.35	—	2.36	—	2.37

Common LispとSchemeの大まかな違い

SchemeはLisp-1、Common LispはLisp-2である

多分 @aharisu さんだったと思いますけど「Common LispとSchemeの違いって何?」と言う質問に対して、

「SchemeはLisp-1だけどCommon LispはLisp-2です」

って即答してました。多分一言で言うとそうだろうと思います。両者ともレキシカル・スコープを採用したLispですが、そうなると一言で言える違いはコレになるでしょう。もちろん、細かい話では色々な違いが出てきますが。

Lisp-2は名前空間を二つ持ち、片方を演算子に使い片方を変数に使う。一方、Lisp-1の名前空間は1つだ。

実践Common Lisp

実際、Common Lispの方は名前、つまりシンボルの衝突を避ける為に神経質なまでに繊細な設計を行っています。逆に言うと、設計が繊細なお陰でユーザーはあまり面倒臭い事を気にかける必要がありません。大雑把にいられる。

例えば、このページで紹介されてる例が良い例だと思います。

;;; Common Lisp の場合
CL-USER> (setf sin 1.0)
; 
; caught WARNING:
;   undefined variable: SIN
; 
; compilation unit finished
;   Undefined variable:
;     SIN
;   caught 1 WARNING condition
1.0
CL-USER> (sin sin)
0.84147096
CL-USER>

;;; Schemeの場合

> (define sin 1.0)
> (sin sin)
procedure application: expected procedure, given: 1.0; arguments were: 1.0

 === context ===
/usr/lib/plt/collects/scheme/private/misc.ss:74:7

> 

SBCLだと警告が出ますが、それでも(sin sin)なんてヘンな式でもへーキで実行してしまいます。S式の第一要素は関数、第二要素は変数だ、と賢く解釈してくれるから、です。一方Schemeはそうしてくれません。何故なら、sinを1.0で束縛してしまった以上、sinはもはや手続きじゃなくなってしまったのです。

シンボル

上のsinみたいなのをシンボルと呼ぶわけですが。Lispの特徴としてはこのシンボルがデータ型であると言うのが前提なんですが、結局このシンボルの扱いがCommon LispとSchemeでは大きく違うわけです。

Schemeの仕様書(R5RS)には次のように定義されています。

シンボルとは，二つのシンボルが(eqv? の意味で) 同一なのは名前が同じようにつづられるときかつそのときに限られるという事実に，その有用性がかかっているオブジェクトである。これはまさに，プログラムで識別子を表現するために必要とされる性質であり，したがってScheme の大多数の実装はシンボルを内部的にその目的のために利用している。シンボルは他の多くの応用にも有用である。たとえば，列挙値をPascal で利用するのと同じ用途に，シンボルを利用してもよい。

色々ゴチャゴチャと書いていますが、要するに、

1. 各シンボルはプログラム中で「唯一無二の存在」でなければならない。


2. じゃないと識別子として役に立たない。


3. つまり、シンボルは「名前を識別する為だけに」存在する。

と言ってるんですね。言わば当たり前の事を言ってるんですが。他の言語鑑みてもわざわざシンボル型なんてデータ型が存在しなくても良いくらいアッサリしています。

ところが、Common Lispの場合、シンボル自体に機能がある。詳しい事はCLHSを見てほしいんですが、端的な表現としてはシンボルに対してアクセサが3つも定義されている。C的に言うとまるで、シンボルは構造体で定義されているデータ型の如し、です。

• symbol-function


• symbol-value


• symbol-plist

例えば上のように(setf sin 1.0)とREPL上で評価した後、次のように、

CL-USER> (symbol-function 'sin)
#<FUNCTION SIN>
CL-USER> 

とすればsinと言う組み込み関数が束縛されている事が分かります。

続いて次のようにすれば、

CL-USER> (symbol-value 'sin)
1.0
CL-USER> 

sinに1.0が束縛されている事が分かります。つまり同一のsinと言うシンボルが二つの役割を担っていると言う事が明らさまに分かる。要するに、名前空間が二つ存在しているんです。

んじゃあ、最後のsymbol-plistってのは何なのか?本筋にあんま関係ないんで端折って書いておくと、シンボルはついでに属性リストと言う特別なリストを「内部構造として」持つことが可能なんです。symbol-plistはそいつをリテラルとして引っ張り出すアクセサです。

例えば大域変数として次のようなメンバー名のリストとする9lispを定義します。

CL-USER> (defparameter 9lisp '(valvallow mutronix 堀 田中克之 そーり shunsuk gibson cametan sakurako_s _Relm koki-h AKIRA))
9LISP
CL-USER> 9lisp
(VALVALLOW MUTRONIX 堀 田中克之 そーり SHUNSUK GIBSON CAMETAN SAKURAKO_S _RELM KOKI-H
 AKIRA)
CL-USER> 

シンボルを大域変数で定義した場合、REPLでシンボルを評価した結果とsymbol-valueでシンボルにアクセスした結果は同じです。

CL-USER> 9lisp
(VALVALLOW MUTRONIX 堀 田中克之 そーり SHUNSUK GIBSON CAMETAN SAKURAKO_S _RELM KOKI-H
 AKIRA)
CL-USER> (symbol-value '9lisp)
(VALVALLOW MUTRONIX 堀 田中克之 そーり SHUNSUK GIBSON CAMETAN SAKURAKO_S _RELM KOKI-H
 AKIRA)
CL-USER> 

ところが、シンボル9lispはここで定義したリストと別の属性リスト(キーとデータが交互に並んだリストの事)を内部に持つことが出来ます。

CL-USER> (setf (get '9lisp :parent-group) 'KPF
        (get '9lisp :通称) '9lisp
        (get '9lisp :explanation) '九州熊本を中心にLISPの勉強会を開催しています
        (get '9lisp :開催) '隔週
        (get '9lisp :オンライン参加) t)
T
CL-USER> (symbol-plist '9lisp)
(:オンライン参加 T :開催 隔週 :EXPLANATION 九州熊本を中心にLISPの勉強会を開催しています :通称 9LISP
 :PARENT-GROUP KPF)
CL-USER> 

そして、先ほど大域変数として値を与えた9lispとその内部構造である属性リストは、当然ながら名前を共有しながら全く別物なんです。

CL-USER> 9lisp
(VALVALLOW MUTRONIX 堀 田中克之 そーり SHUNSUK GIBSON CAMETAN SAKURAKO_S _RELM KOKI-H
 AKIRA)
CL-USER> (symbol-plist '9lisp)
(:オンライン参加 T :開催 隔週 :EXPLANATION 九州熊本を中心にLISPの勉強会を開催しています :通称 9LISP
 :PARENT-GROUP KPF)
CL-USER> (equal 9lisp (symbol-plist '9lisp))
NIL
CL-USER> 

とまあ、Common Lispに於いてはシンボルは最低でも3つの役割を担っています。ただし、最後の属性リストに関して言うと、ポール・グレアムは、

なお、Common Lispでは属性リストはあまり使われない。ハッシュ表を使うことがはるかに多い。

ANSI Common Lisp

と記述しています。と言うわけで、属性リストは使わなくても構わないらしいですが、同時にここではANSI Common LispにはSchemeでは存在しないハッシュ表も存在すると言う事が分かります。

いずれにせよ、同一のシンボルに対して最低でも3つの役割を持たせているのがANSI Common Lispで、これだけに限らず、たとえ同一のシンボルが存在しようと可能な限り衝突を避けようと設計されているのがANSI Common Lispの仕様です。ここでは立ち入りませんが、パッケージと言う仕組みがあって、何重にもシンボル衝突を回避しようとしてる。そしてそれが実はANSI Common Lispの設計上の肝なんです。

比較するとSchemeのシンボルはANSI Common Lispに比べるとお粗末、と言えばお粗末です。黒板の人の

(quote a) と入れたら A と返ってくるのが symbol なわけではなくて、 symbol っちゅうものは、そもそもプログラマから見れば first class object であって、 package に intern したり unintern したり、他の package から inherit したり、 shadow したり、 export したり import したりできるもの。それが symbol です。
Scheme には、この symbol がありません。

と言うScheme批判はこの辺なんですよね。少なくとも今まで見た通り、Schemeのシンボルだと出来る事は殆ど無いに等しい、と言う事ですから。

写像関数と関数適用の例

さて、名前空間が二つある、と言う事はシンボルが表すものが最低2つはある、と言う事です。その辺でSchemeと若干作法が変わってきたりします。代表的なトコで写像関数を見てみましょう。

Schemeでは写像手続きはmapですが、ANSI Common Lispでそれに一番近いものはmapcarでしょう。

そこで次のような問題を考えます。

要素がリストであるリストがある。各要素のcarを取ったリストを返せ。

Schemeだったらこう書くでしょう。

> (map car '((Google YouTube) (ニワンゴ ニコニコ動画)))
(Google ニワンゴ)
> 

ところが、これがCommon Lispじゃあ上手く動かない。

CL-USER> (mapcar car '((Google YouTube) (ニワンゴ ニコニコ動画)))
The variable CAR is unbound.
   [Condition of type UNBOUND-VARIABLE]
; Evaluation aborted.
CL-USER> 

何と「変数carは未束縛です」と文句を言ってくる。これは何故かというと、ANSI Common LispではS式の第一要素に置かれたシンボルに付いては素直に「関数」だと解釈してくれるんですが、第二要素以降に付いてはデフォルトでは必ず「変数」だ、と解釈してくるんです。一方、Lisp-1であるSchemeでは、S式のどこに手続きとして定義されたシンボルを置いても、手続きは手続き、なわけです。この辺がCommon LispとSchemeでは食い違ってくるんです。

そこで、ANSI Common Lispでは、S式の第二要素以降に置いたシンボルが変数なのか関数なのか、処理系に知らせてやらないとならない。上の問題はANSI Common Lispではこう書きます。

CL-USER> (mapcar #'car '((Google YouTube) (ニワンゴ ニコニコ動画)))
(GOOGLE ニワンゴ)
CL-USER> 

carの前に置いた記号はそのままシャープクオートと呼びます。これ、実際は省略記法で、@valvallowさんに「何の省略記号だっけ?」と訊かれてぶっちゃけ忘れてたんですけど(笑)、functionと言う特殊オペレータ(Schemeで言う特殊形式)の省略記法ですね。故に上の式は次と等価です。

CL-USER> (mapcar (function car) '((Google YouTube) (ニワンゴ ニコニコ動画)))
(GOOGLE ニワンゴ)
CL-USER> 

実際(function 何とか)とか書いてられねえけどな(笑)。メンドっちくて(笑)。だから#'だけ覚えていてその意味忘れてた僕は責められないと思う(笑)。多分(笑)。

いずれにせよ、ANSI Common Lispでは、写像関数を含む高階関数が関数引数を取る場合、渡す関数引数には#'を付ける、と覚えておきましょう。

ANSI Common Lispでの関数定義

実際Schemeは変わった言語で、事実上、例えばPascal的な意味での「手続き定義」の様式を持ちません。特殊形式defineが行ってるのはシンボルとデータ(つや～な言い方をするとオブジェクト)を結びつけてる(束縛)してるだけ、です。当然λ式で形作られるクロージャもデータなんで、全ての「値」を一元的に扱える、と言うのがSchemeの特徴なわけです。

> (define a 1)    ;シンボル a と数値 1 を結びつけた例
> a
1
> (define fact    ;シンボル fact と クロージャを結び付けた例
    (lambda (n)    ;これが Scheme に於ける手続き定義の基本となる
      (letrec ((iter
  (lambda (m acc)
    (if (zero? m)
        acc
        (iter (- m 1) (* m acc))))))
 (iter n 1))))
> fact
#<procedure:fact>   ;Scheme に於ける手続きリテラルの例
> 

一方、Lisp-2であるANSI Common Lispの場合、シンボルには複数の役割がある、と言う事を既に見ました。従って、表層的にせよ、変数定義と関数定義は分かれてなければならないと言う要請が出てきます(※)。ANSI Common Lispで用いられる関数定義の為のマクロがdefunです。

CL-USER> (defun fact (n)
    (labels ((iter (m acc)
        (if (zerop m)
     acc
     (iter (1- m) (* m acc)))))
      (iter n 1)))
FACT
CL-USER> (symbol-function 'fact)
#<FUNCTION FACT>
CL-USER> 

一見、SchemeのMIT記法による手続き定義の構文糖衣に似てますね。並べて比べてみれば分かると思います。

ANSI Common Lisp の関数定義の例	Scheme の手続き定義の例
(defun fact (n) (labels ((iter (m acc) (if (zerop m) acc (iter (1- m) (* m acc))))) (iter n 1)))	(define (fact n) (letrec ((iter (lambda (m acc) (if (zero? m) acc (fact (- m 1) (* m acc)))))) (iter n 1)))

パラメータリスト(引数リスト)に関数名/手続き名を表すシンボルが第一要素として含まれるか否か、って辺りだけが違います。ANSI Common Lispの場合は含まない、SchemeのMIT型構文糖衣だと含む、と言うのが違いです。

実際問題、SchemeとCommon Lisp行き来してると、この辺良く間違うんですよ(笑)。手癖と言うか(笑)。関数定義/手続き定義をやってエラーが出て、一瞬、

「あれ?どこ間違えたんだろ?」

ってクダラないトコで悩む事が良くあります(笑)。僕だけか(笑)?

※: 本当は出てきません。あくまでユーザー的に表層では、と言う事です。

Common Lispの大域変数定義

Lisp-1とLisp-2に絞って大まかなSchemeとANSI Common Lispの違いを見ると、残るは大域変数だけ、です。が、これがややこしいんで端折ります。

Schemeの場合、結局何でもdefineなんですが、ANSI Common Lispの場合は大域変数定義には次の3つがあるんです。

• defvar


• defparameter


• defconstant

んで、これらの使い分け、ってのが細かくてぶっちゃけピンと来ていません(笑)。実際僕だけでもないみたいで、defconstantはともかくとして、defvar派とかdefparameter派、みたいなのがいたりする模様です(※)。

ザーッと手元の資料見てみても、割に実践Common Lispが一番詳細に解説してたりしますね。が、長いんで転載出来ません(笑)。英語で良ければ原書の第6章辺りを参考にしてください。

※:本によって解説が偏ってる、ってのは事実。例えばポール・グレアムは「自分の好きな機能」に関してはページを多く割く傾向があって、defvarはあんまり使わないんだけどdefparameterは良く使う、ってのが見て取れる。他の本も大同小異だったりする。

CLerの間でこの手の「バカに豊富な機能のどれを使うか?」と言うので意見が分かれる事が良くあるようで、例えば簡単なトコでは等価述語であるeqとeqlに対しても「何でもeq派」と「何でもeql派」に分かれているらしい。前者はスピード重視派、後者はデフォルト推奨派、ならしい。

ちなみに、Emacs Lispにはdefparameterやdefconstantは存在しない模様でビックリした。恐らくこの中ではdefvarが歴史的には一番由緒正しいのだろう。

Common LispとSchemeのちょっとだけ細かい違い

ではもうちょっとだけANSI Common LispとSchemeの違いを見てみましょう。これらはtrivialな話ではなくって、実際SchemeからはじめてCommon Lispへと進んでプログラムを書く場合、場合によっては障害となるんじゃないか、と言う個人的な観点に絞ります。

ANSI Common Lispはどんな形であれ値を返す

Schemeの仕様書を見ていくと、意外と「返り値は未定義である」と言う表現を多く見かけます。それが結構多くて困った事が多いんですが(実際多い)、一方、ANSI Common Lispは、一見無意味に見えるものでも必ず値を返します。代表的なところは出力関数でしょうか。

Common Lisp の format 関数の例	Scheme の display 手続きの例
CL-USER> (format t "~A~%" "Hello, World!") Hello, World! ;表示 NIL ;format の返り値自体は nil CL-USER>	> (display "Hello, World!\n") Hello, World! ;Hello, World! は表示だが、display の返り値は未定義 >

一見無意味に見えるんですが、Common Lispの出力関数formatは返り値があります。一方、Schemeのdisplayの返り値は未定義です。

「どんな場合でも何らかの値を返す」と言う事の信頼性は重要です。ANSI Common Lispに関して言うと、信頼して構わない、と言う事です。

ANSI Common Lispの真偽値

ANSI Common Lispでの真値はt、偽値はnilで表され、Schemeではそれぞれ#tと#fで表されます。

これだけ見ると大した違いが無いように見えるんですが、どころがどっこい。ANSI Common Lispでは次のようなルールが存在します。

• 空リストはnilの事である。


• nilはユニークなシンボルである。


• 論理上、nilでないものは、全てtである。

従ってANSI Common LispとSchemeでは次のような食い違いが起こります。

ANSI Common Lispの場合	Schemeの場合
CL-USER> (null '()) T CL-USER> (not '()) T CL-USER>	> (null? '()) #t > (not '()) #f >

実はANSI Common Lispではnullとnotは同機能異名の関数なんですが、Schemeではnull?は空リスト判定用述語、notはあくまで真偽値判定用述語です。そしてSchemeに於いては空リストは#fではない。要するにANSI Common LispとSchemeではブーリアンの体系が違うんですよね。Schemeはいわゆる普通のプログラミング言語と同様に、ブーリアン用の体系があるわけですけど、ANSI Common Lispはちょっとしたハックに見える。

従って、ANSI Common Lispでは次のような一見わけの分からない事が可能です。

CL-USER> (cons 1 (> 2 3))
(1)
CL-USER> 

(> 2 3)は偽なんでnilを返すわけなんですけど、それはすなわち空リストです。そこに1をconsして、リストにしちゃう……。「こんなんで大丈夫なのか?」とか思うでしょうが、実はこのnilの性質は色んな局面で結構役に立ちます(※)。プログラムが短くなったりするんですよ。

※: ちなみに、僕が最初に触ったのはANSI Common Lispの方で、「随分大雑把な設計だな」とか感じました。が、慣れると病みつきになって、最初Schemeを触った時は#t、#fの存在がどうにも馴染めませんでした。っつーか、ハッキリ言うと嫌いだった。

例えば、The Little Schemerに次のようなお題があるらしいんですけど。

;;; The Little Schemer の member? の回答例
> (define (member? a lat)
    (and (pair? lat)   ;いちいちlatがどうなのか検査しなければならない。
  (or (eq? a (car lat))
      (member? a (cdr lat)))))
> (member? 'a '(f u c k o f f!))
#f
> 

ANSI Common Lispだったら次のように書けます。

CL-USER> (defun member? (a lat)
    (and lat   ;これだけで充分
  (or (eq a (car lat))
      (member? a (cdr lat)))))
MEMBER?
CL-USER> (member? 'a '(s o n o f a b i t c h !))
T
CL-USER> (member? 'a '(f u c k o f f !))
NIL
CL-USER> 

リスト再帰は構造上、ベースケースとして空リストが停止条件になる場合が多いんですが、空リスト=nilと定義しているCommon Lispではこの性質が大活躍します。上の例だと、andがnilを見つけると即刻評価を中止してnilを返すのが肝なんですけど、latはリストである事が前提で、かつ、そこに対して特殊な判定は必要ないわけです。latが空リストになった途端、andはそれを偽値と解釈して再帰は滞り無く終わる。

上の例は単純ですが、色んな場面で効いてくる、Common Lispの便利な側面です。

偽と空リストに対して同じものを使うと混乱を引き起こすことがときどきあるが、長年のLispプログラミングの中で私はそれが掛け値なしの勝利であることを確信している。なぜなら、空リストは集合論での偽であり、多くのLispプログラムは集合で考えるからである。

ポール・グレアム

ANSI Common Lispのcarとcdr

さて、偽値=空リストであるANSI Common Lispのnilなんですが。Schemeと違って次の大変美しい性質があります。それは空リストにcarやcdrを適用したらどうなるか、と言う話です。

Schemeの場合、空リストにcarやcdrを適用するとエラーを返してきます。

> (car '())
car: expects argument of type ; given ()

 === context ===
/usr/lib/plt/collects/scheme/private/misc.ss:74:7

> (cdr '())
cdr: expects argument of type ; given ()

 === context ===
/usr/lib/plt/collects/scheme/private/misc.ss:74:7

> 

一方、ANSI Common Lispではそう言う事がありません。

CL-USER> (car '())
NIL
CL-USER> (cdr '())
NIL
CL-USER> 

nilにcar/cdrを適用するとnilが返る。これは大変ありがたい仕様です。

これは実はInterlisp由来の仕様だそうなんですが、いずれにせよ大変便利で、それがCommon Lispの仕様として取り入れられたそうです。

ANSI Common LispとSchemeのcar/cdrの違いは、そのままそれらを利用した組み込み関数/手続きの挙動にも影響しています。代表的なのは次の機能でしょうか。

Scheme	ANSI Common Lisp
list-ref	nth
list-tail	nthcdr

両者とも引数の順序が違うんですが、大体同じ機能です。ただし、nilのcar/cdrの扱いの違いで、挙動に差が生じるのです。

例えば、LOLで紹介されている(正確に言うとOn Lispで紹介されている)groupと言う関数があります。コードは以下の通りです。

(defun group (source n)
  (if (zerop n) (error "zero length"))
  (labels ((rec (source acc)
                (let ((rest (nthcdr n source)))
                  (if (consp rest)
                      (rec rest (cons (subseq source 0 n) acc))
                      (nreverse (cons source acc))))))
    (if source (rec source nil) nil)))

Schemeでそのまま何も考えないで直訳すると次のような感じでしょうか。

;; Gauche なら (use srfi-1)
;; Guile なら (use-modules (srfi srfi-1))
(require srfi/1)   ;PLT Scheme 依存

(define (group source n)
  (and (zero? n) (error "zero length"))
  (letrec ((rec (lambda (source acc)
    (let ((rest (list-tail source n))) ;list-tail の引数の順番に注意!
      (if (pair? rest)
   (rec rest (cons (take source n) acc)) ;take が srfi-1 の手続き
   (reverse (cons source acc)))))))
    (and (pair? source) (rec source '()))))

ところがどっこい、これは動きません。

> (group '(a b c d e f g) 2)
list-tail: index 2 too large for list: (g)

 === context ===
stdin::7328: group
/usr/lib/plt/collects/scheme/private/misc.ss:74:7

> 

list-refが「sourceリストの長さが足りない!」と文句を言ってくる。つまり、こう言う事です。

ANSI Common Lispのnth-cdrの挙動	Schemeのlist-tailの挙動
CL-USER> (nthcdr 2 '(g)) NIL CL-USER>	> (list-ref '(g) 2) list-ref: index 2 too large for list: (g) === context === /usr/lib/plt/collects/scheme/private/misc.ss:74:7 >

groupは与えられたsourceリストに対して、再帰的に要素をn個ずつグルーピングしていくわけですが、結局ベースケースで問題が生じてくるわけです。ANSI Common Lispでは考えなくて済むんですが、Schemeの場合、「現時点でのリストがどう言う状況なのか?」一々チェックを入れないとなりません。この場合は常にsourceの長さがnより大きいかどうか見なければならない。

従って、Schemeだとここまで面倒みないとなりません。

> (define (group source n)
    (and (zero? n) (error "zero length"))
    (letrec ((rec (lambda (source acc)
      (let ((rest (if (< (length source) n) ;リスト source の長さを n と比較する
        '() ;空リストを返す
        (list-tail source n))))
        (if (pair? rest)
     (rec rest (cons (take source n) acc))
     (reverse (cons source acc)))))))
      (and (pair? source) (rec source '()))))
> (list-ref '(g) 2)
> (group '(a b c d e f g) 2)
((a b) (c d) (e f) (g))
> 

CLerだったら

「やってらんねえよ！！！」

とか言うんでしょうね(笑)。人間一旦ラクを覚えたら引き返せませんので(笑)。

いずれにせよ、ANSI Common Lispではnilに対するcar/cdrがエラーにならないお陰で、書くべきプログラムが短く済む事が多いのです。

ANSI Common Lispにはラムダ・リスト・キーワードがいっぱい

Schemeの手続きに於いては必須パラメータとレスト・パラメータくらいしかありません。まあ、実装によるんですが、仕様(R5RS)ではそうなっていますね。

一方、ANSI Common Lispでは必須パラメータ「その他」がたくさんあります。必須パラメータ「以外」をラムダ・リスト・キーワード等と呼ぶようです。

#9LISP の方で@aharisuさんが紹介していたんですが、ここでもザックリまとめておきたいと思います。

• &optional : オプショナル・パラメータ指定


• &rest : レスト・パラメータ


• &key と &allow-other-key : キーワード・パラメータ指定


• &aux : 補助変数指定

レスト・パラメータはSchemeのヤツと同じなんで、ここでは端折ります。キーワード・パラメータに付いては後回しにします。まずはオプショナル・パラメータを見てみます。

例えば、Schemeを扱っていて、末尾再帰で手続きを書くのに便利な構文にnamed-letなんてのがあります。ワンパターンで階乗手続きを定義しますが、次のように使いますね。

> (define (fact n)
    (let loop ((n n) (acc 1))
      (if (zero? n)
   acc
   (loop (- n 1) (* n acc)))))
> (fact 10)
3628800
> 

実際これは便利で、LOLも本格的なマクロ実装の最初の例として、このnamed-letをまずは実装しよう、と言う流れになっています。

どうしてこんなに楽に末尾再帰が書ける構文をCommon Lispは持ってないんだろう?平たく言うとその必要が無いからって事でしょうね(※)。ANSI Common Lispにはオプショナル・パラメータがある。

オプショナル・パラメータとは文字通りオプショナルなパラメータで、関数呼び出しのときに対応する引数があってもなくてもよい。

～(中略)～

オプショナル・パラメータは、もし対応する引数があればその引数を初期値とし、そうでなければ、ラムダ・リストに指定された値(デフォルト値という)を初期値とする。個々のオプショナル・パラメータは、一般に三つの要素からなるリストで指定する。

(<<変数>> <<式>> <<判定変数>>)

～(中略)～

判定変数が必要なければ、オプショナル・パラメータ指定の<<判定変数>>のところを省略して

(<<変数>> <<式>>)

だけでもよい。また、デフォルト値を特に指定する必要がなければ

(<<変数>>)

だけでもよい。これらの場合はデフォルト値としてnilが使われる。

Common Lisp入門

つまり、オプショナル・パラメータに適当な初期値を与えれば、named-let無しでも簡単に末尾再帰が書けて、結果Scheme版より短くコードを記述する事が可能となるわけです。

CL-USER> (defun fact (n &optional (acc 1)) ;オプショナル・パラメータとして acc を初期値1として設定
    (if (zerop n)
        acc   ;返り値は acc
        (fact (1- n) (* n acc)))) ;オプショナル・パラメータ acc を操作する
FACT
CL-USER> (fact 10)   ;計算はオプショナル・パラメータ無しで
3628800
CL-USER> 

もう一つ例を挙げましょう。これはオプショナル・パラメータがどうの、と言うよりLisp-2であるための説明なんですが、ここで見てみます。

The Little Schemerにrember-fと言う問題があるそうで、これは高階手続きの問題のようですが、Schemeのnamed-letを用いると次のように定義出来ます。

> (define (rember-f test? a l)
    (let loop ((l l) (acc '()))
      (if (null? l)
   (reverse acc)
   (loop (cdr l) (let ((it (car l)))
     (if (test? a it)
         acc
         (cons it acc)))))))
> (rember-f (lambda (x y)
       (= x y)) 5 '(1 2 3 4 5))
(1 2 3 4)
> (rember-f (lambda (x y)
       (eq? x y)) 'jelly '(jelly beans are good))
(beans are good)
> (rember-f (lambda (x y)
       (equal? x y)) '(pop corn) '(lemonade (pop corn) and (cake)))
(lemonade and (cake))
> 

これもANSI Common Lispでは、上で見た通り、オプショナル・パラメータを用いた末尾再帰で基本的には実装可能なんですが、実際やってみると、何故かエラーを返してきます。

CL-USER>> (defun rember-f (test? a l &optional (acc nil))
    (if (null l)
        (reverse acc)
        (rember-f test? a (cdr l)
    (let ((it (car l)))
      (if (test? a it)
          acc
          (cons it acc))))))

;     (TEST? A IT)
; 
; caught STYLE-WARNING:
;   undefined function: TEST?
; 
; compilation unit finished
;   Undefined function:
;     TEST?
;   caught 1 STYLE-WARNING condition
REMBER-F
CL-USER> 

上はSBCLでの警告表示ですが、(test? a it)のtest?なんて関数はないぞ、と文句を言ってくる。Schemeだと何ともないんですが、Common Lispじゃダメだ、って事ですね

何が悪いのか、と言うと、仮引数はデフォルトでは変数が来る、と解釈されているわけです。ところがtest?と言う仮引数は関数のポジションであるS式の第一要素に鎮座してる。Common Lispは「それじゃマズいだろ」って言ってるわけです。

これを解決するのが、Schemerの中で悪名高いCommon Lispのfuncallです。つまり、こう書けば良い。

CL-USER> (defun rember-f (test? a l &optional (acc nil))
    (if (null l)
        (reverse acc)
        (rember-f test? a (cdr l)
    (let ((it (car l)))
      (if (funcall test? a it) ;ここで使う
          acc
          (cons it acc))))))
REMBER-F
CL-USER> (rember-f #'(lambda (x y)
         (= x y)) 5 '(1 2 3 4 5))
(1 2 3 4)
CL-USER> (rember-f #'(lambda (x y)
         (eq x y)) 'jelly '(jelly beans are good))
(BEANS ARE GOOD)
CL-USER> (rember-f #'(lambda (x y)
         (equal x y)) '(pop corn) '(lemonade (pop corn) and (cake)))
(LEMONADE AND (CAKE))
CL-USER> 

最後に補助変数&auxです。これはあんまり使われてるの見たことないんで、Common Lisp入門から解説を引っ張ってきます。

補助変数とは関数内で局所的に使用する変数のことで、関数の引数とは関係ない。局所変数は、letやlet*などのスペシャル・フォームを使っても宣言できるが、ラムダ・リスト・キーワード&auxを使うことによって、関数定義がコンパクトになる。例えば

(lambda (a b) (let* ((c 1) (d 2)) ...))

と書くかわりに&auxを使って、

(lambda (a b &aux (c 1) (d 2)) ...)

と書くことができる。各補助変数指定は、変数名とその初期値を与える式からなるリストである。

(<<変数>> <<式>>)

<<式>>がnilの場合はこれを

(<<変数>>)

あるいは単に

<<変数>>

と略してもよい。

だそうです。

確かに便利そうですが、あんま使われてるのを見ないのは、ひょっとしたらCLerはletの方が好きなのかもしれませんね。

※: もっとも、LOLの流れから言うと、「もっとも簡単なマクロで作る制御構文」の例としてnamed-letを敢えて取り上げたと思われる。

もう一つの狙いが「マクロに最適化したコードを吐かせる」例として、魅力的な題材だったのだろう。実際、ANSI Common Lispの仕様はSchemeと違って末尾再帰の最適化を要求していない。

ただし、「末尾再帰の最適化をしない」Common Lispの実装を思いつく方が難しい、と言うのも事実である。ちなみに、GNU CLISPの場合、インタプリタ上で入力しただけの末尾再帰関数に関しては最適化しないが、バイトコードへコンパイルすると最適化を行う模様である。

ANSI Common Lispの組み込み関数は汎用/統合指向

Schemeにはmemq、memv、memberと言う組み込み手続きがあります。それぞれ二つ引数を取り、第二引数はリストで、第一要素と等価なcarを持つ第二引数の部分リストを返します。ただし、この「等価」の定義が違って、memqはeq?、memvはeqv?、memberはequal?を比較に用います。

> (memq 'a '(a b c))
(a b c)
> (memq 'b '(a b c))
(b c)
> (memq 'a '(b c d))
#f
> (memq (list 'a) '(b (a) c))
#f
> (member (list 'a)
   '(b (a) c))
((a) c)
> (memq 101 '(100 101 102))  ;ここの動作は未定義
(101 102)    ;実装によって結果が異なる
> (memv 101 '(100 101 102))
(101 102)
> 

一方、ANSI Common Lispにはmemberしかありません。ただし、ANSI Common Lispのmemberは高階関数として設計されていて、比較演算子をキーワード・パラメータとして受け取る事が出来ます。

CL-USER> (member 'a '(a b c) :test #'eq) ; :test がキーワードパラメータで、ここで比較関数を指定
(A B C)
CL-USER> (member 'b '(a b c) :test #'eq)
(B C)
CL-USER> (member 'a '(b c d) :test #'eq)
NIL
CL-USER> (member (list 'a) '(b (a) c) :test #'eq)
NIL
CL-USER> (member (list 'a) 
   '(b (a) c) :test #'equal)
((A) C)
CL-USER> (member 101 '(100 101 102) :test #'eq) ;ここは実装依存の結果が返る
(101 102)
CL-USER> (member 101 '(100 101 102)) ;デフォルトは eql による比較
(101 102)
CL-USER> 

それどころか、CLHSに記載されている通り、比較対象の要素まで指定する事が出来ます。

;; ドット対のcdrを見て等価じゃないところから返せ、と言う指定
CL-USER> (member 2 '((1 . 2) (3 . 4)) :test-not #'= :key #'cdr)
((3 . 4))
CL-USER> 

このように、ANSI Common Lispの一部の関数は、Schemeではバラバラになっている手続きを統合したような単一関数として設計されているパターンが多いです(※)。もはや「組み込み関数」と言うより立派な一つのプログラムである、と言って良いくらいでしょう。非常に大掛かりなのがANSI Common Lispの関数の特徴です。

もう一つこの手の代表的なものに、連想リストへのアクセサ、assocが挙げられます。Schemeではassq、assv、assocが用意されています。

> (define e '((a 1) (b 2) (c 3)))
> (assq 'a e)
(a 1)
> (assq 'b e)
(b 2)
> (assq 'd e)
#f
> (assq (list 'a) '(((a)) ((b)) ((c))))
#f
> (assoc (list 'a) '(((a)) ((b)) ((c))))
((a))
> (assq 5 '((2 3) (5 7) (11 13))) ;これは返り値は未定義
(5 7)     ;実装依存の結果が返る
> (assv 5 '((2 3) (5 7) (11 13)))
(5 7)
> 

当然ANSI Common Lispではassocは高階関数として設計されていて、比較関数はキーワード・パラメータで変更するようになっています。

CL-USER> (defparameter e '((a 1) (b 2) (c 3)))
E
CL-USER> (assoc 'a e :test #'eq)
(A 1)
CL-USER> (assoc 'b e :test #'eq)
(B 2)
CL-USER> (assoc 'd e :test #'eq)
NIL
CL-USER> (assoc (list 'a) '(((a)) ((b)) ((c))) :test #'eq)
NIL
CL-USER> (assoc (list 'a) '(((a)) ((b)) ((c))) :test #'equal)
((A))
CL-USER> (assoc 5 '((2 3) (5 7) (11 13)) :test #'eq) ;返り値は実装依存
(5 7)
CL-USER> (assoc 5 '((2 3) (5 7) (11 13))) ;デフォルトは eql による比較
(5 7)
CL-USER> 

※: 最初のSchemeは1975年に登場、ANSI以前のCommon Lispは1984年登場なんで、約10年の開きがあるわけです。仕様自体はCommon Lispの方が新しい。

調べてみた限り、Schemeのmemq/memv/member、assq/assv/assocは共にMITのMacLisp由来で、Schemeでの名称もこれを受けています。一方、約10年後に登場したCommon Lispではキーワード・パラメータの導入と共に、積極的に統合化へ進んだ、と見た方が良いでしょう。

なお、MacLisp直系の子孫であるEmacs Lispでは、やはりSchemeのようにmemq/memv/member、assq/assv/assocと言う形になっている模様です。

Schemeにはいくつもの「データ変換用」の手続きが用意されていて、それらは大体シンボルに->と言う記号が入っています。中でも良く使うのがリスト、ベクタ、文字列等の通称シーケンスと呼ばれるデータ型同士の変換手続きです。

• list->string


• list->vector


• string->list


• vector->list

> (list->string '(#\爆 #\発 #\し #\ろ #\!))
"爆発しろ!"
> (list->vector '(0 1 2 3 4 5 6 7 8 9))
#(0 1 2 3 4 5 6 7 8 9)
> (string->list "爆発した!")
(#\爆 #\発 #\し #\た #\!)
> (vector->list #(0 1 2 3 4 5 6 7 8 9))
(0 1 2 3 4 5 6 7 8 9)
> 

これらは当然便利なんです。が、CLHSでそれらに対応する関数を探そうとしてもなかなか見つからない。まあ、見つからないのは当然で、ANSI Common Lispではこれらを統一的に扱う高階関数coerceに置き換わっています(しかも何て読むんだか分からない・笑)。

CL-USER> (coerce '(#\爆 #\発 #\し #\ろ #\!) 'string)
"爆発しろ!"
CL-USER> (coerce '(0 1 2 3 4 5 6 7 8 9) 'vector)
#(0 1 2 3 4 5 6 7 8 9)
CL-USER> (coerce "爆発した!" 'list) ;ユニコード指定文字のリストに変換される
(#\U7206 #\U767A #\HIRAGANA_LETTER_SI #\HIRAGANA_LETTER_TA #\!)
CL-USER> (coerce #(0 1 2 3 4 5 6 7 8 9) 'list)
(0 1 2 3 4 5 6 7 8 9)
CL-USER> 

ちなみに、その他の変換手続きへの対応表は以下の通りとなっています。

Scheme	ANSI Common Lisp
char->integer	char-code
exact->inexact	float
inexact->exact	rational
integer->char	code-char
number->string	write-to-string
string->number	parse-integer
string->symbol	intern
symbol->string	symbol-name/string

ANSI Common Lispにはfoldがない

けどreduceはあります。@valvallowさん大喜び(謎)。

;;; http://valvallow.blogspot.com/2010/04/lol-flatten.html
;;; を参照
;;; 形式的には全く同じコードだと分かる
;;; CL の reduce は SRFI-1 のfold/fold-right/reduce/reduce-right
;;; をキーワード・パラメータを用いて統合化したようなもの

CL-USER> (defun flatten (tree)
    (reduce #'(lambda (e acc)
         (cond
    ((null e) acc)
    ((consp e)
     (append (flatten e) acc))
    (t (cons e acc))))
     tree :from-end t :initial-value nil)) ;初期値に nil を指定して tree を逆順に辿る
FLATTEN
CL-USER> (flatten '(1 2 3 (4 5 6 (7) ((8) 9)) ((() 10))))
(1 2 3 4 5 6 7 8 9 10)
CL-USER> 

ANSI Common Lispのsetfは超強力

Schemeのset!にあたるANSI Common Lispの推奨マクロがsetfです。setfは汎用構造修正子としてデザインされています。

両者の使い方は基本的には同じです。

Scheme	ANSI Common Lisp
> (define a 1) ;define の返り値は未定義 > (set! a '(x y z)) ;set! の返り値も未定義 > a (x y z) >	CL-USER> (defparameter a 1) ;defparameter の返り値は束縛されたシンボル A CL-USER> (setf a '(x y z)) ;setf の返り値は束縛されたデータ (X Y Z) CL-USER> a (X Y Z) CL-USER>

ただし、まずsetfの特徴として、複数の変数を逐次、破壊的に変更する事が可能です(※1)。これがSchemeのset!には出来ない。

Scheme	ANSI Common Lisp
> (define a 1) > (define b 2) > (define c 3) ;;; 複数の変数を一気に変更しようとすると、当然エラーが出る > (set! a 'x b 'y c 'z) stdin::10037: set!: bad syntax (has 6 parts after keyword) in: (set! a (quote x) b (quote y) c (quote z)) === context === /usr/lib/plt/collects/scheme/private/misc.ss:74:7 > (set! a 'x) > (set! b 'y) > (set! c 'z) > a x > b y > c z >	CL-USER> (defparameter a 1) A CL-USER> (defparameter b 2) B CL-USER> (defparameter c 3) C ;;; 複数の変数を一気に変更する事が出来る CL-USER> (setf a 'x b 'y c 'z) Z ;返り値は最後に束縛されたデータ CL-USER> a X CL-USER> b Y CL-USER> c Z CL-USER>

また、setfの第一引数は式でも良く、第一引数で参照された場所の値を破壊的に変更する事が可能で、これもSchemeのset!には出来ない事です(※2)。

CL-USER> (defparameter x '(a b c))
X
CL-USER> (setf (car x) 'n)
N
CL-USER> x
(N B C)
CL-USER> 

※1: しかしながら「出来る」と言うのと「人気がある」と言うのは別っぽい。Common Lispにはもうちょっとプリミティヴな特殊形式であるsetqがあり、これも逐次で変数の値を破壊的に書き換える機能がある。同じ特殊形式がEmacs Lispにも存在するが、色んなelispファイルを眺めても、この「複数の値を一気に書き換える」書き方はあまり成されてないようである。それよりもsetqを羅列する方が好まれてる模様だ。

※2: SRFI 17でANSI Common Lispのsetfと同等の機能を持つ一般化set!が提案されてはいる。が、動かない処理系が出てきてるので要注意。

一般化set!をマクロで実装するにはset-car!やset-cdr!と言う手続きが必要なのだが、これらはR6RS辺りからさほど重要な手続きではなくなってきた模様である。

set-car!, set-cdr!: ペアの要素を変更可能にすると 特に実装者にとって色々面倒なことが起きるので、R6RS案の段階ではペアは 全て変更不可にしようぜ、みたいな極端な話が出てきたこともありました。 結局、これらの手続きを別ライブラリにすることでなんとなく妥協。 ペアを変更不可にすると、循環リストが出来ないんで色々見通しが良くなるんですね。 個人的には破壊的変更が嫌ならHaskell使えばって思いますが。


なんとなく隅に追いやられた手続き

これを受けて、PLT SchemeがVersion: 4.0.0をもってset-car!/set-cdr!を廃止(Getting rid of set-car! and set-cdr!)。他にもScheme48のような海外でメジャーな処理系もset-car!/set-cdr!を備えていない。

Schemeの仕様に準じてないのにSchemeを名乗るのはおかしいだろ、って話もあるが、PLTは既に「Scheme方言である」と明言し、また、そもそもANSIと違って仕様書の縛りがそれほどキツくない。実装者側にとってのSchemeの魅力とは、言語仕様が比較的小さく、コアをラクに実装出来(とは言ってもそれはそれで難しい)、かつ自分のオリジナルのアイディアを組み込みやすいことである。従って処理系間の互換性が落ちやすい、と言うのがどの道前提になる(これはANSI Scheme仕様書であるR4RS準拠実装を今全くと言っていいほど見かけない、って事からも分かる)。

現時点ではR6RS準拠を謳っている実装はPLTくらいしかないが、今後Schemeはどうなっていくか分からない。いずれにせよ、当分の間set-car!/set-cdr!はアテにせん方が良いような気がする。

ANSI Common Lispはcase-insensitive

R5RSには明言されてないと思うんですけど、現存する実装を見る限り、Schemeはcase-sensitive(シンボルの大文字/小文字を区別する)言語です。R6RSでは、ハッキリとcase-sensitiveな言語となった模様です。

Lispの長年の伝統をついに破って、識別子がcase-sensitiveになりました。 もっともこれは現状追認とも言えます (参考：x:Concept:CaseSensitivity)。

処理系はオプショナルなcase-insensitive modeを用意しても 良いことになっています (6app:B)。

一方、ANSI Common Lispの方は、既に気づいたと思いますが、Lispの伝統に則り、case-insensitive(シンボルの大文字/小文字を区別しない)言語です。従って、両者のシンボルの等価判定には差が出てきます。

Schemeの場合	ANSI Common Lispの場合
> (eq? 'hoge 'HOGE) #f >	CL-USER> (eq 'hoge 'HOGE) T CL-USER>

ANSI Common LispはC登場以前の言語群の伝統を継承しているんですね。シンボル表記に関して言うと、ANSI Common LispはFortran/BASIC/Pascalの仲間です(っつーかUNIX文化じゃない)。

ANSI Common Lispには継続も遅延評価も無い

そんなつや～なものはANSI Common Lispにはありません(笑)。元々、Scheme自体が研究用途だった、と言う事もあって、実験的/先鋭的機能(※)を入れてるんですが、ANSI Common Lispはもっと堅実な仕様になっています。「より普通の」プログラミング言語なんですね。

※: とは言っても、R6RSの本体から遅延評価は消えた模様です。

delay, force: R6RS本体では特に遅延評価のためのプリミティブは 提供されません。というのは、遅延評価メカニズム自体はSchemeの手続きの上に簡単に 構築できるのと、R5RSのdelayとforceはunderspecifiedで、実用に供するためには 結局再実装が必要であった (srfi-40およびsrfi-45をめぐる議論参照。x:SRFI-40, x:SRFI-45)、という経験によります。

互換ライブラリで提供される手続き

ANSI Common Lispでは、大域脱出をする際には通常、特殊オペレータreturn-fromか、あるいはreturnマクロを用います。

例えば、次のような問題を考えます。

引数のリストの要素が全てpred?を満たすか判定するlist-of-pred?手続き/関数を定義してみる

Scheme: call/cc での解	ANSI Common Lisp: return-from での解
(define (list-of-pred? lst pred?) (call/cc (lambda (return) (and (map (lambda (x) (let ((it (pred? x))) (if it it (return it)))) lst) #t))))	(defun list-of-pred? (lst pred?) (and (mapcar #'(lambda (x) (let ((it (funcall pred? x))) ;; return-from は第一引数に関数名を取り、 ;; そこから第二引数の値を持って大域脱出する ;; 第二引数が省略された場合のデフォルト値は nil (if it it (return-from list-of-pred?)))) lst) t))

なお、On LispではCommon Lispでの遅延評価の実装例と継続の実装例が紹介されています。

ANSI Common Lispは(過剰に)親切設計

ANSI Common Lispは非常に巨大な仕様で有名なんですが、何と仕様にデバッグ関連のツールまで含まれているんです。デバッグ関連ツールまで(ある程度にせよ)定義されている言語なんて殆ど無いでしょう。一方、Schemeはそう言う部分は丸っきり無くって、まるでCSの宿題を解く為の言語の如しです。自分で解いて考えてくれ、と言わんばかり。

有名なのはtraceマクロでしょう(※1)。例えば再帰関数を定義して、何かおかしな結果が返るような場合、関数の挙動を逐一追ってくれたりします。

CL-USER> (defun fact (n &optional (acc 1))
    (if (zerop n)
        acc
        (fact (1- n) (* n acc))))
FACT
CL-USER> (trace fact)
(FACT)
CL-USER> (fact 3)
  0: (FACT 3)
    1: (FACT 2 3)
      2: (FACT 1 6)
        3: (FACT 0 6)
        3: FACT returned 6
      2: FACT returned 6
    1: FACT returned 6
  0: FACT returned 6
6
CL-USER> 

なお、traceを解除するにはuntraceを使います。

ちなみに、残念ながらtraceは局所関数の中身まで追っかけてきてくれません。これがSchemerとCLerのアティテュードの差をある程度生んでいて、Schemerはトップレベルでのシンボルの衝突を避ける意味もあって、ローカル手続きを多用する傾向があるんですが、CLerはSchemer程局所関数を多用せず、どちらかと言うと大域関数として補助関数を複数作る事を好みます。CLerはトップレベルのシンボルの衝突はいざとなったらパッケージで回避出来るので、デバックのやりやすさをより重要視する傾向があるんです。

また、ANSI Common Lispでは、エラーが起こるとバックトレースあるいはブレイクループと呼ばれる状態に入ります。ANSI Common Lispではこれがデバッガの基本となっていて、関数が止まった地点から逆順に何が起こったか探索していけるように設計されています。

例えばC言語を勉強したとしてもデバッギングはまた別です。「GDBの使い方」なんかを学ばないとならない。ブレークポイント設置もメンド臭いし、何よりこれは「言語の外」の話です。言語に精通したとせよ、プログラミングするには「その他のソフトウェアの使い方」を強要される。じゃないとマトモにプログラミングが出来ない。

一方、ANSI Common Lispは言語仕様の中にデバッガがある。ANSI Common Lispは一種オールインワンの言語環境を目指していて、そこに何でもあるわけです。それ以外に何も必要がない、最初からデバッガの使い方も簡単に学べる、と言う辺りがCLerの「CL最強説」の一つの源になっているのでしょう(※2)。

※1: もちろんSchemeにも実装依存でtraceを持ってる処理系があります。ただし、ここでは「実装依存がどーの」とか言うつもりは全くありません。やはりプログラミングのしやすさを考えると仕様で定義されてるべきじゃないか、と思います。逆に言うと、定義してないのは、やっぱりSchemeは宿題の為の言語なのでは、と。

なお、Gaucheで使えるtraceはSLIBのものです。SRFIとはまた別の共有ライブラリなんですが、一方、PLT SchemeではSLIBは使用出来ません。

PLT Schemeでは(require mzlib/trace)を評価した後、CLと全く同じようにtraceが使えます。

Gaucheでは

(use slib)
(require 'trace)

でtraceが使用出来ます。

Guileではそのままデフォルトでtraceが使用可能になっています。

※2: この「ANSI Common Lispは言語環境の統合化を狙っている」ってのはマジな話で、例えばedなんて関数が仕様で定義されていて、これを走らせると「エディタを立ち上げる」事が要請されています。

Windows上のCLISPで試した事があるんですが、何と「メモ帳」が立ち上がって大爆笑した事があります(笑)。ANSI仕様では何とテキストエディタまで内包されているんです(もっとも仕様に実装依存で構わんと明記されてるんですが)。

この辺、IDEの機能であるべきものを言語仕様に含めるべきではない、と言う意見もあるとは思います。しかし、ANSI Common Lispはそれをやっちゃった。

CLerの選民思想に関する批判があって、それはその通りだと思います。ただ、敢えて言うと、「オールインワンの言語環境を提供する」ってのは別の見方をすると「ラクだ」って事でもあるんですよね。誰に対してラクか、と言われれば当然エキスパートにとって、って事もあるんですけど、プログラミング初心者にとってもラクだと言う事でもあるんです。

CLは「言語設計者にとって良い事はプログラマにとっても良い事だ」が設計思想だ、と言われてますが、同時に「プログラミング初心者にとってもラクな事はエキスパートにとってもラクだ」と言う設計思想もあるような気がします。本当はこの二つは境界線があるべきものじゃない。そしてBASICみたいにやたら初心者におもねってるわけでもないのです。

「CLerの苛立ち」と言うのは選民思想と言うよりは、

「こんなにラクな環境を構築してるのに何で人気が無いんだろ?」

って部分に根ざしているような気がします。エラーが出たら自動的にデバッガが立ち上がったりする、ってCLの設計を見ても、どっちかと言うと、

どんなアンポンタンでもプログラムがデッチ上げられる

ように設計されているようにしか見えない、のです。その親切設計に気づかないで

「括弧が多いから・・・・・・。」

と文句言われたらそりゃあ頭にも来るし、引きこもるでしょう(笑)。そう言う部分はある、のです。括弧は大した問題じゃない傍流の話だから、です。

ANSI Common Lispはプログラミングのビギナーからエキスパートまでの幅広い層を対象に設計されてます。これは事実です。すべての人々のレベルに合わせて応えてくれる。

残念ながら、Common Lispの内側に住む限り最強でしょうが、90年代初頭と違ってCLの外界はどんどん様変わりしています。OSとやり取りするのが一番難しい、と言うのが現状でしょう。結局、ライブラリの問題に帰着するって現象が起きている。

Lispで書かれたOSでCommon Lispを動かす、のが実際は最強なんでしょうが、現時点では、過去のLisp OSのエミュレータか、あるいはハードウェアエミュレータくらいしか無いのが残念です。

その他細々した違い

• Schemeの手続き/特殊形式名とANSI Common Lispの関数/特殊オペレータ名が食い違っている

  
  今までもちょこちょこと出てきましたが、結構名前が違うものが多いです。代表的なところで、SchemeのbeginはANSI Common Lispではprognとなっています。
  



• Schemeの仕様では述語の最後は?で終わる命名規約になっている

  
  一方、ANSI Common Lispでは慣習的には述語はpで終わる、とされていますが、仕様内で定義されている述語を見ると、必ずしもそうじゃありません(例:atomやnull)。また、Schemeでは破壊的変更を行う手続きに関しては!で終わる命名規約になっていますが、その手の命名規約はCommon Lispにはありません。これらのゴチャゴチャは、Common Lispの元となったZetalisp、MacLisp、Interlispで書かれたコードと最大限互換性を保つ為、だと思われます。要するに結構デタラメです。色んな意味で(笑)。
  
  なお、独自に述語を作る際、実践Common LispやLOLではCommon Lisp流の-pスタイルを使っていますが、ポール・グレアムはScheme式に?で終わらせる事を好んでる模様です。
  



• ANSI Common Lispでは(if pred? then)で述語部が偽の場合、nilを返す

  
  Schemeではこの場合、返り値が未定義で、処理系によってはこの書き方は単にエラーになります。一方、ANSI Common Lispではどんな場合でも値を返すので素直にnilを返してくれます。
  



• Schemeのcondの「その他」はelseだが、ANSI Common Lispでは単にt

  
  これはもうまんまそのまんま、です。
  



• Schemeのcaseの「その他」はelseだが、ANSI Common Lispでは何故かotherwise

  
  何ででしょ?もう知らん(笑)。
  

ANSI Common Lispのマクロ

衛生的マクロから伝統的マクロへ

Schemeが方向を誤ったのは、マクロの構築を目的とするドメイン固有言語を推進したことである。Schemeのミニ言語は確かに強力だが、マクロの勘所を完全に外している。マクロは初心者用プリプロセッサ言語ではなく、Lispで書くから偉大なのだ。

Let Over Lambda

Schemeの衛生的マクロ、特にR5RSのヤツは、パターンマッチングと言う武器を使って、分かりやすいテンプレート変換を用いた機能の提供を行っています。確かに比較的分かりやすく、敷居は低いんです。

ただし、これがLispなのか?と言うと……実際問題まるで別物です。LOLで示唆されているように、Scheme自体の文法とまるで関係なく衛生的マクロは存在している。つまり、仕様としてはSchemeはScheme＋別のミニ言語を提供しているんだ、って言って良いでしょう。

とは言っても、Schemeの衛生的マクロを見た後だと、比較的ラクにANSI Common Lispのマクロの世界には入っていきやすいとは思います。何故ならどの道狙いは同じだから、です。目的はパターンの変換。そして、単にANSI Common Lispのマクロは衛生的マクロより強力だ、ってだけの話です。

例えば、letを実装しろ、って課題があったとします。教科書的にはletはlambdaの構文糖衣なんで、ANSI Common Lispのマクロで単純に書けば次のようになるでしょう。

(defmacro my-let (bindings &body body)
  `((lambda ,(mapcar #'car bindings)
      ,@body)
    ,@(mapcar #'cadr bindings)))

ちょっといきなりなんで見にくいとは思いますが、敢えてインデントを揃えてSchemeの衛生的マクロでの解と照らし合わせてみれば、次のように対応している事が分かるでしょう。

Schemeの衛生的マクロでの解	ANSI Common Lispのマクロでの解
(define-syntax my-let (syntax-rules () ((_ ((x v) ...) body ...) ((lambda (x ...) body ...) v ...))))	(defmacro my-let (bindings &body body) `((lambda ,(mapcar #'car bindings) ,@body) ,@(mapcar #'cadr bindings)))

比べてみると、

1. Schemeの衛生的マクロの方が(syntax-rules () ...)の為に記述要素が多い。


2. Schemeの方が明示的なパターン変換を指定する為、括弧が多い。


3. ANSI Common Lispのdefmacroのパラメータ・リストが衛生的マクロによる記述パターンに対応している。


4. 他はこのレベルでは構成自体は大して変わらない。

と言う事が見て取れます。概形自体は全く同じなんです。

「ANSI Common Lisp版には`とか,@とかワケの分からん記号が跋扈してるぞ…！」

と言う感想はどーでもいいです(笑)。まずはザックリと「構成自体は似てる」って感覚をまず掴む事が大事だと思います。

衛生的マクロの(syntax-rules () ...)に関して言うと、僕もこれが何の為にあるんだか、ぶっちゃけ分からないです(笑)。これしかないんだったら、明示せんでもエエんちゃうの?とか思ってるんですが(実際は、R6RSにはsyntax-caseと言うものもあり)。まあ、恐らく、Schemeのλ式による手続き定義と対応させるためだけに入ってるんでしょうけどね。

Schemeの手続き定義の形式	Schemeのマクロ定義の形式
(define 手続き名 (lambda (引数) ...))	(define-syntax マクロ名 (syntax-rules (キーワード) ...))

形式的な一貫性を保つ為なのかどうか知りませんが、それだけの為の整合性ってのは正直イラつきますね(笑)。タイプ量が増えるだけ、なんで。実際、実装によっては、define-syntaxと(syntax-rules () ...)を独立で提供しつつ、なおかつこの二つを統合したマクロを提供している処理系もあります(例:PLT Schemeのdefine-syntax-rule)。反面、ANSI Common Lispのマクロにはそう言うイラつき要素はありません。

いずれにせよ、最初はSchemeの衛生的マクロで鍛えた「パターン変換」を念頭に入れてマクロを記述するようにした方が早く慣れるんじゃないか、とは思います。

以下は古いLispの本の筋書きに則った展開です。

クオートとlistは違う

何を当たり前な事を、と言う話なんですけど、実は手癖で忘れる可能性が高い話なんじゃないか、と思います。

例えば、(1 2 3 4 5)と言うリスト*lst*を定義せよ、と言われたら殆どの人が

(defparameter *lst* '(1 2 3 4 5))

と書くでしょう。まあ、十中八九書きますよね。でもリストを生成する関数はlistなんで、

(defparameter *lst* (list 1 2 3 4 5))

って書いてもいい筈。でも書かない。何故なら前者の方が短くリストを設定出来るから、です。後者は長い。よって前者のパターンばっか書く確率が高いでしょう。そしてある意味、基本関数である筈のlistはもっとも使われない関数となってしまうんです。

ところが、一見似た結果をもたらす両者なんですが、次のようにしてみると当然結果が違うんです。

CL-USER> (defparameter *quoted-lst* '(1 (+ 2 3) (- 4 5) (* 6 7) (/ 8 9)))
*QUOTED-LST*
CL-USER> *quoted-lst*
(1 (+ 2 3) (- 4 5) (* 6 7) (/ 8 9))
CL-USER> (defparameter *listed-lst* (list 1 (+ 2 3) (- 4 5) (* 6 7) (/ 8 9)))
*LISTED-LST*
CL-USER> *listed-lst*
(1 5 -1 42 8/9)
CL-USER> (equal *quoted-lst* *listed-lst*)
NIL
CL-USER> 

ここは普段意識しないでしょうから結構重要です。特殊オペレータquoteは含まれたS式の評価を完全に止めます。しかしながら、listは関数なんで最初に引数を評価してから作用する。従って、listの引数にS式を与えたら、それぞれの引数の計算結果が返ってくるんです。当たり前なんですがかなり重要な事です。

Lispのプログラムはリスト

さて、上で見た通り、関数listと特殊オペレータquoteの動作は丸っきり違うわけですけど、この二つを組み合わせるとS式を部分評価してS式を組み立てられる事に気づきます。例えば次のようにして。

CL-USER> (let ((x 0))
    (list 'cond (list (list 'zerop x) ''zero)
   (list (list 'plusp x) ''positive)
   (list t ''negative)))
(COND ((ZEROP 0) 'ZERO) ((PLUSP 0) 'POSITIVE) (T 'NEGATIVE))
CL-USER> 

恣意的な例なんですが、Lispのプログラムを返してるのが分かるでしょうか。評価が成されてない、入力で書きそうなS式が返っています。しかも、必要な部分(この場合はx)が評価されて埋め込まれています。別な言い方をすると確かにコードを生成してるんです。あるいはテンプレートを生成した、と言うべきか。

CL-USER> (let ((x 1))
    (list 'cond (list (list 'zerop x) ''zero)
   (list (list 'plusp x) ''positive)
   (list t ''negative)))
(COND ((ZEROP 1) 'ZERO) ((PLUSP 1) 'POSITIVE) (T 'NEGATIVE))
CL-USER> (let ((x -1))
    (list 'cond (list (list 'zerop x) ''zero)
   (list (list 'plusp x) ''positive)
   (list t ''negative)))
(COND ((ZEROP -1) 'ZERO) ((PLUSP -1) 'POSITIVE) (T 'NEGATIVE))
CL-USER> 

しかし、これらは評価されていません。実際に評価を下すのがLisp万能関数evalです。

CL-USER> (eval (let ((x 0))
   (list 'cond (list (list 'zerop x) ''zero)
         (list (list 'plusp x) ''positive)
         (list t ''negative))))
ZERO
CL-USER> (eval (let ((x 1))
   (list 'cond (list (list 'zerop x) ''zero)
         (list (list 'plusp x) ''positive)
         (list t ''negative))))
POSITIVE
CL-USER> (eval (let ((x -1))
   (list 'cond (list (list 'zerop x) ''zero)
         (list (list 'plusp x) ''positive)
         (list t ''negative))))
NEGATIVE
CL-USER> 

つまり、defmacroの仕組みとは、基本的には、

1. マクロの記述形式を引数として受け取る。


2. それをリストで記述されたコードのテンプレートに受け渡す。


3. 最終的にevalを適用する。

と言う事です。まあ、実際はこんなに単純に動作しているわけじゃないんでしょうが、「考え方」はこの通りですね。なお、簡単なdefmacroの実装方法に関してはOn Lispのマクロのモデルに記載されています。

この考え方でifを定義すると、次のようになります。

(defmacro my-if (pred? then-clause else-clause) ;マクロの記述形式を引数で表現する
  (list 'cond (list pred? then-clause)  ;リストで組み立てられたコードのテンプレートを記述する
 (list t else-clause)))

my-ifは次のような再帰的定義内でもキチンと動く事が分かります。

CL-USER> (defun fact (n &optional (acc 1))
    (my-if (zerop n)
    acc
    (fact (1- n) (* n acc))))
FACT
CL-USER> (fact 3)
6
CL-USER> 

バッククオートとカンマ

マクロの基本的な書き方は上の通りです。歴史的には、元々実際上のようにして書いてたらしいんですがlist、list、list、だと見づらいです。かつ書きづらい。そこで、listとquoteを使う代わりに、この二つの組み合わせが行う事を別の書き方で表現する方法がバッククオート(※1)(日本語キーボードだとShift-@)とカンマなんです。

listとquoteを使った評価例	バッククオートとカンマを使った評価例
CL-USER> (list 'a '(+ 1 2) (+ 3 4)) (A (+ 1 2) 7) CL-USER>	CL-USER> `(a (+ 1 2) ,(+ 3 4)) (A (+ 1 2) 7) CL-USER>

これらは写真で言うポジとネガの関係のようです。同じ事を書き表すのに反転しているように見える。

listの場合は引数で評価したい部分式はそのまま、評価を止めたい部分式にクオートしますが、バッククオートでは評価したい部分式にカンマを付けて、評価を止めたい部分式をそのまま記述します。いずれにせよ、結果は同じになります。

また、カンマは上のようにバッククオートの中で使われるのが前提なんで、カンマ単独で使用しようとする(※2)と、必ずエラーを返します。カンマはバッククオートの一部です(これは元々listの代用表記だと言う事を考えてみても分かるでしょう)。

;;; エラーの例
;;; 「カンマがバッククオートの中にないよ！」と文句を言ってくる
CL-USER> '(+ 1 ,(+ 2 3))
SB-INT:SIMPLE-READER-ERROR on #<SB-IMPL::STRING-INPUT-STREAM {AF98ED9}>:
  comma not inside a backquote
   [Condition of type SB-INT:SIMPLE-READER-ERROR]
; Evaluation aborted.
CL-USER> 

そして、上のエラーの例見ても分かるでしょうが、クオートとバッククオートは紛らわしいです。間違えないようにしましょう。もう一回書きますが、日本語キーボードだとバッククオートはShift-@です。

my-ifのlistで組み立てられたヴァージョンとバッククオートで組み立てられたヴァージョンを並べて見てみます。

listとクオートで書いたmy-if	バッククオートとカンマで書いたmy-if
(defmacro my-if (pred? then-clause else-clause) (list 'cond (list pred? then-clause) (list t else-clause)))	(defmacro my-if (pred? then-clause else-clause) `(cond (,pred? ,then-clause) (t ,else-clause)))

若干見やすくなってスッキリしている事が分かると思います。若干ですがね。

※1: あるいはそのまま逆引用符、等と呼んだりする。

なお、Schemeでは`をquasiquoteや準引用符等と呼んで、バッククオートとは呼ばない。同じものを別の呼び方で呼ぶ。文化圏が違うのである。

加えて、quasiquoteはR5RSでも定義されているが、マクロが衛生的マクロしか定義されてないので、仕様書範囲内では何のために存在してるんだかサッパリ、である。単純にそれこそlistの代用としてしか使い道がない。仕様書の範囲内では。

※2: Emacs + SLIME(あるいはLispbox)では、REPLでカンマを丸裸で打つと、SLIMEのコマンドが列挙される。つまりSLIME上ではカンマはSLIMEの機能の呼び出しコマンドにあたる。従って、REPL上ではカンマが丸裸では使えないように設計されているので、ミスは減る。

macroexpand-1

若干と強調したのは、どのみちバッククオートがlistの代用である以上、見た目はスッキリしたとしてもlistでコードを組み立てるメンド臭さは変わらないと言う事だから、です。そして、メンドくさい、って事はいずれにせよ間違える。

Schemeだったらコード記述時に間違えた場合、処理系は知らんぷりなんですけど、そこは過剰な親切設計であるANSI Common Lisp。マクロ記述用の一種のデバッガまで用意しています。macroexpand-1と言う関数がそのデバッガにあたります。

CL-USER> (macroexpand-1 '(my-if (zerop n)
     acc
     (fact (1- n) (* n acc))))
(COND ((ZEROP N) ACC) (T (FACT (1- N) (* N ACC))))
T
CL-USER> 

上の例はmy-ifを用いて定義した階乗関数の一部分をmacroexpand-1に手渡したものです。macroexpand-1は関数なので、受け渡すフォーム(作成したマクロを使った部分コード)はクオートしなければなりません。しかし、それさえ守れば、コードが意図したように展開されたかどうか、一発で分かりますね。問題があったら修正、と言う流れです。

@valvallowさんがブログで記述していた宿題のうち、when、unless、pop、pushなんかは仕様で定義されているマクロなんで、全部macroexpand-1で展開形を見てみて、カンニングする事が出来ます(笑)。

CL-USER> (macroexpand-1 '(when t 'hello))
(IF T (PROGN 'HELLO) NIL)
T
CL-USER> (macroexpand-1 '(unless t 'hello))
(IF T NIL (PROGN 'HELLO))
T
CL-USER> (macroexpand-1 '(pop stack))
(LET* ((#:NEW769 STACK))
  (PROG1 (CAR #:NEW769) (SETQ #:NEW769 (CDR #:NEW769)) (SETQ STACK #:NEW769)))
T
CL-USER> (macroexpand-1 '(push 1 (car lst)))
(LET* ((#:G772 1) (#:TMP771 LST) (#:NEW770 (CONS #:G772 (CAR #:TMP771))))
  (SB-KERNEL:%RPLACA #:TMP771 #:NEW770))
T
CL-USER> 

#:とか言うのは変数名なんで、若干見にくいんですが、要するにxとかyとかの無意味な変数名と同じものです。他には、上の例の場合、SB-KERNEL:と記述されているのはSBCLの実装上、プリミティヴとして定義されている関数の事を表したりしてるんですが、いずれにせよ、それらの「独特の表記」さえ抜かせば、解読はさほど難儀ではないと思います。

いずれにせよ、ツマッた場合のカンニングは、学校のテストじゃご法度ですが、CLのマクロでは推奨されています。

マクロ理解のポイントは、それがどのようにして実装されているかを理解することである。実質的にマクロは式を変換する関数に過ぎない。

ANSI Common Lisp

マクロ展開は単なるデバッグの補助手段ではなく、マクロの書き方の勉強手段でもあることを言っておきたい。Common Lispには100以上の組み込みマクロがあり、なかには大変複雑なものもある。そんなマクロの展開形を見ることで、それらがどう書かれたのかが分かることも多い。

On Lisp

destructuring-bind、カンマアットと&body

同じく、@valvallowさんのブログで示唆されている宿題ではforがあります。しかし、一般にforとは言っても、

からはじまって、色々な形式のforがあります。言語によって形式的には全く違う。

そこで、もっともメジャーだと思われるC言語のforのスタイルを借りてきます。C言語嫌いの僕でも一応K&Rは持っているんで(笑)、そこから形式を借りてきます。

for文

for (expr1; expr2; expr3)
    文

さいでっか(笑)。何とシンプルな(笑)。

ここで、文はCommon Lispで言う本体部(body)、になるでしょうね。あとはCommon Lispの組み込みマクロであるdoを使って、次のようにしてでっち上げてみます。

(defmacro for ((expr1 expr2 expr3) &body body)
  `(do ((,@expr1 ,expr3))
       ((not ,expr2))
     ,@body))

これでK&Rの冒頭にある、華氏->摂氏の変換表も次のように、Cスタイルで簡単に書けますね。

CL-USER> (for ((fahr 0) (<= fahr 300) (incf fahr 20))
    (format t "~A ~A~%" fahr (float (* 5/9 (- fahr 32)))))
0 -17.777779
20 -6.6666665
40 4.4444447
60 15.555555
80 26.666666
100 37.77778
120 48.88889
140 60.0
160 71.111115
180 82.22222
200 93.333336
220 104.44444
240 115.55556
260 126.666664
280 137.77777
300 148.88889
NIL
CL-USER> 

さて、上のforは実は次のようにしても書けるんですが、

(defmacro for (exprs &body body)
  `(do ((,@(car exprs) ,(third exprs)))
       ((not ,(cadr exprs)))
     ,@body))

好みにもよるんですが、若干見づらいですね。比べてみますか。

最初のヴァージョンのfor	次のヴァージョンのfor
(defmacro for ((expr1 expr2 expr3) &body body) `(do ((,@expr1 ,expr3)) ((not ,expr2)) ,@body))	(defmacro for (exprs &body body) `(do ((,@(car exprs) ,(third exprs))) ((not ,(cadr exprs))) ,@body))

平たく言うと、ANSI Common LispではSchemeの衛生的マクロ程明らさまで強力なパターンマッチングの機能は無いんですが、一方、単純なパラメータの分配に関して言うと、行う事が出来ます。この機能をdestructuring-bindと呼びます。

Common Lispのdefmacroではパラメータリストは任意のリスト構造であってよい。マクロ呼び出しが展開されたとき、マクロ呼び出しの構成要素はマクロのパラメータにdestructuring-bindと同様に代入される。

On Lisp

「任意のリスト構造で良い」と言うのは次のような事です。つまり、最初のヴァージョンのforでは、expr1は二つの要素を持つリストだと仮定していました。よって、三つ以上の要素を持つリストがexpr1に渡されたら明らかにバグります。エラーチェックを行ってないわけです。

そこで「任意のリスト構造で良い」と言うのなら、これを避ける意味もあって、forは次のように記述しても構わない、と言う事です。

(defmacro for (((var start) expr2 expr3) &body body)
  `(do ((,var ,start ,expr3))
       ((not ,expr2))
     ,@body))

もう一回並べておきますが、もうちょっとforの動作が明確になってるんじゃないか、と思います。

最初のヴァージョンのfor	最後のヴァージョンのfor
(defmacro for ((expr1 expr2 expr3) &body body) `(do ((,@expr1 ,expr3)) ((not ,expr2)) ,@body))	(defmacro for (((var start) expr2 expr3) &body body) `(do ((,var ,start ,expr3)) ((not ,expr2)) ,@body))

控え目に使う限り、パラメータリストの分配は明確なコードにつながる。～(中略)～ 本体の式の前に複数の引数を取るようなマクロで便利だ。

On Lisp

となると、カンマアット(,@)(※)が何を行っているのか明確です。それはつまり、次のような作用がある、と言う事です。

CL-USER> `(,@(list 'var 'start))
(VAR START)
CL-USER> (let ((expr1 '(fahr 0))
        (expr2 '(<= fahr 300))
        (expr3 '(incf fahr 20))
        (body '((format t "~A ~A~%" fahr (* 5/9 (- fahr 32))))))
    `(do ((,@expr1 ,expr3))
  ((not ,expr2))
       ,@body))
       
(DO ((FAHR 0 (INCF FAHR 20)))
    ((NOT (<= FAHR 300)))
  (FORMAT T "~A ~A~%" FAHR (* 5/9 (- FAHR 32))))
CL-USER> 

カンマアット(,@)はカンマの変種で、機能はカンマと同じだが違いが1点ある : 次に続く式の値をカンマのようにそのまま挿入するのでなく、カンマアットは切り張り操作を行う。つまり、1番外側の括弧を取り除いて挿入する :

On Lisp

残るは&bodyですが、これはレスト・パラメータ指定、つまり&restと基本的には同じです。ただし、macroexpand-1等を行った際に改行やインデントを施したプリティ・プリント(清書印字を)してくれるかどうかが差、なんですが、現時点、処理系によってはどっちでもプリティ・プリントを行ってくれる模様です。だから慣習的な意味しかない、と言えば無いでしょうね。関数を書く場合は&restを使って、マクロを書く場合は&bodyを使う、程度の差しか無いと言えば無いでしょう。

レスト・パラメータは以降の式をすべて纏めて単一リストにしちゃうので、本体の実行部を全てマクロ定義内に並べる為には一番大枠の括弧が要らなくなるので、当然カンマアットが必要になるわけです。

※: ちなみに、カンマアットが正式名称なのか、と言うとそれは分からない。CLHSを見る限り、バッククオートに付いての章しかなくて、

カンマに続いてアットサインがある場合は…

のように記載されているので、特にハッキリとした名称は存在しない模様である。ただし、歴史的には通称カンマアットで間違いはない。

ちなみにSchemeのR5RSでは、,はunquote、,@はunquote-splicingと言う洒落た名称が与えられている。

カンマ、カンマアットとmapcar

Schemeの衛生的マクロの場合、省略符号(...)とパターンマッチがあるお陰で、簡単なパターン記述がしばしば行えるわけですけど、ANSI Common Lispのマクロにはそう言う洒落た機能はありません。もう一回最初の例に戻りますが、

Schemeの衛生的マクロでのmy-let	ANSI Common Lispのマクロでのmy-let
(define-syntax my-let (syntax-rules () ((_ ((x v) ...) body ...) ((lambda (x ...) body ...) v ...))))	(defmacro my-let (bindings &body body) `((lambda ,(mapcar #'car bindings) ,@body) ,@(mapcar #'cadr bindings)))

でScheme版だと省略符号で上手く回避しているパターン記述に対して、ANSI Common Lispでは与えられたリスト(この場合はbindings)の要素を操作して切り張りしているのはそれが理由です。カンマやカンマアットに続く部分は部分評価が成されるので、バッククオートで形作られたテンプレートにその評価結果をハメこんでいるわけです。

これはANSI Common Lispのマクロに於いて良く見かけるテクニックなんで覚えておいた方が良いと思います。かつ、悪名高いネストされたバッククオートと言うのもこれ絡みで良く出てくる現象です。

なお、必ずmapcarじゃないといけないのか、と言うとそう言うわけでもなくって、例えば実践Common Lispの著者であるPeter Seibelはmapcarよりloopを使うのが好みのようです。

mapcarを使ったmy-let	loopを使ったmy-let
(defmacro my-let (bindings &body body) `((lambda ,(mapcar #'car bindings) ,@body) ,@(mapcar #'cadr bindings)))	(defmacro my-let (bindings &body body) `((lambda ,(loop for i in bindings collect (car i)) ,@body) ,@(loop for i in bindings collect (cadr i))))

どちらでもお好きなように。展開形が同じなら、スタイルの違いは大した問題じゃない、と言うのがCommon Lispらしさと言えばらしさです。

二度あることは三度ある

以上がCLのマクロに付いての基本的な概観の全てです。

ところで、LOLでは次の二つの関数が紹介されています。

G-BANG-SYMBOL-PREDICATE	O-BANG-SYMBOL-PREDICATE
(defun g!-symbol-p (s) (and (symbolp s) (> (length (symbol-name s)) 2) (string= (symbol-name s) "G!" :start1 0 :end1 2)))	(defun o!-symbol-p (s) (and (symbolp s) (> (length (symbol-name s)) 2) (string= (symbol-name s) "O!" :start1 0 :end1 2)))

実は殆ど全く同じです。こう言う場合、IDEだとコードをコピペして編集、ってのが一つのやり方なんですが、似たような関数だったらマクロを書いて関数を自動で生成しちゃうと言うのも手です。もちろん、この二つは目的を持って作られた関数なんですが、二度ある事は三度あるとも言いますしね(※)。今後a!-symbol-pなんて関数が欲しくならない、と言う保証もないんで、関数*!-symbol-pを生成するマクロを最後に作ってみましょう。

(defmacro !-symbol-p-generator (str)
  ;; 最初に材料の下処理をやっておく
  (let ((len (1+ (length str))))
    ;; !が付くところの生成と関数名の生成をしておく
    (let ((bang-part (string-upcase (concatenate 'string str "!"))))
      (let ((func-name (intern (concatenate 'string bang-part "-SYMBOL-P"))))
 ;; マクロ本体
 `(defun ,func-name (s)
    (and (symbolp s)
  (> (length (symbol-name s)) ,len)
  (string= (symbol-name s)
    ,bang-part
    :start1 0
    :end1 ,len)))))))

Schemeの衛生的マクロとANSI Common Lispのマクロのおそらく最大の違いは、Common Lispではマクロのテンプレートを生成する前に下処理が出来る辺りです。これがR5RSのマクロでは出来ません。上のマクロ、!-symbol-p-generatorでは、"!"が付く部分(bang-part)と、関数名(func-name)を最初に生成しておいて、マクロのテンプレートにそれらをハメこんでいます。

注意点としては、internは大文字から成る文字列はそのまま素直にシンボルに直してくれるんですが、小文字が混在する場合、|(縦線)込みのシンボルにしてしまいます。

CL-USER> (intern "MY-SYMBOL")
MY-SYMBOL
NIL
CL-USER> (intern "My-Symbol")
|My-Symbol|
NIL
CL-USER> 

ANSI Common Lispはcase-insensitiveなプログラミング言語でした。よって、internで関数名(シンボル)を生成する前に、引数として与える文字列を全て大文字にしておきましょう。

!-symbol-p-generatorは文字列を引数として取って関数"*!-symbol-p"を返すマクロです。macroexpand-1でg!-symbol-pやo!-symbol-pが生成されてるのかどうか確認してみましょう。

CL-USER> (macroexpand-1 '(!-symbol-p-generator "g"))
(DEFUN G!-SYMBOL-P (S)
  (AND (SYMBOLP S) (> (LENGTH (SYMBOL-NAME S)) 2)
       (STRING= (SYMBOL-NAME S) "G!" :START1 0 :END1 2)))
T
CL-USER> (macroexpand-1 '(!-symbol-p-generator "o"))
(DEFUN O!-SYMBOL-P (S)
  (AND (SYMBOLP S) (> (LENGTH (SYMBOL-NAME S)) 2)
       (STRING= (SYMBOL-NAME S) "O!" :START1 0 :END1 2)))
T
CL-USER> 

上手い具合にコードが生成されている模様ですね。実際動かしてみましょうか。

CL-USER> (!-symbol-p-generator "g")
G!-SYMBOL-P
CL-USER> (g!-symbol-p 'hoge)
NIL
CL-USER> (g!-symbol-p 'g!hoge)
T
CL-USER> (g!-symbol-p 'o!hoge)
NIL
CL-USER> (!-symbol-p-generator "o")
O!-SYMBOL-P
CL-USER> (o!-symbol-p 'hoge)
NIL
CL-USER> (o!-symbol-p 'g!hoge)
NIL
CL-USER> (o!-symbol-p 'o!hoge)
T
CL-USER>

もちろん、!-symbol-p-generatorは一文字以上の文字列も受け取って*!-symbol-pを生成出来ます。

CL-USER> (!-symbol-p-generator "bang")
BANG!-SYMBOL-P
CL-USER> (bang!-symbol-p 'hoge)
NIL
CL-USER> (bang!-symbol-p 'g!hoge)
NIL
CL-USER> (bang!-symbol-p 'o!hoge)
NIL
CL-USER> (bang!-symbol-p 'bang!hoge)
T
CL-USER> 

こうなってくると楽しくなってきますね(笑)。

※: 個人的な経験では、小さなREPLを書いてる時良く起こります。例えばアドヴェンチャー・ゲームの入力/表示部分とか。ちょっとだけ内容が違うのに、形式的には全く同じ関数を何度も書いてる事に気づいて嫌になりました。

C言語でやると大体コードがscanf/printfまみれになって、それこそIDEでコードを大量にコピペするケースでしょうが、LispだったらマクロでREPLの概形を書き下して、マクロに関数を自動生成させた方が手っ取り早かったりします。修正するなら生成側のマクロ「だけ」を修正すれば良く、自動生成された関数は勝手に定義しなおされます。ある意味、オブジェクト指向のクラスの継承なんかより遥に強力でしょう。

Schemeの伝統的マクロ

取りあえずこれで #9LISP 014用のメモは全て、です。最後に実装依存ですが、

「やっぱSchemeがいいなあ～～。」

と言う人の為に、いくつかのScheme処理系での伝統的マクロの使い方を紹介しておきます。

• Gauche: デフォルトでdefine-macroと言う形式で利用可能です。


• PLT Scheme: (require mzlib/defmacro)を評価した後、define-macroと言う形式で利用可能です。


• Guile: デフォルトでdefine-macroと言う形式で利用可能です。

この3つは形式的には全て同じなので、どれもGaucheプログラミング(立ち読み版)の示唆通り動くでしょう。

;;; PLT Scheme の場合
Welcome to MzScheme v4.2.5 [3m], Copyright (c) 2004-2010 PLT Scheme Inc.
> (require mzlib/defmacro)
> (define-macro (my-let varlst . body)
    (let ((vars (map car varlst))
   (exps (map cadr varlst)))
      `((lambda ,vars ,@body) ,@exps)))
> (my-let ()
   (+ 3 4))
7
> (my-let ((x 7)
    (y 10))
   (+ x y))
17
> (my-let ((x 3))
   (my-let ((x 10)
     (y (* x x)))
    y))
9
>
 
;;; Guile の場合
guile> (define-macro (my-let varlst . body)
  (let ((vars (map car varlst))
        (exps (map cadr varlst)))
    `((lambda ,vars ,@body) ,@exps)))
guile> (my-let ()
        (+ 3 4))
7
guile> (my-let ((x 7)
  (y 10))
        (+ x y))
17
guile> (my-let ((x 3))
        (my-let ((x 10))
         (y (* x x)))
        y)
guile> (my-let ((x 3))
        (my-let ((x 10)
   (y (* x x)))
         y))
9
guile> 

パラメータ・リストの記述方法がSchemeらしい、ですが、基本これでCommon Lisp相当のマクロを記述する事が可能です。