478 lines
10 KiB
Forth
478 lines
10 KiB
Forth
# RETRO
|
|
|
|
This is a set of extensions for RRE.
|
|
|
|
# Console Input
|
|
|
|
~~~
|
|
:c:get (-c) `1001 ;
|
|
~~~
|
|
|
|
---------------------------------------------------------------
|
|
|
|
# Floating Point
|
|
|
|
~~~
|
|
:n:to-float (n-_f:-n) #0 `-6000 ;
|
|
:s:to-float (s-_f:-n) #1 `-6000 ;
|
|
:f:to-string (f:n-__-s) s:empty dup #2 `-6000 ;
|
|
:f:+ (f:ab-c) #3 `-6000 ;
|
|
:f:- (f:ab-c) #4 `-6000 ;
|
|
:f:* (f:ab-c) #5 `-6000 ;
|
|
:f:/ (f:ab-c) #6 `-6000 ;
|
|
:f:floor (f:ab-c) #7 `-6000 ;
|
|
:f:eq? (f:ab-c) #8 `-6000 ;
|
|
:f:-eq? (f:ab-c) #9 `-6000 ;
|
|
:f:lt? (f:ab-c) #10 `-6000 ;
|
|
:f:gt? (f:ab-c) #11 `-6000 ;
|
|
:f:depth (-n) #12 `-6000 ;
|
|
:f:dup (f:a-aa) #13 `-6000 ;
|
|
:f:drop (f:a-) #14 `-6000 ;
|
|
:f:swap (f:ab-ba) #15 `-6000 ;
|
|
:f:log (f:ab-c) #16 `-6000 ;
|
|
:f:power (f:ab-c) #17 `-6000 ;
|
|
:f:to-number (f:a-__-n) #18 `-6000 ;
|
|
:f:sin (f:f-f) #19 `-6000 ;
|
|
:f:cos (f:f-f) #20 `-6000 ;
|
|
:f:tan (f:f-f) #21 `-6000 ;
|
|
:f:asin (f:f-f) #22 `-6000 ;
|
|
:f:acos (f:f-f) #23 `-6000 ;
|
|
:f:atan (f:f-f) #24 `-6000 ;
|
|
:f:ceiling (f:f-f) #25 `-6000 ;
|
|
:f:sqrt (f:f-f) #26 `-6000 ;
|
|
:f:square (f:n-m) f:dup f:* ;
|
|
:f:over (f:ab-aba) f:to-string f:dup s:to-float f:swap ;
|
|
:f:tuck (f:ab-bab) f:swap f:over ;
|
|
:f:positive? (-f__f:a-) #0 n:to-float f:gt? ;
|
|
:f:negative? (-f__f:a-) #0 n:to-float f:lt? ;
|
|
:f:negate (f:a-b) #-1 n:to-float f:* ;
|
|
:f:abs (f:a-b) f:dup f:negative? [ f:negate ] if ;
|
|
:prefix:. (s-__f:-a)
|
|
compiling? [ s:keep ] [ s:temp ] choose &s:to-float class:word ; immediate
|
|
:f:put (f:a-) f:to-string s:put ;
|
|
:f:PI (f:-F) .3.141592 ;
|
|
:f:E (f:-F) .2.718281 ;
|
|
:f:NAN (f:-n) .0 .0 f:/ ;
|
|
:f:INF (f:-n) .1.0 .0 f:/ ;
|
|
:f:-INF (f:-n) .-1.0 .0 f:/ ;
|
|
:f:nan? (f:n-,-f) f:dup f:-eq? ;
|
|
:f:inf? (f:n-,-f) f:INF f:eq? ;
|
|
:f:-inf? (f:n-,-f) f:-INF f:eq? ;
|
|
:f:round (-|f:a-b)
|
|
f:dup f:negative?
|
|
[ .0.5 f:- f:ceiling ]
|
|
[ .0.5 f:+ f:floor ] choose ;
|
|
~~~
|
|
|
|
---------------------------------------------------------------
|
|
|
|
# Float
|
|
|
|
## Description
|
|
|
|
This implements a means of encoding floating point values into signed integer cells. The technique is described in the paper titled "Encoding floating point numbers to shorter integers" by Kiyoshi Yoneda and Charles Childers.
|
|
|
|
This will extend the `f:` vocabulary and adds a new `u:` vocabulary.
|
|
|
|
## Code & Commentary
|
|
|
|
Define some constants. The range is slightly reduced from the standard integer range as the smallest value is used for NaN.
|
|
|
|
~~~
|
|
n:MAX n:dec 'u:MAX const
|
|
n:MAX n:dec n:negate 'u:MIN const
|
|
n:MIN 'u:NAN const
|
|
n:MAX 'u:INF const
|
|
n:MAX n:negate 'u:-INF const
|
|
~~~
|
|
|
|
~~~
|
|
:u:n? (u-f)
|
|
u:MIN n:inc u:MAX n:dec n:between? ;
|
|
:u:max? (u-f) u:MAX eq? ;
|
|
:u:min? (u-f) u:MIN eq? ;
|
|
:u:zero? (u-f) n:zero? ;
|
|
:u:nan? (u-f) u:NAN eq? ;
|
|
:u:inf? (u-f) u:INF eq? ;
|
|
:u:-inf? (u-f) u:-INF eq? ;
|
|
:u:clip (u-u) u:MIN u:MAX n:limit ;
|
|
~~~
|
|
|
|
Define the scaling factors. Adjust these as needed for your application.
|
|
|
|
~~~
|
|
:f:U1 (-|f:-b) .1.e9 ;
|
|
:f:BALANCE (-|f:-b) .1. ;
|
|
~~~
|
|
|
|
~~~
|
|
{{
|
|
:f:scale (-|f:a-b) f:U1 f:* ;
|
|
:f:descale (-|f:a-b) f:U1 f:/ ;
|
|
|
|
:f:encode (-|f:a-b)__n/(s_+_n_)
|
|
f:BALANCE f:over f:+ f:/ ;
|
|
|
|
:f:decode (-|f:a-b)_su/(1_-_u_)
|
|
.1. f:over f:- f:/ f:BALANCE f:* ;
|
|
|
|
---reveal---
|
|
|
|
:f:to-u (-u|f:a-)
|
|
f:dup f:encode f:scale f:round f:to-number u:clip
|
|
f:dup f:nan? [ drop u:NAN ] if
|
|
f:dup f:inf? [ drop u:INF ] if
|
|
f:dup f:-inf? [ drop u:-INF ] if
|
|
f:drop ;
|
|
|
|
:u:to-f (u-|f:-b)
|
|
dup n:to-float f:descale f:decode
|
|
dup u:nan? [ f:drop f:NAN ] if
|
|
dup u:inf? [ f:drop f:INF ] if
|
|
dup u:-inf? [ f:drop f:-INF ] if
|
|
drop ;
|
|
}}
|
|
~~~
|
|
|
|
~~~
|
|
:f:store (a-|f:n-) [ f:to-u ] dip store ;
|
|
:f:fetch (a-|f:-n) fetch u:to-f ;
|
|
~~~
|
|
|
|
---------------------------------------------------------------
|
|
|
|
# Gopher
|
|
|
|
RETRO has Gopher support via `gopher:get`.
|
|
|
|
Takes:
|
|
|
|
destination
|
|
server name
|
|
port
|
|
selector
|
|
|
|
Returns:
|
|
|
|
number of characters read
|
|
|
|
~~~
|
|
:gopher:get `-6200 ;
|
|
~~~
|
|
|
|
---------------------------------------------------------------
|
|
|
|
# Scripting: Command Line Arguments
|
|
|
|
~~~
|
|
:sys:argc (-n) `-6100 ;
|
|
:sys:argv (n-s) s:empty swap `-6101 ;
|
|
~~~
|
|
|
|
# System Interaction
|
|
|
|
The `unix:` namespace contains words for interacting with the
|
|
host operating system.
|
|
|
|
`unix:system` runs another application using the system shell
|
|
and returns after execution is completed.
|
|
|
|
~~~
|
|
:unix:system (s-) #-8000 `-6300 ;
|
|
~~~
|
|
|
|
`unix:fork` forks the current process and returns a process
|
|
identifier.
|
|
|
|
~~~
|
|
:unix:fork (-n) #-8001 `-6300 ;
|
|
~~~
|
|
|
|
`unix:exit` takes a return code and exits RRE, returning the
|
|
specified code.
|
|
|
|
~~~
|
|
:unix:exit (n-) #-8002 `-6300 ;
|
|
~~~
|
|
|
|
`unix:getpid` returns the current process identifier.
|
|
|
|
~~~
|
|
:unix:getpid (-n) #-8003 `-6300 ;
|
|
~~~
|
|
|
|
This group is used to execute a new process in place of the
|
|
current one. These take a program and optionally 1-3 arguments.
|
|
They map to the execl() system call.
|
|
|
|
Example:
|
|
|
|
'/usr/bin/cal '2 '2019 unix:exec2
|
|
|
|
~~~
|
|
:unix:exec0 (s-) #-8004 `-6300 ;
|
|
:unix:exec1 (ss-) #-8005 `-6300 ;
|
|
:unix:exec2 (sss-) #-8006 `-6300 ;
|
|
:unix:exec3 (ssss-) #-8007 `-6300 ;
|
|
~~~
|
|
|
|
`unix:wait` waits for a child process to complete. This maps to
|
|
the wait() system call.
|
|
|
|
~~~
|
|
:unix:wait (-n) #-8008 `-6300 ;
|
|
~~~
|
|
|
|
`unix:kill` terminates a process. Takes a process and a signal
|
|
to send.
|
|
|
|
~~~
|
|
:unix:kill (nn-) #-8009 `-6300 ;
|
|
~~~
|
|
|
|
The next two words allow opening and closing pipes. The first,
|
|
`unix:popen` takes the name of a program and a file mode and
|
|
returns a file handle usable with words in the `file:` namespace.
|
|
The second, `unix:pclose` closes the pipe.
|
|
|
|
~~~
|
|
:unix:popen (sn-n) #-8010 `-6300 ;
|
|
:unix:pclose (n-) #-8011 `-6300 ;
|
|
~~~
|
|
|
|
~~~
|
|
:unix:write (sh-) [ dup s:length ] dip #-8012 `-6300 ;
|
|
~~~
|
|
|
|
`unix:chdir` changes the current working directory to the
|
|
specified one.
|
|
|
|
~~~
|
|
:unix:chdir (s-) #-8013 `-6300 ;
|
|
~~~
|
|
|
|
~~~
|
|
:unix:getenv (sa-) #-8014 `-6300 ;
|
|
:unix:putenv (s-) #-8015 `-6300 ;
|
|
~~~
|
|
|
|
`unix:sleep` pauses execution for the specified number of
|
|
seconds.
|
|
|
|
~~~
|
|
:unix:sleep (n-) #-8016 `-6300 ;
|
|
~~~
|
|
|
|
---------------------------------------------------------------
|
|
|
|
# File I/O
|
|
|
|
This implements words for interfacing with the POSIX file I/O words if
|
|
you are using an interface supporting them. All of these are in the
|
|
`file:` namespace.
|
|
|
|
These are pretty much direct wrappers for fopen(), fclose(), etc.
|
|
|
|
First up, constants for the file modes.
|
|
|
|
| # | Used For |
|
|
| - | ------------------ |
|
|
| R | Mode for READING |
|
|
| W | Mode for WRITING |
|
|
| A | Mode for APPENDING |
|
|
|
|
~~~
|
|
#0 'file:R const
|
|
#1 'file:W const
|
|
#2 'file:A const
|
|
#3 'file:R+ const
|
|
~~~
|
|
|
|
For opening a file, provide the file name and mode. This will return a
|
|
number identifying the file handle.
|
|
|
|
~~~
|
|
:file:open (sm-h) `118 ;
|
|
~~~
|
|
|
|
Given a file handle, close the file.
|
|
|
|
~~~
|
|
:file:close (h-) `119 ;
|
|
~~~
|
|
|
|
Given a file handle, read a character.
|
|
|
|
~~~
|
|
:file:read (h-c) `120 ;
|
|
~~~
|
|
|
|
Write a character to an open file.
|
|
|
|
~~~
|
|
:file:write (ch-) `121 ;
|
|
~~~
|
|
|
|
Return the current pointer within a file.
|
|
|
|
~~~
|
|
:file:tell (h-n) `122 ;
|
|
~~~
|
|
|
|
Move the file pointer to the specified location.
|
|
|
|
~~~
|
|
:file:seek (nh-) `123 ;
|
|
~~~
|
|
|
|
Return the size of the opened file.
|
|
|
|
~~~
|
|
:file:size (h-n) `124 ;
|
|
~~~
|
|
|
|
Given a file name, delete the file.
|
|
|
|
~~~
|
|
:file:delete (s-) `125 ;
|
|
~~~
|
|
|
|
Flush pending writes to disk.
|
|
|
|
~~~
|
|
:file:flush (f-) `126 ;
|
|
~~~
|
|
|
|
Given a file name, return `TRUE` if it exists or `FALSE` otherwise.
|
|
|
|
~~~
|
|
:file:exists? (s-f)
|
|
file:R file:open dup n:-zero?
|
|
[ file:close TRUE ]
|
|
[ drop FALSE ] choose ;
|
|
~~~
|
|
|
|
~~~
|
|
:file:open<for-reading> (s-nn)
|
|
file:R file:open dup file:size swap ;
|
|
|
|
:file:open<for-append> (s-nn)
|
|
file:A file:open dup file:size swap ;
|
|
|
|
:file:open<for-writing> (s-n)
|
|
file:W file:open ;
|
|
~~~
|
|
|
|
With that out of the way, we can begin building higher level functionality.
|
|
|
|
The first of these reads a line from the file. This is read to `here`; move
|
|
it somewhere safe if you need to keep it around.
|
|
|
|
The second goes with it. The `for-each-line` word will invoke a combinator
|
|
once for each line in a file. This makes some things trivial. E.g., a simple
|
|
'cat' implementation could be as simple as:
|
|
|
|
'filename [ s:put nl ] file:for-each-line
|
|
|
|
~~~
|
|
{{
|
|
'FID var
|
|
'Size var
|
|
'Action var
|
|
'Buffer var
|
|
:-eof? (-f) @FID file:tell @Size lt? ;
|
|
:preserve (q-) &FID [ &Size [ call ] v:preserve ] v:preserve ;
|
|
---reveal---
|
|
:file:read-line (f-s)
|
|
!FID
|
|
[ here dup !Buffer buffer:set
|
|
[ @FID file:read dup buffer:add
|
|
[ ASCII:CR eq? ] [ ASCII:LF eq? ] [ ASCII:NUL eq? ] tri or or ] until
|
|
buffer:get drop ] buffer:preserve
|
|
@Buffer ;
|
|
|
|
:file:for-each-line (sq-)
|
|
[ !Action
|
|
file:open<for-reading> !FID !Size
|
|
[ @FID file:read-line @Action call -eof? ] while
|
|
@FID file:close
|
|
] preserve ;
|
|
}}
|
|
~~~
|
|
|
|
`file:slurp` reads a file into a buffer.
|
|
|
|
~~~
|
|
{{
|
|
'FID var
|
|
'Size var
|
|
---reveal---
|
|
:file:slurp (as-)
|
|
[ file:open<for-reading> !FID !Size
|
|
buffer:set
|
|
@Size [ @FID file:read buffer:add ] times
|
|
@FID file:close
|
|
] buffer:preserve ;
|
|
}}
|
|
~~~
|
|
|
|
~~~
|
|
{{
|
|
'FID var
|
|
---reveal---
|
|
:file:spew (ss-)
|
|
file:open<for-writing> !FID
|
|
[ @FID file:write ] s:for-each
|
|
@FID file:close ;
|
|
}}
|
|
~~~
|
|
|
|
|
|
|
|
~~~
|
|
:unix:io:n:put (n-) #-8100 `-6300 ;
|
|
:unix:io:s:put (s-) #-8101 `-6300 ;
|
|
~~~
|
|
|
|
# Interactive Listener
|
|
|
|
~~~
|
|
'NoEcho var
|
|
|
|
{{
|
|
:version (-) @Version #100 /mod n:put $. c:put n:put ;
|
|
:eol? (c-f) [ ASCII:CR eq? ] [ ASCII:LF eq? ] [ ASCII:SPACE eq? ] tri or or ;
|
|
:valid? (s-sf) dup s:length n:-zero? ;
|
|
:ok (-) @NoEcho not 0; drop compiling? [ nl 'Ok_ s:put ] -if ;
|
|
:check-eof (c-c) dup [ #-1 eq? ] [ #4 eq? ] bi or [ 'bye d:lookup d:xt fetch call ] if ;
|
|
:check-bs (c-c) dup [ #8 eq? ] [ #127 eq? ] bi or [ buffer:get buffer:get drop-pair ] if ;
|
|
:s:get (-s) [ #1025 buffer:set
|
|
[ c:get dup buffer:add check-eof check-bs eol? ] until
|
|
buffer:start s:chop ] buffer:preserve ;
|
|
---reveal---
|
|
:banner (-) @NoEcho not 0; drop
|
|
'RETRO_12_(rx- s:put version $) c:put nl
|
|
EOM n:put '_MAX,_TIB_@_1025,_Heap_@_ s:put here n:put nl ;
|
|
:bye (-) #0 unix:exit ;
|
|
:listen (-)
|
|
ok repeat s:get valid? [ interpret ok ] [ drop ] choose again ;
|
|
}}
|
|
~~~
|
|
|
|
~~~
|
|
:include (s-) `-9999 ;
|
|
~~~
|
|
|
|
~~~
|
|
{{
|
|
:gather (c-)
|
|
dup [ #8 eq? ] [ #127 eq? ] bi or [ drop ] [ buffer:add ] choose ;
|
|
:cycle (q-qc) repeat c:get dup-pair swap call not 0; drop gather again ;
|
|
---reveal---
|
|
:parse-until (q-s)
|
|
[ s:empty buffer:set cycle drop-pair buffer:start ] buffer:preserve ;
|
|
}}
|
|
|
|
:s:get (-s) [ [ ASCII:LF eq? ] [ ASCII:CR eq? ] bi or ] parse-until ;
|
|
~~~
|
|
|