Элементы функционального программирования [2] с переменным успехом используются в языках самых разных стилей. Форт в этом отношении не исключение. Впрочем, чаще всего речь идёт лишь об ограниченном применении функций высшего порядка. Для более свободного использования техники функционального программирования нужно, в первую очередь, освободить программиста от ручного управления памятью. Иными словами, необходима сборка мусора. C подобной целью обычно проектируют очередной диалект Форта, как это было сделано в случае с Postscript и Joy.

В своей статье я предлагаю иной подход: S-выражения [3], используемые в семействе языков Lisp/Scheme, реализованы в виде компактного ANS Forth-расширения на самом Форте. При этом исследуются некоторые вопросы практического применения этого расширения.

Элемент S-выражения представляется в виде четвёрки:

: .s-mark ;
: .s-tag [ 1 CELLS ] LITERAL + ;
: .s-car [ 2 CELLS ] LITERAL + ;
: .s-cdr [ 3 CELLS ] LITERAL + ;
: /s-obj [ 4 CELLS ] LITERAL ;

Содержимое полей .s-car и .s-cdr зависит от поля .s-tag, которое хранит адрес определяющей процедуры. В текущей реализации атомами могут быть число или адрес слова Форта. Можно легко добавить в систему и атомы иных типов, изменив соответствующие поля.

Сборка мусора организована на основе классического алгоритма пометить и собрать(mark&sweep) [2]. Имеется три источника ячеек, за которыми необходимо проследить на стадии пометки:

1. стек локальных S-выражений s-locals, соответствующий стеку параметров Форта,
2. стек s-calls, аналогичный стеку возвратов,
3. список s-globals, связывающий текущие глобальные переменные, в которых хранятся S-выражения.

Служебное слово s-reserve подготавливает сборщик мусора к работе, устанавливая соответствующие служебные переменные и составляя список свободных ячеек. Для вызова ему требуется указать адрес новой кучи и количество содержащихся в ней ячеек.

Для работы с s-locals имеются служебные слова p->s и s->p, отвечающие за перенос значения со стека параметров Форта на данный стек и обратно, а также вполне очевидные s-dup, s-drop, s-swap и s-over. Для работы с s-calls имеются слова s->c, c->s и c-pick, которое копирует элемент из s-calls на вершину s-locals. Наконец, для работы с глобальными S-переменными предназначено определяющее слово s-variable. Доступ к определяемым переменным осуществляется с помощью get и set.

С помощью ->s в куче размещается число, указанное в качестве аргумента, а соответствующий указатель помещается на s-locals. Слово xt->s работает аналогичным образом для адресов слов Форта. Слово s-> снимает элемент-указатель со стека s-locals и выполняет связанную с этим элементом определяющую процедуру. Если элемент является парой, указатель на неё возвращается на s-locals, если это число, оно помещается на стек параметров Форта, и если, наконец, элемент оказывается адресом слова Форта, это слово выполняется. Данная схема позволяет единообразно работать с атомами различных типов. Слово s-execute выполняет полученное в качестве аргумента S-выражение, как программу, последовательно вызывая для каждого её элемента слово s->. Программой может быть список, точечная пара или атом. Для поддержки вложенного исполнения S-выражений используется стек s-calls.

Для отладки имеется слово .free, сообщающее о расходе памяти и .locals, которое информирует о текущей глубине стека s-locals. Слово .se печатает на экране S-выражение, указанное в качестве аргумента.

В своём расширении я реализовал несколько процедур, оперирующих S-выражениями в духе Scheme [4]. Ниже приведены некоторые примеры их использования. Для краткости введено слово n в качестве синонима ->s.Для более удобного использования слов Форта в качестве аргументов функций высшего порядка, оперирующих S-выражениями, введены следующие слова-обёртки: 1pr(одноместный предикат, при использовании вместе с for-each pr можно читать, как procedure), 1op и 2op(одноместная и двухместная функции).

Ниже приводится чуть более расширенный пример:

: subsets' ( s: e x -- s: e y ) s-over s-swap cons ;
: subsets ( s: x -- s: y )
   s-dup null? IF s-drop () 1 list EXIT THEN
   s-dup s->c cdr RECURSE c->s car s-over
   ['] subsets' xt->s map s-swap s-drop append ;

s( 1 n 2 n 3 n )s subsets .se
( () ( 3 ) ( 2 ) ( 2 3 ) ( 1 ) ( 1 3 ) ( 1 2 ) ( 1 2 3 ) )

Слово subsets порождает все подмножества данного множества.Джон Бэкус в своей знаменитой тьюринговской лекции [1] предложил особый стиль функционального программирования без переменных. Попробуем реализовать на Форте пример умножения матриц в этом стиле.

Для начала нам понадобится слово trans, транспонирующее матрицу:

: trans ( s: x -- s: y )
   s-dup car null? IF s-drop () EXIT THEN s-dup s->c
   ['] car xt->s map c->s ['] cdr xt->s map RECURSE cons ;

s( s( 1 n 2 n )s s( 3 n 4 n )s )s trans .se
( ( 1 3 ) ( 2 4 ) )

Теперь дело за APL-подобными /+ и /*, и aa(apply-to-all, применить ко всем):

: /+ ( s: x -- s: y ) 0 ->s ['] + 2op fold ;
: /* ( s: x -- s: y ) 1 ->s ['] * 2op fold ;
: aa ( f s: x -- s: y ) xt->s map ;

s( 1 n 3 n 5 n )s /+ .se
9
s( 1 n 3 n 5 n )s /* .se
15

К этому моменту мы в состоянии написать функцию, вычисляющую внутреннее произведение:

: ip ( s: x -- s: y ) trans ['] /* aa /+ ;

s( s( 1 n 2 n )s s( 3 n 4 n )s )s ip .se
11

Осталось реализовать только две вспомогательные функции: distl (дистрибутивно слева) и distr (дистрибутивно справа):

: cadr cdr car ;

: distl' ( s: x e -- s: y ) s->c s-dup c->s 2 list ;
: distl ( s: x -- s: y )
   s-dup car s-swap cadr ['] distl' aa s-swap s-drop ;
: distr' ( s: x e -- s: y ) s-over 2 list ;
: distr ( s: x -- s: y )
   s-dup cadr s-swap car ['] distr' aa s-swap s-drop ;

s( 42 n s( 1 n 2 n 3 n )s )s distl .se
( ( 42 1 ) ( 42 2 ) ( 42 3 ) )
s( s( 1 n 2 n 3 n )s 42 n )s distr .se
( ( 1 42 ) ( 2 42 ) ( 3 42 ) )

Матричное умножение будет выглядеть следующим образом:

: mm' ( s: x -- s: y ) ['] ip aa ;
: mm ( s: x -- s: y )
   trans 2 list distr ['] distl aa ['] mm' aa ;

s(
  s( 1 n 0 n 2 n )s
  s( 1 n 3 n 1 n )s )s
s(
  s( 3 n 1 n )s
  s( 2 n 1 n )s
  s( 1 n 0 n )s )s mm .se
( ( 5 1 ) ( 10 4 ) )

В этом разделе представлен набросок реализации потоков(ленивых списков) в том виде, как они описаны в известном учебнике “Структура и интерпретация компьютерных программ” [5].

Введём слово cons-stream, создающее пару, в cdr-части которой будет храниться не готовое значение, как в случае с обычным cons, а задержанный объект, “обещание” вычислить это значение. Если задержанный объект уже был однажды вычислен, следует заменить его его результатом, чтобы избежать повторных ненужных вычислений. Этой работой занимается слово stream-cdr. Для реализации запоминания используется флаг, который cons-stream устанавливает в состояние FALSE.

: cons-stream ( s: x y -- s: z ) FALSE ->s cons cons ;
: stream-cdr ( s: x -- s: y )
   cdr s-dup cdr s-> IF car EXIT THEN
   TRUE ->s s-over set-cdr! s-dup s->c
   car s-execute s-dup c->s set-car! ;

1 n s( 2 n () cons-stream )s cons-stream
s-dup .se
( 1 ( ( 2 () . 0 ) ) . 0 )
s-dup stream-cdr car .se
2
.se
( 1 ( 2 () . 0 ) . -1 )

Приведённый выше пример может подсказать идею организовать циклическую структуру, наподобие следующей(следует соблюдать осторожность при выведении циклов на печать):

s-variable 'ones
: ones 'ones get ;
1 n ' ones xt->s cons-stream 'ones set

ones .se
( 1 ones . 0 )
ones stream-cdr stream-cdr stream-cdr car .se
1

Слово '.atom было переопределено, чтобы иметь возможность распечатывать имена слов Форта в S-выражениях.

Отвлекаясь, стоит заметить, что в более сложной реализации потоков имело бы смысл организовать рекурсию на уровне S-выражений, в виде специальной конструкции для организации произвольных циклов внутри списочной структуры.

Мы получили возможность создавать простейшие бесконечные потоки. Чтобы перевести несколько первых элементов потока в обычный список, введём слово take:

: take ( n s: x -- s: y )
   DUP IF s-dup car s-swap stream-cdr 1- RECURSE cons EXIT THEN
   DROP s-drop () ;

ones 10 take .se
( 1 1 1 1 1 1 1 1 1 1 )

Слово from порождает бесконечный поток целых чисел, начиная с заданного числа. Замечу, что в отсутствие стандартного способа обратиться к адресу определяемого слова, мне пришлось прибегнуть к помощи VARIABLE.

VARIABLE 'from
: from ( n -- s: x )
   DUP ->s s( SWAP 1+ ->s 'from @ xt->s )s cons-stream ;
' from 'from !

1 from 10 take .se
( 1 2 3 4 5 6 7 8 9 10 )

Займёмся теперь потоковым аналогом map, stream-map:

: ?list ( s: x -- s: y ) s-dup pair? IF EXIT THEN 1 list ;

VARIABLE 'stream-map'
: stream-map ( s: x f -- s: y )
   s->c s->c 1 c-pick car 2 c-pick s-execute
   s( c->s c->s ?list 'stream-map' @ xt->s )s cons-stream ;
: stream-map' ( s: x f -- s: y )
   s->c stream-cdr c->s stream-map ;
' stream-map' 'stream-map' !

1 from ' 2* 1op stream-map 10 take .se
( 2 4 6 8 10 12 14 16 18 20 )

Слово ?list необходимо для случая появления слова Форта в качестве функции-аргумента stream-map.

Известно, что при работе с потоками момент вызова задержанной процедуры не определён. Поэтому, в отсутствие автоматического механизма, аналогичного лексическим замыканиям [2], мы не имеем возможности использовать в таких процедурах внешние данные из стека.

Рассмотрим работу stream-map более подробно:

1 from ' 2* 1op stream-map ' 1+ 1op stream-map 10 take .se
( 3 5 7 9 11 13 15 17 19 21 )
1 from ' 2* 1op stream-map ' 1+ 1op stream-map s-dup .se
( 3 ( ( 2 ( ( 1 ( 2 from ) . 0 ) ( s-> 2* ->s ) stream-map' ) . 0 )
( s-> 1+ ->s ) stream-map' ) . 0 )
stream-cdr .se
( 5 ( ( 4 ( ( 2 ( 3 from ) . 0 ) ( s-> 2* ->s ) stream-map' ) . 0 )
( s-> 1+ ->s ) stream-map' ) . 0 )

Видим, что на каждом этапе выполняется минимум необходимой работы по вычислениям. Этот подход выгодно отличается от продемонстрированного в предыдущем разделе.

Попробуем теперь комбинировать потоки:

VARIABLE 'combine-streams'
: combine-streams ( s: x y f -- s: z )
   s->c s->c s->c 1 c-pick car 2 c-pick car 3 c-pick s-execute
   s( c->s c->s c->s ?list 'combine-streams' @ xt->s )s
   cons-stream ;
: combine-streams' ( s: x y f -- s: z )
   s->c s->c stream-cdr c->s stream-cdr c->s combine-streams ;
' combine-streams' 'combine-streams' !

: add-streams ( s: x y -- s: z ) ['] + 2op combine-streams ;
: mul-streams ( s: x y -- s: z ) ['] * 2op combine-streams ;

1 from s-dup mul-streams 10 take .se
( 1 4 9 16 25 36 49 64 81 100 )

На этой основе можно определить поток чисел Фибоначчи:

s-variable 'fibs
: fibs 'fibs get ;
: fibs' ( -- s: x ) fibs stream-cdr fibs add-streams ;
0 n s( 1 n ' fibs' xt->s cons-stream )s cons-stream 'fibs set

fibs 45 take 40 list-tail .se
( 102334155 165580141 267914296 433494437 701408733 )

В заключение, предположим, что нам требуется протабулировать функцию и несколько степеней её конечных разностей. Попробуем реализовать это в виде бесконечных потоков:

: d ( s: x -- s: y )
   s-dup stream-cdr s-swap ['] - 2op combine-streams ;

: y(x) DUP DUP * * ;

0 from ' y(x) 1op stream-map 10 take .se
( 0 1 8 27 64 125 216 343 512 729 )
0 from ' y(x) 1op stream-map d 10 take .se
( 1 7 19 37 61 91 127 169 217 271 )
0 from ' y(x) 1op stream-map d d 10 take .se
( 6 12 18 24 30 36 42 48 54 60 )
0 from ' y(x) 1op stream-map d d d 10 take .se
( 6 6 6 6 6 6 6 6 6 6 )
0 from ' y(x) 1op stream-map d d d d 10 take .se
( 0 0 0 0 0 0 0 0 0 0 )

( S-expressions 20070727, Peter Sovietov )

: .s-mark ;
: .s-tag [ 1 CELLS ] LITERAL + ;
: .s-car [ 2 CELLS ] LITERAL + ;
: .s-cdr [ 3 CELLS ] LITERAL + ;
: /s-obj [ 4 CELLS ] LITERAL ;

VARIABLE s-heap
VARIABLE s-size
VARIABLE s-free

VARIABLE s-locals
VARIABLE s-lp

: lp-reset ( n ) s-locals @ s-lp ! ;
: s-depth ( -- n ) s-lp @ s-locals @ - CELL / ;

: p->s ( x -- s: x ) s-lp @ ! CELL s-lp +! ;
: s->p ( s: x -- x ) [ CELL NEGATE ] LITERAL s-lp +! s-lp @ @ ;
: s-dup ( s: x -- s: x x ) s->p DUP p->s p->s ;
: s-drop ( s: x ) s->p DROP ;
: s-swap ( s: x y -- s: y x ) s->p s->p SWAP p->s p->s ;
: s-over ( s: x y -- s: x y x )
   s->p s->p SWAP OVER p->s p->s p->s ;

VARIABLE s-calls
VARIABLE s-cp

: cp-reset ( n ) s-calls @ s-cp ! ;

: s->c ( s: x -- c: x ) s->p s-cp @ ! CELL s-cp +! ;
: c->s ( c: x -- s: x )
   [ CELL NEGATE ] LITERAL s-cp +! s-cp @ @ p->s ;
: c-pick ( n -- s: x )
   [ CELL NEGATE ] LITERAL * s-cp @ + @ p->s ;

: (pair) ( a ) p->s ;
: (null) ( a ) p->s ;
: (number) ( a ) .s-car @ ;
: (xt) ( a ) .s-car @ EXECUTE ;

CREATE '() /s-obj ALLOT ' (null) '() .s-tag !
: () ( -- s: 0 ) '() p->s ;

VARIABLE s-globals

: s-variable CREATE HERE '() , s-globals @ , s-globals ! ;
: get ( a -- s: x ) @ p->s ;
: set ( a s: x ) s->p SWAP ! ;

: s-reserve ( a n )
   s-size ! s-heap ! '() s-free !
   s-heap @ DUP >R s-size @ /s-obj * +
   BEGIN R@ OVER < WHILE
     FALSE R@ .s-mark !
     ['] (pair) R@ .s-tag !
     s-free @ R@ .s-cdr !
     R@ s-free ! R> /s-obj + >R
   REPEAT R> 2DROP lp-reset cp-reset 0 s-globals ! ;

: s-mark ( a )
   BEGIN DUP '() = IF DROP EXIT THEN
     DUP .s-mark @ IF DROP EXIT THEN
     DUP .s-mark TRUE SWAP !
     DUP .s-tag @ ['] (pair) = WHILE
       DUP .s-car @ RECURSE .s-cdr @
   REPEAT DROP ;
: s-sweep 
   '() s-free ! s-heap @ DUP >R s-size @ /s-obj * +
   BEGIN R@ OVER < WHILE
     R@ .s-mark @ IF FALSE R@ .s-mark !
     ELSE ['] (pair) R@ .s-tag !
       s-free @ R@ .s-cdr ! R@ s-free !
     THEN R> /s-obj + >R
   REPEAT R> 2DROP ;
: gc
   s-locals @ >R s-lp @ BEGIN R@ OVER < WHILE
     R@ @ s-mark R> CELL+ >R REPEAT R> 2DROP
   s-calls @ >R s-cp @ BEGIN R@ OVER < WHILE
     R@ @ s-mark R> CELL+ >R REPEAT R> 2DROP
   s-globals @ BEGIN DUP WHILE DUP @ s-mark
     CELL+ @ REPEAT DROP s-sweep
   s-free @ '() = ABORT" se: gc" ;

: (cons) ( x y -- z )
   s-free @ '() = IF gc THEN
   s-free @ DUP .s-cdr @ s-free ! >R
   R@ .s-cdr ! R@ .s-car ! R> ;
: cons ( s: x y -- s: z )
   s-over s->p s-dup s->p (cons) s-drop s-drop p->s ;

: ->s ( n -- s: n )
   0 (cons) DUP .s-tag ['] (number) SWAP ! p->s ;
: xt->s ( a -- s: a )
   0 (cons) DUP .s-tag ['] (xt) SWAP ! p->s ;
: s-> ( s: x ) s->p DUP .s-tag @ EXECUTE ;

: pair? ( s: x -- ? ) s->p .s-tag @ ['] (pair) = ;
: null? ( s: x -- ? ) s->p '() = ;
: number? ( s: x -- ? ) s->p .s-tag @ ['] (number) = ;
: xt? ( s: x -- ? ) s->p .s-tag @ ['] (xt) = ;

: car ( s: x -- s: y )
   s-dup pair? 0= ABORT" se: car" s->p .s-car @ p->s ;
: cdr ( s: x -- s: y )
   s-dup pair? 0= ABORT" se: cdr" s->p .s-cdr @ p->s ;
: set-car! ( s: x y ) 
   s-dup pair? 0= ABORT" se: set-car!" s->p .s-car set ;
: set-cdr! ( s: x y ) 
   s-dup pair? 0= ABORT" se: set-cdr!" s->p .s-cdr set ;

: list ( n s: ... -- s: x )
   () BEGIN DUP WHILE cons 1- REPEAT DROP ;
: s( ( -- n ) s-depth ;
: )s ( n s: ... -- s: x ) s-depth SWAP - list ;

: eq? ( s: x y -- ? )
   s->p s->p OVER .s-tag @ OVER .s-tag @ = >R
   OVER .s-car @ OVER .s-car @ = >R
   .s-cdr @ SWAP .s-cdr @ = R> AND R> AND ;
: equal? ( s: x y -- ? )
   BEGIN s-dup pair? s-over pair? AND WHILE
     s-over car s-over car RECURSE 0= IF
       s-drop s-drop FALSE EXIT THEN cdr s-swap cdr
   REPEAT eq? ;

: list-tail ( n s: x -- s: y )
   BEGIN DUP WHILE cdr 1- REPEAT DROP ;
: list-ref ( n s: x -- s: y ) list-tail car ;

: s-execute ( s: f )
   BEGIN s-dup pair? WHILE s-dup s->c car s-> c->s cdr
   REPEAT s-dup null? IF s-drop EXIT THEN s-> ;

: for-each-pair ( s: x f )
   BEGIN s-over pair? WHILE s-dup s->c s-over cdr s->c
     s-execute c->s c->s REPEAT s-drop s-drop ;

: last-pair' ( s: x e -- s: e ) s-swap s-drop ;
: last-pair ( s: x -- s: y )
   s-dup cdr ['] last-pair' xt->s for-each-pair ;

: for-each ( s: x f ) ['] car xt->s s-swap cons for-each-pair ;

: length' ( i s: e -- j ) s-drop 1+ ;
: length ( s: x -- n ) 0 ['] length' xt->s for-each ;

: fold ( s: x z f -- s: y ) s->c s-swap c->s for-each ;

: reverse' ( s: x e -- s: y ) s-swap cons ;
: reverse ( s: x -- s: y ) () ['] reverse' xt->s fold ;

: reverse!' ( s: x e -- s: y ) s-dup s->c set-cdr! c->s ;
: reverse! ( s: x -- s: y )
   () s-swap ['] reverse!' xt->s for-each-pair ;

: map' ( s: f x e -- s: y )
   s-swap s->c s-swap s-dup s->c s-execute
   c->s s-swap c->s cons ;
: map ( s: x f -- s: y )
   s-swap () ['] map' xt->s fold reverse! s-swap s-drop ;

: list-copy ( s: x -- s: y ) () map ;

: append ( s: x y -- s: z )
   s-swap s-dup null? IF s-drop EXIT THEN
   list-copy s-dup s->c last-pair set-cdr! c->s ;

: filter' ( s: f x e -- s: y )
   s->c s->c s->c 3 c-pick 1 c-pick s-execute
   c->s c->s c->s IF s-swap cons EXIT THEN s-drop ;
: filter ( s: x f -- s: y )
   s-swap () ['] filter' xt->s fold reverse! s-swap s-drop ;

: 1pr ( a -- s: f ) s( SWAP ['] s-> xt->s xt->s )s ;
: 1op ( a -- s: f )
   s( SWAP ['] s-> xt->s xt->s ['] ->s xt->s )s ;
: 2op ( a -- s: f )
   s( SWAP ['] s-> xt->s s-dup ['] SWAP xt->s xt->s
   ['] ->s xt->s )s ;

( debug )

: (.atom) ( s: x )
   s-dup number? IF s-> . EXIT THEN
   s-dup xt? IF s-drop ." xt " EXIT THEN
   s-dup null? IF s-drop ." () " EXIT THEN
   s-drop ." ? " ;
VARIABLE '.atom ' (.atom) '.atom !
: .atom '.atom @ EXECUTE ;
: .se ( s: x )
   s-dup pair? IF ." ( "
     BEGIN s-dup car RECURSE cdr s-dup pair? 0= UNTIL
     s-dup null? IF s-drop ELSE ." . " .atom THEN ." ) "
   ELSE .atom THEN ;

: gc-free ( -- n )
   s-free @ 0 >R BEGIN DUP '() =
     IF DROP R> EXIT THEN .s-cdr @ R> 1+ >R AGAIN ;
: .free gc-free . ;
: .locals s-depth . ;

HERE 1024 CELLS ALLOT s-locals !
HERE 1024 CELLS ALLOT s-calls !
HERE 1024 /s-obj * ALLOT 1024 s-reserve

Программирование на уровне функций (пример к разделу)

: n ->s ;
: cadr cdr car ;

: trans ( s: x -- s: y )
   s-dup car null? IF s-drop () EXIT THEN s-dup s->c
   ['] car xt->s map c->s ['] cdr xt->s map RECURSE cons ;

: /+ ( s: x -- s: y ) 0 ->s ['] + 2op fold ;
: /* ( s: x -- s: y ) 1 ->s ['] * 2op fold ;
: aa ( f s: x -- s: y ) xt->s map ;

: ip ( s: x -- s: y ) trans ['] /* aa /+ ;

: distl' ( s: x e -- s: y ) s->c s-dup c->s 2 list ;
: distl ( s: x -- s: y )
   s-dup car s-swap cadr ['] distl' aa s-swap s-drop ;
: distr' ( s: x e -- s: y ) s-over 2 list ;
: distr ( s: x -- s: y )
   s-dup cadr s-swap car ['] distr' aa s-swap s-drop ;

: mm' ( s: x -- s: y ) ['] ip aa ;
: mm ( s: x -- s: y )
   trans 2 list distr ['] distl aa ['] mm' aa ;

Ленивые вычисления: потоки (пример к разделу)

: cons-stream ( s: x y -- s: z ) FALSE ->s cons cons ;
: stream-cdr ( s: x -- s: y )
   cdr s-dup cdr s-> IF car EXIT THEN
   TRUE ->s s-over set-cdr! s-dup s->c
   car s-execute s-dup c->s set-car! ;

: take ( n s: x -- s: y )
   DUP IF s-dup car s-swap stream-cdr 1- RECURSE cons EXIT THEN
   DROP s-drop () ;

VARIABLE 'from
: from ( n -- s: x )
   DUP ->s s( SWAP 1+ ->s 'from @ xt->s )s cons-stream ;
' from 'from !

: ?list ( s: x -- s: y ) s-dup pair? IF EXIT THEN 1 list ;

VARIABLE 'stream-map'
: stream-map ( s: x f -- s: y )
   s->c s->c 1 c-pick car 2 c-pick s-execute
   s( c->s c->s ?list 'stream-map' @ xt->s )s cons-stream ;
: stream-map' ( s: x f -- s: y )
   s->c stream-cdr c->s stream-map ;
' stream-map' 'stream-map' !

VARIABLE 'combine-streams'
: combine-streams ( s: x y f -- s: z )
   s->c s->c s->c 1 c-pick car 2 c-pick car 3 c-pick s-execute
   s( c->s c->s c->s ?list 'combine-streams' @ xt->s )s
   cons-stream ;
: combine-streams' ( s: x y f -- s: z )
   s->c s->c stream-cdr c->s stream-cdr c->s combine-streams ;
' combine-streams' 'combine-streams' !

: add-streams ( s: x y -- s: z ) ['] + 2op combine-streams ;
: mul-streams ( s: x y -- s: z ) ['] * 2op combine-streams ;

s-variable 'ones
: ones 'ones get ;
1 n ' ones xt->s cons-stream 'ones set

s-variable 'fibs
: fibs 'fibs get ;
: fibs' ( -- s: x ) fibs stream-cdr fibs add-streams ;
0 n s( 1 n ' fibs' xt->s cons-stream )s cons-stream 'fibs set

: d ( s: x -- s: y )
   s-dup stream-cdr s-swap ['] - 2op combine-streams ;

[1]	John Backus, Can programming be liberated from the von Neumann style?: a functional style and its algebra of programs, Communications of the ACM, v.21 n.8, p.613-641, Aug. 1978. (Имеется перевод: Бэкус Дж. Можно ли освободить программирование от стиля фон Неймана? Функциональный стиль и соответствующая алгебра программ. - Пер. с англ. Мартынюка В. В. - В кн.: Лекции лауреатов премии Тьюринга за первые двадцать лет 1966-1985. - Под ред. Р. Эшенхерста. - М.: Мир, 1993. - с. 84-158). http://www.stanford.edu/class/cs242/readings/backus.pdf
[2]	A. J. Field, Peter G. Harrison: Functional Programming Addison-Wesley, 1988. (Имеется перевод: А. Филд, П. Харрисон. Функциональное программирование. - М.: Мир, 1993).
[3]	John McCarthy. Recursive Functions of Symbolic Expressions and Their Computation by Machine, Part I. Comm. ACM, 3(4):184-195, April 1960. http://www-formal.stanford.edu/jmc/recursive/recursive.html
[4]	R. Kelsey, W. Clinger, J. Rees (eds.), Revised5 Report on the Algorithmic Language Scheme. Higher-Order and Symbolic Computation, Vol. 11, No. 1, September, 1998 and ACM SIGPLAN Notices, Vol. 33, No. 9, October, 1998. http://www.schemers.org/Documents/Standards/R5RS/
[5]	Harold Abelson and Gerald Jay Sussman, with Julie Sussman. Structure and Interpretation of Computer Programs. MIT Press (Cambridge, MA) and McGraw-Hill (New York), 1985. (Имеется перевод: Абельсон Х., Сассман Дж. при участии Сассман Дж. Структура и интерпретация компьютерных программ. - М.: Добросвет, КДУ, 2006). http://mitpress.mit.edu/sicp/