1. И так, посмотрим, что можно сделать с помощью замыканий. В стандарт ANSI Common Lisp включена Common Lisp Objective System, реализующая полноценная ООП система. Станадрт же Scheme (R5RS как я понимаю текущий) описан значительно более меньший функционал, который должен быть реализован в интерпретаторе/компиляторе Схемы и поддержка ООП в нем не декларирована. Но поскольку считается, что Лисп позволяет реализовать любую парадигму программирования без измененния базового интерпретатора/компилятора, попробуем реализовать простую ООП систему с помощью замыканий.

;(module object) ;;; required by bigloo

;(require-extension syntax-case) ;;; required by chicken

(define-syntax define-object
 (syntax-rules (:)
 ((_ name : class)
 (define name (class 'name 'class)))))

(define (error-class name class)
 (let* ((name name)
 (class class)
 (errors (list 'type-mismatch 'unknown-action))
 (actions (list 'get-errors 'get-actions 'msg))
 (msg (lambda (args)
 (for-each display args)
 (newline)))
 (error (lambda args 
 (msg (cons "* ERROR: " (cons name (cons ": " args)))))))
 (lambda (action . value)
 (cond ;-- GET-actions:
 ((eq? action 'get-errors) errors)
 ((eq? action 'get-actions) actions)
 ;-- OTHER-actions:
 ((eq? action 'msg) (msg value))
 ;-- ERROR-actions:
 ((eq? action 'type-mismatch)
 (if (pair? value)
 (error "wrong type of `" (car value) 
 "' must be " (cadr value))
 (error "not enough parameters in 'type-mismatch message")))
 (else (error "unknown action `" action "'") 
 'unknown-action)))))

(define (base-class name class)
 (let ((name name)
 (class class)
 (error (error-class name class))
 (actions (list 'get-name 'get-class 'msg 'get-actions)))
 (lambda (action . value)
 (cond ;-- GET-actions:
 ((eq? action 'get-name) name)
 ((eq? action 'get-class) class)
 ((eq? action 'get-actions) (cons actions (error 'get-actions)))
 ;-- OTHER-actions:
 (else (apply error (cons action value)))))))

(define (parent-class name class)
 (let ((name name)
 (class class)
 (parent (base-class name class))
 (actions (list 'get-int-field 'set-int-field))
 (int-field 0))
 (lambda (action . value)
 (cond ;-- GET-actions:
 ((eq? action 'get-int-field) int-field)
 ((eq? action 'get-actions) (cons actions (parent 'get-actions)))
 ;-- SET-actions:
 ((eq? action 'set-int-field)
 (if (integer? (car value))
 (set! int-field (car value))
 (parent 'type-mismatch 'int-field 'integer)))
 ;-- OTHER-actions:
 (else (apply parent (cons action value)))))))

(define (child-class name class)
 (let ((name name)
 (class class)
 (parent-obj (parent-class name class))
 (base-obj (base-class name class))
 (actions (list 'get-str-field 'set-str-field))
 (str-field ""))
 (lambda (action . value)
 (cond ;-- GET-actions:
 ((eq? action 'get-str-field) str-field)
 ((eq? action 'get-actions)
 (cons actions (parent-obj 'get-actions)))
 ;-- SET-actions:
 ((eq? action 'set-str-field)
 (if (string? (car value))
 (set! str-field (car value))
 (parent-obj 'type-mismatch 'str-field 'string)))
 ;-- OTHER-actions:
 (else (apply parent-obj (cons action value)))))))

;-- TESTING:

(define-object base-obj : base-class)
(define-object parent-obj : parent-class)
(define-object child-obj : child-class)

(define (test-base-obj)
 (let ((obj base-obj))
 (obj 'msg " ---- base-obj ----"
 "\nclass : " (obj 'get-class)
 "\nname : " (obj 'get-name)
 "\nactions : " (obj 'get-actions)
 "\nerrors : " (obj 'get-errors))
 (newline)
 (obj 'action)
 (newline)))

(define (test-parent-obj)
 (let ((obj parent-obj))
 (obj 'msg " ---- parent-obj ----"
 "\nclass : " (obj 'get-class)
 "\nname : " (obj 'get-name)
 "\nactions : " (obj 'get-actions)
 "\nerrors : " (obj 'get-errors)
 "\nint-field : " (obj 'get-int-field))
 (newline)
 (obj 'set-int-field 12)
 (obj 'set-int-field "df")
 (obj 'msg "\nint-field : " (obj 'get-int-field))
 (newline)))

(define (test-child-obj)
 (let ((obj child-obj))
 (obj 'msg " ---- child-obj ----"
 "\nclass : " (obj 'get-class)
 "\nname : " (obj 'get-name)
 "\nactions : " (obj 'get-actions)
 "\nerrors : " (obj 'get-errors)
 "\nstr-field : " (obj 'get-str-field) 
 "\nint-field : " (obj 'get-int-field))
 (newline)
 (obj 'set-str-field "abc")
 (obj 'set-int-field 5)
 (obj 'some-action)
 (obj 'set-str-field 'abc)
 (obj 'msg "\nstr-field : " (obj 'get-str-field) 
 "\nint-field : " (obj 'get-int-field))
 (newline)))

(test-base-obj)
(test-parent-obj)
(test-child-obj)

Как видно из кода система получилась в стиле "передачи сообщений объекту", где в качестве "объектов" выступают функции-замыкания, сохраняющие свое состояние(поля) а в качестве "классов" -- функции высшего порядка, возвращающие(создающие) "объекты".

2. Как известно Лисп превосходно подходит для реализации языков, например всяких DSL/eDSL. Говорят что на Лиспе Вы не описываете как решить задачу, а подгоняете язык под задачу до тех пор, пока не создадите язык, на котором задача формулируется легко и просто. Приведу несколько пример, как можно расширить синтаксис/семантику Scheme.

2.1. Один мой знакомый очень любит язык Pascal. Специально для него вот немного сахарку в Схему, предоставляющую пару паскалеподобных конструкций:

(define-syntax for
 (syntax-rules (:= to do)
 ((_ i := a to n do e ...)
 (if (< a n)
 (let ((i a) 
 (f (lambda (i f)
 (if (<= i n)
 (begin
 e ...
 (f (+ i 1) f))))))
 (f i f))))))

(define-syntax while
 (syntax-rules (do)
 ((_ s do e ...)
 (let ((f (lambda (f)
 (if s
 (begin
 e ...
 (f f))))))
 (f f)))))

(define-syntax repeat
 (syntax-rules (until)
 ((_ (e ...) until s)
 (let ((f (lambda (f)
 (begin
 e ...
 (if s (f f))))))
 (f f)))))

(define integer integer?)
(define real real?)
(define char char?)
(define TString string?)
(define TVector vector?)
(define TPair pair?)
(define TList list?)

(define-syntax function
 (syntax-rules (:)
 ((_ name ((a1 : t1) (a2 : t2) ...) : type 
 (e1 e2 ...))
 (define (name a1 a2 ...)
 (let 
 ((result
 (if (and (t1 a1) (t2 a2) ...)
 (begin e1 e2 ...)
 (begin
 (message "* ERROR: type mismatch in function ``(" 'name 
 " " '((a1 : t1) (a2 : t2) ...) 
 " : " 'type ")'':\n (" 'name 
 " " `,(list a1 a2 ...) ")")
 'null))))
 (if (type result)
 result
 (if (eq? result 'null)
 (message " function returns `null'")
 (message "* ERROR: wrong result type in function ``(" 'name
 " " '((a1 : t1) (a2 : t2) ...)
 " : " 'type ")'':\n (" 'name
 " " `,(list a1 a2 ...) ") -> " result))))))))

(define-syntax procedure
 (syntax-rules (:)
 ((_ name ((a1 : t1) (a2 : t2) ...) 
 (e1 e2 ...))
 (define (name a1 a2 ...)
 (if (and (t1 a1) (t2 a2) ...)
 (begin
 (begin e1 e2 ...)
 'null)
 (message "* ERROR: type mismatch in procedure (" 'name 
 " " '((a1 : t1) (a2 : t2) ...) 
 "):\n (" 'name " " `,(list a1 a2 ...) ")"))))))

(define-syntax [
 (syntax-rules (.. ])
 ((_ x0 .. xN ])
 (let* ((dx (if (< x0 xN) 1 -1)) 
 (f (lambda (x f)
 (if (= x xN)
 (cons x '())
 (cons x (f (+ x dx) f))))))
 (f x0 f)))
 ((_ x0 x1 .. xN ])
 (let* ((dx (- x1 x0))
 (f (lambda (x f)
 (if (> x xN)
 '()
 (cons x (f (+ x dx) f))))))
 (f x0 f)))))

(message ([ 1 .. 20 ]))
(message ([ 1 3 .. 20 ]))
(message (apply + ([ 1 3 .. 20 ])))

;------------------------------

(function summ-func ((a : integer) (b : integer)) : integer 
 ( ;begin
 (+ a b)
 )) ;end

(message (summ-func 1 2))
(message (summ-func 1 2.0))
(message (summ-func 1 2.1))

(function summ-func-2 ((a : integer) (b : integer)) : integer
 ( ;begin
 (cons a b)
 )) ;end

(message (summ-func-2 1 2))

(procedure summ-proc ((a : integer) (b : integer)) 
 ( ;begin
 (display (+ a b))
 (newline)
 )) ;end

(summ-proc 1 2)
(summ-proc 1 2.0)
(summ-proc 1 2.1)

;------------------------------

(display "for i in [1..10] do : ")

(for i := 1 to 10 do
 (display i)
 (display " "))

(newline)

(display "while i < 10 do : ")

(define x 0)

(while (< x 10) do
 (display x)
 (display " ")
 (set! x (+ x 1)))

(newline)

(display "repeat until x < 10 : ")

(set! x 0)

(repeat 
 ((display x)
 (display " ")
 (set! x (+ x 1)))
 until (< x 10))

(newline)

2.2. А вот пример реализации простейшей базы данных и sql-еподобных языковых конструкций для работы с ней(здесь был использован опыт из пункта 1 про ООП)

(define *current-db* '())

(define number (cons 'number number?))
(define char (cons 'char char?))
(define varchar (cons 'varchar string?))
(define bool (cons 'bool boolean?))
(define int (cons 'int integer?))
(define symbol (cons 'symbol symbol?))

(define (make-field name type default-value)
 (let ((name name)
 (type type)
 (defval default-value)
 (vals '()))
 (lambda (action . args)
 (cond
 ((eq? action 'get-name) name)
 ((eq? action 'get-values) vals)
 ((eq? action 'get-type) (car type))
 ((eq? action 'get-value)
 (if (not (null? args))
 (if (integer? (car args))
 (let find-val ((ls vals)
 (n (car args)))
 (if (null? ls)
 '()
 (if (= n 0)
 (car ls)
 (find-val (cdr ls) (- n 1))))))
 '()))
 ((eq? action 'set-value)
 (if (not (null? args))
 (if ((cdr type) (car args))
 (if (not (null? (cdr args)))
 (if (integer? (cadr args))
 (set! vals (set-ref vals (car args) (cadr args))))))))
 ((eq? action 'add-value)
 (if (not (null? args))
 (if ((cdr type) (car args))
 (set! vals (append vals (list (car args)))))
 (set! vals (append vals (list defval)))))))))

(define (make-db name)
 (let ((name name)
 (tables '()))
 (lambda (action . args)
 (cond ((eq? action 'add-table)
 (set! tables (cons args tables)))
 ((eq? action 'get-tables)
 (if (not (null? tables))
 (map car tables)))
 ;tables)
 (else
 (if (symbol? action)
 (let 
 ((result (let find-table ((table action)
 (tables tables))
 (if (null? tables)
 'null
 (if (eq? table (caar tables))
 (cadar tables)
 (find-table table (cdr tables)))))))
 (if (eq? result 'null)
 (lambda args
 (message "*ERROR* " name ": no tables with name `" action "' found\n"))
 result))
 (message "*ERROR* " name ": wrong type of action")))))))

(define (make-table name columns)
 (let ((name name)
 (columns columns))
 (lambda (action . args)
 (cond 
 ((eq? action 'get-name) name)
 ((eq? action 'get-columns) 
 (map (lambda (col) 
 (cons (col 'get-name) (col 'get-values)))
 columns))
 ((eq? action 'select-column)
 (if (not (null? args))
 (if (symbol? (car args))
 (let find-cols ((cols columns))
 (cond
 ((null? cols) 'null)
 ((eq? ((car cols) 'get-name) 
 (car args))
 (cons ((car cols) 'get-name) 
 ((car cols) 'get-values)))
 (else (find-cols (cdr cols))))))))
 ((eq? action 'append-record)
 (let add-values ((cols columns)
 (vals args))
 (if (not (null? cols))
 (if (null? vals)
 (begin
 ((car cols) 'add-value ((car cols))
 (add-values (cdr cols) '())))
 (begin
 ((car cols) 'add-value (car vals))
 (add-values (cdr cols) (cdr vals)))))))))))


(define-syntax use
 (syntax-rules ()
 ((_ db)
 (set! *current-db* db))))

(define-syntax create
 (syntax-rules (field : table database)
 ((_ field name : type (default-value))
 (define name (make-field 'name type default-value)))
 ((_ table name ((f t v) ...))
 (let ((table (make-table 'name 
 (list (make-field 'f t v)
 ...))))
 (*current-db* 'add-table (table 'get-name) table)))
 ((_ database name)
 (define name (make-db 'name)))))

(define-syntax insert
 (syntax-rules (into values:)
 ((_ into table values: v ...)
 ((*current-db* 'table) 'append-record v ...))))

(define print 
 (lambda (ls)
 ;(message ls)
 (if (pair? ls)
 (if (not (null? (car ls)))
 (begin
 (for-each (lambda (x) 
 (display x) 
 (display "\t"))
 (map car ls))
 (display "\n")
 (print (map cdr ls)))))))

(define-syntax select
 (syntax-rules (* from)
 ((_ * from table)
 (print ((*current-db* 'table) 'get-columns)))
 ((_ (field ...) from table)
 (print (list ((*current-db* 'table) 'select-column 'field)
 ...)))
 ((_ ((f1 ...) ...) (from t1 ...))
 (begin
 (let ((table 't1))
 (message ((*current-db* table) 'get-name) ": ")
 (print (list ((*current-db* table) 'select-column 'f1)
 ...))
 (newline))
 ...))))

;------------------------------------------------------

(define-syntax test
 (syntax-rules ()
 ((_ (f ...))
 (begin
 (message ";;; " '(f ...) ": ")
 (f ...)))
 ((_ displayfunc (f ...))
 (begin
 (message ";;; " '(f ...) ": ")
 (displayfunc (f ...))))))

;------------------------------------------------------

(define main-test
 (lambda ()
 (create database test-db)
 (create database other-db)

 (use test-db)

 (create table table-1 ((name varchar "")
 (age int 0)
 (sex symbol 'male)))

 (create table table-2 ((name varchar "")
 (age int 0)
 (sex symbol 'male)
 (prof varchar "")))

 (test message (*current-db* 'get-tables))
 (test message ((test-db 'table-1) 'get-columns))
 (test message ((test-db 'table-2) 'get-columns))

 (insert into table-1 values: "vasya" 22 'male)
 (insert into table-1 values: "kolya" 24 'male)

 (test message ((*current-db* 'table-1) 'get-columns))
 (test message ((*current-db* 'table-1) 'select-column 'age))

 (test (select (name age) from table-1))
 (test (select * from table-1))

 (insert into table-2 values: "lena" 23 'female "manager")

 (test (select * from table-2))
 (test (select ((name age) (name sex prof)) (from table-1 table-2)))
 (test (select * from table-2))

 (use other-db)

 (test (select * from table-2))

 (create table table-3 ((id int 0) 
 (name varchar "") 
 (f_name varchar "")
 (dep_id int 0)))

 (test (select * from table-3))

 (insert into table-3 values: 1 "name" "family name" 2)

 (test (select * from table-3))

 (use test-db)))


(define field-object-test
 (lambda ()
 (create field age : int (0))
 
 (test message (age 'get-name))
 (test message (age 'get-values))
 (test message (age 'get-value))
 (test message (age 'get-value 2))
 
 (age 'add-value 23)
 
 (test message (age 'get-value 0))
 (test message (age 'get-values))
 
 (age 'set-value 25 0)
 
 (test message (age 'get-values))))

;(field-object-test)

(main-test)

2.3. А теперь попробуем реализовать свой язык, например нечто похожее на Форт, ибо он, пожалуй, еще проще Лиспа:

(define ~ `~)
(define begin-declare `[)
(define delim-declare `|)
(define end-declare `])
(define if-expr `if)
(define else-expr `else)
(define then-expr `then)
(define assign `>>)
(define norm-recursion 'normal)
(define tail-recursion 'tail)

(define basic-dictionary
 (list
 `(+ ~ ,(list +))
 `(- ~ ,(list -))
 `(* ~ ,(list *))
 `(/ ~ ,(list /))
 `(> ~ ,(list >))
 `(< ~ ,(list <))
 `(^ ~ ,(list (lambda args (cdr args))))
 `(& ~ ,(list (lambda args (car args))))
 `(*> ~ ,(list (lambda args (apply printf args) '())))
 `(@> ~ ,(list (lambda args (apply printl args) '())))
 `(true ~ ,(list #t))
 `(false ~ ,(list #f))
 `(null? ~ ,(list (lambda args (null? args))))
 ))

(define eof-error "unexpected EOF")
(define syntax-error "wrong syntax")


(define (declare name text)

 (define (make-body params body text braces)
 (cond

 ((null? text)
 (error declare "`" name "': " eof-error))

 ((eq? (car text) begin-declare)
 (make-body
 params
 (cons (car text) body)
 (cdr text)
 (+ braces 1)))

 ((eq? (car text) end-declare)
 (if (= 0 braces)
 (list
 (list
 name
 params
 (reverse body))
 (cdr text))
 (make-body
 params
 (cons (car text) body)
 (cdr text)
 (- braces 1))))
 (else
 (make-body
 params
 (cons (car text) body)
 (cdr text)
 braces))))

 (define (make-head params text)
 (cond

 ((null? text)
 (error declare "`" name "': " eof-error))

 ((or (eq? (car text) begin-declare)
 (eq? (car text) end-declare)
 (not (symbol? (car text))))
 (error declare "`" name "': " syntax-error))

 ((eq? (car text) delim-declare)
 (make-body
 (if (null? params) ~ params)
 '()
 (cdr text)
 0))

 (else
 (make-head
 (cons (car text) params)
 (cdr text)))))

 (make-head '() text))


(define (make-then-else text)

 (define (make-t-e then-text else-text text)
 (cond

 ((null? text)
 (error make-then-else eof-error))

 ((eq? (car text) else-expr)
 (make-t-e 
 '() 
 then-text 
 (cdr text)))

 ((eq? (car text) then-expr)
 (list
 (reverse then-text)
 (reverse else-text)
 (cdr text)))

 (else
 (make-t-e
 (cons (car text) then-text)
 else-text
 (cdr text)))))

 (make-t-e '() '() text))


(define (make-env stack word)

 (define (make-e stack params env)
 (cond

 ((null? params)
 (list env stack))

 ((null? stack)
 (error make-env eof-error))

 (else
 (make-e
 (cdr stack)
 (cdr params)
 (cons
 (list (car params) ~ (list (car stack)))
 env)))))

 (make-e stack word '()))


(define (redeclare word words)
 (define (make-words word head tail)
 (cond
 ((null? tail)
 (reverse head))
 ((eq? (car word) (caar tail))
 (append
 (reverse head)
 (cons word (cdr tail))))
 (else
 (make-words
 word
 (cons (car tail) head)
 (cdr tail)))))
 (make-words word '() words))


(define (*iter* stack text words env recursion-type)
 ;(printl (length words) (length env))
 ;(printl (length stack) (length text))
 ;(printl words)
 ;(printl env)
 (cond

 ((null? text) stack)
 
 ((or (number? (car text))
 (boolean? (car text))
 (char? (car text))
 (string? (car text)))
 (*iter*
 (cons (car text) stack)
 (cdr text)
 words
 env
 recursion-type))
 
 ((symbol? (car text))
 (let ((sym (car text)))
 (cond

 ((eq? sym begin-declare)
 (let ((word/text 
 (declare (cadr text) (cddr text))))
 (*iter*
 stack
 (cadr word/text)
 (if (eq? recursion-type norm-recursion)
 (cons (car word/text) words)
 (redeclare (car word/text) words))
 env
 recursion-type)))

 ((eq? sym if-expr)
 (let ((condition (car stack)) 
 (then/else/text
 (make-then-else (cdr text))))
 (if condition
 (*iter*
 (cdr stack)
 (append (car then/else/text)
 (caddr then/else/text))
 words
 env
 recursion-type)
 (*iter*
 (cdr stack)
 (append (cadr then/else/text)
 (caddr then/else/text))
 words
 env
 recursion-type))))

 ((eq? sym assign)
 (*iter*
 '()
 (cddr text)
 (cons (list (cadr text) ~ stack)
 words)
 env
 recursion-type))

 (else
 (let ((word
 (cond 
 ((assoc sym env) => (lambda (x) x))
 ((assoc sym words) => (lambda (x) x))
 (else
 (begin
 (error *iter* "word `" sym 
 "' not found in dictionary")
 (list printl))))))
 (cond

 ((eq? (cadr word) ~)
 (*iter*
 stack
 (append (caddr word) (cdr text))
 words
 env
 recursion-type))

 ((null? (cdr text))
 (let ((env/stack
 (make-env stack (cadr word))))
 (*iter*
 (cadr env/stack)
 (append (caddr word) (cdr text))
 words
 (car env/stack)
 tail-recursion)))

 (else
 (let ((env/stack
 (make-env stack (cadr word))))
 (*iter*
 (cadr env/stack)
 (append
 (*iter*
 '()
 (caddr word)
 (append env words)
 (car env/stack)
 norm-recursion)
 (cdr text))
 words
 env
 recursion-type)))))))))

 (else
 (let ((result
 (apply
 (car text)
 (reverse stack))))
 (*iter*
 '()
 (if (null? result)
 (cdr text)
 ((if (pair? result) append cons) result (cdr text)))
 words
 env
 recursion-type)))))


(define (run ls)
 (*iter* '() ls basic-dictionary '() norm-recursion))

(define (interpretator)
 (let 
 ((result
 (run `(
 1 2 7 + 5 6 - ; (1 +2 +7) -5 -6 = 10 -5 -6 = -1 ; stack: < -1 ]
 
 [ a | 5 + ] ; let a = f(ls) = (ls 5 +)
 [ x | 5 ] ; let x = 5
 ; stack: < -2 -1 ]
 -2 a ; a(-2 -1) = -2 -1 +5 = 2 ; stack: < 2 ]
 
 [ square x | x x * ] ; let square = f(x) = x * x
 ; stack: < 2 2 ]
 2 square ; square(2) = 2 * 2 = 4 ; stack: < 4 2 ]
 
 [ quad x | ; let quad = f(x) =
 x square square ] ; square( square(x) )

 quad ; quad(4) = square( square(4) ) = square(16) = 256 
 ; stack < 256 2 ]
 x a ; stack < 5 256 2 ]
 ; a(5 256 2) = +5 +256 +2 +5 = 268 ; stack: < 268 ]
 1500 ; stack: < 1500 268 ]

 [ b x y | ; let b = f(x, y) =
 x y > if ; if (x > y) then
 3 quad else ; square(x)
 x square then ] ; else quad(3)

 b ; b( 268, 1500 ) ; stack: < 81 ]
 >> xx ; let xx = 81
 xx null? if ; if (xx == null) then
 xx ^ else ; 0
 0 then ; else cdr(xx) ; stack: < ]
 xx @> ; printl(xx) = printl( 81 )
 
 [ yy | 123 ] ; let yy = 123 ; -- "global" yy
 [ def x | ; let def = f(x) =
 x xx > if ; if (x > xx) then
 [ yy | xx ] else ; let yy = x ; "local" yy
 [ yy | x ] then ; else let yy = xx ; "local" yy
 yy @> ] ; printl(yy)
 
 80 def ; def(80) = (80 > 81)? = false => let yy = xx = 81 => printl(81)
 82 def ; def(82) = (82 > 81)? = true => let yy = x = 82 => print(82)
 yy @> @> ; printl(yy) = print(123) ; "global" yy
 
 [ n? |
 null? if
 1 else
 0 then ]
 
 n? 2 n? @>

 [ abs x |
 x 0 < if
 x else
 x -1 * then ]
 
 2 abs -2 abs @> @>
 
 [ fac n |
 n 2 < if
 n 1 - fac n * else
 1 then ]
 
 "recursive factorial: " @>
 "34 ! = " *> 34 fac @>
 @>

 [ mul x y | x y * ]

 [ test x |
 x "! = " *> 
 x fac-i @> ]

 [ fac-i n |
 [ f-iter n acc |
 2 n > if
 n 1 - acc n mul f-iter 
 else
 acc 
 then ]
 n 1 f-iter ]
 
 "iterative factorial: " @>
 12 test

 [ add x y | x y + ]

 [ cycle x y |
 [ abc | 2 ]
 0 x < if
 y *> x y 1 add cycle 
 then ]
 
 1 1 cycle
 ))))
 (display "done: stack: ")
 (if (null? result)
 (display "()")
 (apply printf result))
 (newline)))

(interpretator)

Как видно из кода на вновьпридуманном "форте" в его интерпретаторе реализована оптимизация хвостовой рекурсии, в конце приведена проверка этого утверждения -- функция [ cycle x y | ... ] . Я на своем EeePC 1000HD оборвал цикл на 1144131-й итерации, ибо надоело ждать (на работу цикла ушло ~ 5 -- 10 минут). Если кто захочет проверить, отпишитесь о результатах, на какой итерации остановились или был Stack overflow. =) Тем не менее факториал 12345 функция fac-i считает запросто =)

На сегодня все.

UPD: я совсем забыл про словарь words, он разрастался при любом типе рекурсии, но я это исправил и поправил соответствующим образом код в статье