Пётр Советов, peter.sovietov@gmail.com
Элементы функционального программирования [Field] с переменным успехом используются в языках самых разных стилей. Форт в этом отношении не исключение. Впрочем, чаще всего речь идёт лишь об ограниченном применении функций высшего порядка. Для более свободного использования техники функционального программирования нужно, в первую очередь, освободить программиста от ручного управления памятью. Иными словами, необходима сборка мусора. C подобной целью обычно проектируют очередной диалект Форта, как это было сделано в случае с Postscript и Joy.
В своей статье я предлагаю иной подход: S-выражения [McCarthy], используемые в семействе языков 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) [Field]. Имеется три источника ячеек, за которыми необходимо проследить на стадии пометки:
s-locals, соответствующий стеку параметров Форта,s-calls, аналогичный стеку возвратов,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 [R5RS]. Ниже приведены некоторые примеры их использования. Для краткости введено слово n в качестве синонима ->s.
| Выражение | Результат |
|---|---|
| 1 n 2 n cons | ( 1 . 2 ) |
| 1 n 2 n () cons cons | ( 1 2 ) |
| 1 n 2 n 3 n 3 list | ( 1 2 3 ) |
| s( 1 n 2 n 3 n )s | ( 1 2 3 ) |
| s( 1 n )s pair? () null? 42 n number? ' DUP xt->s xt? | -1 -1 -1 -1 |
| s( 1 n s( 2 n )s )s cdr car | ( 2 ) |
| 1 n 2 n cons 3 n s-over set-car! 4 n s-over set-cdr! | ( 3 . 4 ) |
| 1 n 1 n eq? s( 1 n s( 2 n )s )s s( 1 n s( 2 n )s )s equal? | -1 -1 |
| s( 1 n 2 n 3 n )s 1 list-tail | ( 2 3 ) |
| s( 1 n 2 n 3 n )s 1 list-ref | 2 |
| s( 42 n ' EMIT xt->s )s s-execute | * |
| s( 1 n 2 n 3 n )s length | 3 |
| s( 1 n 2 n 3 n )s () ' cons xt->s fold | ( ( ( () . 1 ) . 2 ) . 3 ) |
| s( 1 n 2 n 3 n )s reverse | ( 3 2 1 ) |
| s( 1 n 2 n 3 n )s s( 1 n ' list xt->s )s map | ( ( 1 ) ( 2 ) ( 3 ) ) |
| s( 1 n 2 n )s s( 3 n 4 n )s append | ( 1 2 3 4 ) |
| s( 1 n s( 2 n )s 3 n s( 4 n )s )s ' number? xt->s filter | ( 1 3 ) |
| s( CHAR F n CHAR P n )s ' EMIT 1pr for-each | FP |
| s( 1 n 2 n 3 n )s 0 n ' + 2op fold | 6 |
| s( 1 n 2 n 3 n )s ' 2* 1op map | ( 2 4 6 ) |
| s( -1 n 2 n -3 n )s ' 0< 1pr filter | ( -1 -3 ) |
Для более удобного использования слов Форта в качестве аргументов функций высшего порядка, оперирующих 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 порождает все подмножества данного множества.
Джон Бэкус в своей знаменитой тьюринговской лекции [Backus] предложил особый стиль функционального программирования без переменных. Попробуем реализовать на Форте пример умножения матриц в этом стиле.
Для начала нам понадобится слово 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 ) )
В этом разделе представлен набросок реализации потоков(ленивых списков) в том виде, как они описаны в известном учебнике Структура и интерпретация компьютерных программ [SICP].
Введём слово 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.
Известно, что при работе с потоками момент вызова задержанной процедуры не определён. Поэтому, в отсутствие автоматического механизма, аналогичного лексическим замыканиям [Field], мы не имеем возможности использовать в таких процедурах внешние данные из стека.
Рассмотрим работу 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 )
[Backus] 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
[Field] A. J. Field, Peter G. Harrison: Functional Programming Addison-Wesley, 1988. (Имеется перевод: А. Филд, П. Харрисон. Функциональное программирование. - М.: Мир, 1993).
[McCarthy] 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
[R5RS] 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/
[SICP] 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/
( 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 ;