Хабр Курсы для всех
РЕКЛАМА
Практикум, Хекслет, SkyPro, авторские курсы — собрали всех и попросили скидки. Осталось выбрать!
: sq dup * ; x 0.5 - sq y 0.5 - sq + sqrt t sin * : norm * sin 1 + 2 / ; dup 40 norm over 60 norm rot 80 norm
: sq dup * ; : norm * sin 1 + 2 / ; : на x 0.5 - sq ; : мёртвой y 0.5 - sq ; : ветке + ; : чернеет sqrt t sin * ; : ворон. dup 40 norm ; : осенний over 60 norm ; : вечер. rot 80 norm ; на мёртвой ветке чернеет ворон. осенний вечер.
: sq dup * ; : norm * sin 1 + 2 / ; : tt t 10 mod ; : xc tt 10 / ; : в 0 drop ; : вечерним x xc 0.25 + 0.75 > 1 * xc - abs 0.25 + ; : вьюнком - sq ; : я y 0.5 - sq ; : плен + ; : захвачен… sqrt t 60 mod sin * ; : недвижно dup tt 10 * norm ; : стою over 70 t 50 mod + norm ; : забытьи. rot 80 norm ; вечерним вьюнком я в плен захвачен… недвижно стою в забытьи.
Хабр не знает сорцов Форта?
: INTERPRET ( -> ) \ интерпретировать входной поток
BEGIN
PARSE-NAME DUP \ PARSE-NAME тупо перебирает символы из входного потока в поиске разделителя (пробел и меньше) и возвращает найденное слово
WHILE
SFIND \ Ищем слово в словаре/словарях
IF
STATE @ \ Проверка режима работы системы: компиляция или исполнение
IF COMPILE, ELSE EXECUTE THEN \ Компилируем слово или исполняем его
ELSE
NOTFOUND \ Зависит от реализации, но в общем случае тут обрабатываем исключение "слово не найдено", обычно тут еще бывает проверка "число?" -> компилируем числовой литерал или кладем число на стек
THEN
REPEAT
2DROP \ Выкидываем уже не нужную строку со стека
;c-library socket
\c #include <netdb.h>
c-function gethostbyname gethostbyname a -- a ( name -- hostent )
\c #include <unistd.h>
c-function gethostname gethostname a n -- n ( c-addr u -- ior )
\c #include <errno.h>
\c #define get_errno() errno
c-function errno get_errno -- n ( -- value )
\c #include <sys/types.h>
\c #include <sys/socket.h>
c-function socket socket n n n -- n ( class type proto -- fd )
c-function closesocket close n -- n ( fd -- ior )
c-function connect connect n a n -- n ( fd sock size -- err )
c-function send send n a n n -- n ( socket buffer count flags -- size )
c-function recv recv n a n n -- n ( socket buffer count flags -- size )
c-function listen() listen n n -- n ( socket backlog -- err )
c-function bind bind n a n -- n ( socket sockaddr socklen --- err )
c-function accept() accept n a a -- n ( socket sockaddr addrlen -- fd )
\c #include <stdio.h>
c-function fdopen fdopen n a -- a ( fd fileattr -- file )
\c #include <fcntl.h>
c-function fcntl fcntl n n n -- n ( fd n1 n2 -- ior )
\c #include <arpa/inet.h>
c-function htonl htonl n -- n ( x -- x' )
c-function htons htons n -- n ( x -- x' )
c-function ntohl ntohl n -- n ( x -- x' )
\c #define fileno1(file) fileno((FILE*)(file))
c-function fileno fileno1 a -- n ( file* -- fd )
end-c-library
4 4 2Constant int%
2 2 2Constant short%
struct
cell% field h_name
cell% field h_aliases
int% field h_addrtype
int% field h_length
cell% field h_addr_list
end-struct hostent
struct
short% field family
short% field port
int% field sin_addr
cell% 2* field padding
end-struct sockaddr_in
: IFNOT \ ( flag -- )
?COMP \ Проверка на режим компиляции
[COMPILE] IF
0x85 HERE 5 - C! \ Хак: подменяем скомпилированную ранее инструкцию JE(0x84) на JNE(0x85)
\ Высокоуровневый вариант:
\ POSTPONE 0= [COMPILE] IF
; IMMEDIATE
1024 CONSTANT NewStackSize
CREATE NewStack /NewStack NewStackSize ALLOT 0 ,
0 VALUE NewStackDepth
: -TH \ ( addr n -- addr+n*cell )
CELLS +
;
: NewStack! \ ( n -- )
NewStackDepth 1024 < IF
NewStack NewStackDepth -TH !
NewStackDepth 1+ TO NewStackDepth
ELSE
ABORT" Переполнение стека NewStack"
THEN
;
: ClearNewStack
0 TO NewStackDepth
;
: NewStack@ \ ( -- n )
NewStackDepth IF
NewStackDepth 1- TO NewStackDepth
NewStack NewStackDepth -TH @
ELSE
ABORT" Опустошение стека NewStack"
THEN
;
: NewStackGet \ ( -- n )
NewStackDepth IF
NewStack NewStackDepth 1- -TH @
ELSE
0
THEN
;
: new-stack ( -- stack-id ) ... ; \ Тут реализуем нужные слова new-stack value s0 5 s0 >s 10 s0 >s s0 sswap s0 s> s0 s>
: xx x .8 - ;
: yy y .5 - ;
: tt t .4 * ;
: a .25 * ;
: mx xx 2 a tt cos * 2 tt * cos a - + ;
: my yy 2 a tt sin * 2 tt * sin a - + ;
: mm 2dup Z* mx my z+ ;
mx my
mm mm mm mm mm mm
mm mm mm mm mm mm
mm mm mm mm mm mm
mm mm mm mm mm mm
dup * swap dup * +
0 > negate 1 +
dup dup
Мои программы, конечно, ужасно нечитаемы.
первое, что я делаю, это переопределяю команды языка Forth.
0
<size> -- field1_name
<size> -- field2_name
<size> -- field3_name
CONSTANT /structure_name

Forth и шейдеры