2018-08-24 18:22:29 +02:00
|
|
|
# RETRO FORTH
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
## Background
|
|
|
|
|
2018-08-24 18:22:29 +02:00
|
|
|
Retro is a dialect of Forth. It builds on the barebones Rx
|
|
|
|
core, expanding it into a flexible and useful language.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-24 18:22:29 +02:00
|
|
|
Over the years the language implementation has varied
|
|
|
|
substantially. Retro began in 1998 as a 16-bit assembly
|
|
|
|
implementation for x86 hardware, evolved into a 32-bit
|
|
|
|
system with cmForth and ColorForth influences, and
|
|
|
|
eventually started supporting mainstream OSes. Later it
|
|
|
|
was rewritten for a small, portable virtual machine.
|
|
|
|
|
|
|
|
This is the twelfth generation of Retro. It targets a virtual
|
|
|
|
machine (called Nga) and runs on a wide variety of host
|
|
|
|
systems.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
### Namespaces
|
|
|
|
|
2018-08-24 18:22:29 +02:00
|
|
|
Various past releases have had different methods of dealing
|
|
|
|
with the dictionary. I have settled on using a] single global
|
|
|
|
dictionary, with a convention of using a short namespace prefix
|
|
|
|
for grouping related words. This was inspired by Ron Aaron's
|
|
|
|
8th language.
|
|
|
|
|
|
|
|
The main namespaces are:
|
|
|
|
|
|
|
|
| namespace | words related to |
|
|
|
|
| ---------- | ------------------ |
|
|
|
|
| ASCII | ASCII Constants |
|
2019-02-21 05:19:14 +01:00
|
|
|
| array | arrays |
|
2018-08-24 18:22:29 +02:00
|
|
|
| c | characters |
|
|
|
|
| compile | compiler functions |
|
|
|
|
| d | dictionary headers |
|
|
|
|
| err | error handlers |
|
|
|
|
| n | numbers |
|
|
|
|
| s | strings |
|
|
|
|
| v | variables |
|
|
|
|
|
|
|
|
This makes it very easy to identify related words, especially
|
|
|
|
across namespaces. E.g.,
|
|
|
|
|
|
|
|
c:put
|
|
|
|
c:to-upper
|
|
|
|
s:put
|
|
|
|
s:to-upper
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
### Prefixes
|
|
|
|
|
2018-08-24 18:22:29 +02:00
|
|
|
Prefixes are an integral part of Retro. These are single symbol
|
|
|
|
modifiers added to the start of a word which control how Retro
|
|
|
|
processes the word.
|
|
|
|
|
|
|
|
The interpreter model is covered in *Rx.md*, but basically:
|
|
|
|
|
|
|
|
- Get a token (whitespace delimited string)
|
|
|
|
- Pass it to `interpret`
|
|
|
|
+ if the token starts with a known prefix then pass
|
|
|
|
it to the prefix handler
|
|
|
|
+ if the initial character is not a known prefix,
|
|
|
|
look it up
|
|
|
|
- if found, push the address ("xt") to the stack
|
|
|
|
and call the word's class handler
|
|
|
|
- if not found call `err:not-found`
|
|
|
|
- repeat as needed
|
|
|
|
|
|
|
|
This is different than the process in traditional Forth. A few
|
|
|
|
observations:
|
|
|
|
|
|
|
|
- there are no parsing words
|
|
|
|
- numbers are handled using a prefix
|
|
|
|
- prefixes can be added or changed at any time
|
|
|
|
|
|
|
|
The basic prefixes are:
|
|
|
|
|
|
|
|
| prefix | used for |
|
|
|
|
| ------ | ---------------------- |
|
|
|
|
| : | starting a definition |
|
|
|
|
| & | obtaining pointers |
|
|
|
|
| ( | stack comments |
|
|
|
|
| ` | inlining bytecodes |
|
|
|
|
| ' | strings |
|
|
|
|
| # | numbers |
|
|
|
|
| $ | characters |
|
|
|
|
| @ | variable get |
|
|
|
|
| ! | variable set |
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
### Naming and Style Conventions
|
|
|
|
|
|
|
|
* Names should start with their namespace (if appropriate)
|
|
|
|
* Word names should be lowercase
|
|
|
|
* Variable names should be Title case
|
|
|
|
* Constants should be UPPERCASE
|
|
|
|
* Names may not start with a prefix character
|
|
|
|
* Names returning a flag should end with a ?
|
|
|
|
* Words with an effect on the stack should have a stack comment
|
|
|
|
|
|
|
|
## Code Begins
|
|
|
|
|
|
|
|
Memory Map
|
|
|
|
|
2018-08-24 18:22:29 +02:00
|
|
|
This assumes that the VM defines an image as being 524,288
|
|
|
|
cells. Nga implementations may provide varying amounts of
|
|
|
|
memory, so the specific addresses will vary.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-24 18:22:29 +02:00
|
|
|
| RANGE | CONTAINS |
|
|
|
|
| --------------- | ---------------------------- |
|
|
|
|
| 0 - 1024 | rx kernel |
|
|
|
|
| 1025 - 1535 | token input buffer |
|
|
|
|
| 1536 + | start of heap space |
|
|
|
|
| ............... | free memory for your use |
|
|
|
|
| 506879 | buffer for string evaluate |
|
|
|
|
| 507904 | temporary strings (32 * 512) |
|
|
|
|
| 524287 | end of memory |
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-24 18:22:29 +02:00
|
|
|
I provide a word, `EOM`, which returns the last addressable
|
|
|
|
location. This will be used by the words in the `s:` namespace
|
|
|
|
to allocate the temporary string buffers at the end of memory.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:EOM (-n) #-3 fetch ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
## Stack Depth
|
|
|
|
|
|
|
|
`depth` returns the number of items on the data stack. This is
|
|
|
|
provided by the VM upon reading from address *-1*.
|
|
|
|
|
|
|
|
~~~
|
|
|
|
:depth (-n) #-1 fetch ;
|
|
|
|
~~~
|
|
|
|
|
2018-08-24 18:22:29 +02:00
|
|
|
## Stack Comments
|
|
|
|
|
|
|
|
Stack comments are terse notes that indicate the stack effects
|
|
|
|
of words. While not required, it's helpful to include these.
|
|
|
|
|
|
|
|
They take a form like:
|
|
|
|
|
|
|
|
(takes-returns)
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-24 18:22:29 +02:00
|
|
|
I use a single character for each input and output item. These
|
|
|
|
will often (though perhaps not always) be:
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-24 18:22:29 +02:00
|
|
|
n, m, x, y number
|
|
|
|
a, p pointer
|
|
|
|
q quotation (pointer)
|
|
|
|
d dictionary header (pointer)
|
|
|
|
s string
|
|
|
|
c character (ASCII)
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-24 18:22:29 +02:00
|
|
|
## Dictionary Shortcuts
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-24 18:22:29 +02:00
|
|
|
I define a few words in the `d:` namespace to make it easier
|
|
|
|
to operate on the most recent header in the dictionary. These
|
|
|
|
return the values in specific fields of the header.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:d:last (-d) &Dictionary fetch ;
|
|
|
|
:d:last<xt> (-a) d:last d:xt fetch ;
|
|
|
|
:d:last<class> (-a) d:last d:class fetch ;
|
|
|
|
:d:last<name> (-s) d:last d:name ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-24 18:22:29 +02:00
|
|
|
## Changing A Word's Class Handler
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-24 18:22:29 +02:00
|
|
|
I implement `reclass` to change the class of the most recent
|
|
|
|
word.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:reclass (a-) d:last d:class store ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-24 18:22:29 +02:00
|
|
|
With this I can then define `immediate` (for state-smart words)
|
|
|
|
and `data` to tag data words.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:immediate (-) &class:macro reclass ;
|
2017-10-25 03:36:47 +02:00
|
|
|
:data (-) &class:data reclass ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-11-13 04:12:42 +01:00
|
|
|
~~~
|
|
|
|
:primitive (-) &class:primitive reclass ;
|
|
|
|
~~~
|
|
|
|
|
2019-03-14 18:35:45 +01:00
|
|
|
## Visual Grouping
|
|
|
|
|
|
|
|
Comments start with a `(` and end at the first whitespace. It's
|
|
|
|
useful to be able to punctuate a code block, providing some
|
|
|
|
inline commentary and having a clear end point. We can provide
|
|
|
|
this with a single word `)`.
|
|
|
|
|
|
|
|
Example:
|
|
|
|
|
|
|
|
:pre.min (a-an)
|
|
|
|
(comparison <? <-or-gt? set-hook )
|
|
|
|
(begin_with #-1 !Index n:min !Value dup array:length ) ;
|
|
|
|
|
|
|
|
~~~
|
|
|
|
:) ; immediate
|
|
|
|
~~~
|
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
## Optimizations & Compiler Extensions
|
2017-10-23 20:56:56 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
I have a `compile` namespace for some low level words that
|
|
|
|
compile specific Nga bytecode. This is intended to aid in
|
|
|
|
readability when constructing compiler extensions.
|
2017-10-24 23:00:50 +02:00
|
|
|
|
|
|
|
~~~
|
2019-03-14 18:59:02 +01:00
|
|
|
:compile:lit (a-) (li...... #1 , , ) ;
|
|
|
|
:compile:jump (a-) (liju.... #1793 , , ) ;
|
|
|
|
:compile:call (a-) (lica.... #2049 , , ) ;
|
|
|
|
:compile:ret (-) (re...... #10 , ) ;
|
2017-10-24 23:00:50 +02:00
|
|
|
~~~
|
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
The compiler state is stored in a value named `Compiler`. I
|
|
|
|
have an accessor word that aids in readability.
|
2017-10-25 03:02:02 +02:00
|
|
|
|
|
|
|
~~~
|
|
|
|
:compiling? (-f) &Compiler fetch ;
|
|
|
|
~~~
|
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
It's sometimes useful to inline values directly. I use a
|
|
|
|
backtick prefix for this.
|
|
|
|
|
|
|
|
~~~
|
|
|
|
:prefix:` (s-)
|
|
|
|
s:to-number , ; immediate
|
|
|
|
~~~
|
|
|
|
|
2018-09-06 17:50:08 +02:00
|
|
|
It's traditional to have a word named `here` which returns the
|
|
|
|
next free address in memory.
|
2018-08-29 17:47:21 +02:00
|
|
|
|
|
|
|
~~~
|
|
|
|
:here (-a)
|
|
|
|
&Heap fetch ;
|
|
|
|
~~~
|
|
|
|
|
|
|
|
## Variables
|
|
|
|
|
|
|
|
The next two are additional prefixes to make working with
|
|
|
|
variables a bit less painful. By default you have to do things
|
|
|
|
like:
|
2017-10-23 20:56:56 +02:00
|
|
|
|
|
|
|
&Name fetch #10 * &Name store
|
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
Or using combinators:
|
2017-10-23 20:56:56 +02:00
|
|
|
|
|
|
|
&Name [ fetch #10 * ] sip store
|
|
|
|
|
|
|
|
With the @ and ! prefixes this can become:
|
|
|
|
|
|
|
|
@Name #10 * !Name
|
|
|
|
|
2017-10-24 23:03:00 +02:00
|
|
|
When compiling, these will generate packed Nga instructions
|
|
|
|
corresponding to:
|
|
|
|
|
|
|
|
lit + fetch + nop + nop 'life.... #3841
|
|
|
|
lit + store + nop + nop 'list.... #4097
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-24 23:00:50 +02:00
|
|
|
:prefix:@ (s-n)
|
|
|
|
d:lookup d:xt fetch
|
2019-03-14 18:59:02 +01:00
|
|
|
compiling? [ (life.... #3841 , , ) ]
|
|
|
|
[ fetch ] choose ; immediate
|
2017-10-24 23:03:00 +02:00
|
|
|
|
2017-10-24 23:00:50 +02:00
|
|
|
:prefix:! (s-n)
|
|
|
|
d:lookup d:xt fetch
|
2019-03-14 18:59:02 +01:00
|
|
|
compiling? [ (list.... #4097 , , ) ]
|
|
|
|
[ store ] choose ; immediate
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
The next few words aren't actually useful until the `s:`
|
|
|
|
namespace is defined. With strings and the `'` prefix they
|
|
|
|
allow creation of variables and constants.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
| To create a | Use a form like |
|
|
|
|
| ---------------------------- | ------------------ |
|
|
|
|
| Variable | `'Base var` |
|
|
|
|
| Variable, with initial value | `#10 'Base var<n>` |
|
|
|
|
| Constant | `#-1 'TRUE const` |
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
The lower level kernel provides `d:add-header` to make a new
|
|
|
|
header. This is a bit ugly to use as most of the time I don't
|
|
|
|
need all of the flexibility it provides. Here I add a word to
|
|
|
|
create a new header pointing to `here`. This is then used to
|
|
|
|
build other data structures without invoking the `:` compiler.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:d:create (s-)
|
2019-03-14 18:59:02 +01:00
|
|
|
&class:data #0 d:add-header
|
2017-10-16 18:09:39 +02:00
|
|
|
here d:last d:xt store ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
And then the others are trivial.
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:var<n> (ns-) d:create , ;
|
2019-03-14 19:19:10 +01:00
|
|
|
:var (s-) #0 swap var<n> ;
|
2017-10-16 18:09:39 +02:00
|
|
|
:const (ns-) d:create d:last d:xt store ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
The `const` word is an example of using the dictionary and word
|
|
|
|
classes to do some optimization.It creates a header, with a
|
|
|
|
class of `class:data`, then sets the execution pointer to the
|
|
|
|
desired value. Since the data class either leaves the word
|
|
|
|
pointer on the stack or compiles it as a literal into a
|
|
|
|
definition, this allows constants to exist as just a header
|
|
|
|
with no extra runtime code.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
## Stack Shufflers
|
|
|
|
|
|
|
|
The core Rx language provides a few basic stack shuffling
|
|
|
|
words: `push`, `pop`, `drop`, `swap`, and `dup`. There are
|
|
|
|
quite a few more that are useful. Some of these are provided
|
|
|
|
here.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-11-13 04:12:42 +01:00
|
|
|
Most of these are implemented as raw bytecodes which can be
|
|
|
|
inlined when used in definitions. The high level definitions
|
|
|
|
are:
|
|
|
|
|
|
|
|
:tuck (xy-yxy) dup push swap pop ;
|
|
|
|
:over (xy-xyx) push dup pop swap ;
|
|
|
|
:nip (xy-y) swap drop ;
|
|
|
|
:drop-pair (nn-) drop drop ;
|
|
|
|
|
|
|
|
And the low level forms:
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2019-03-14 18:59:02 +01:00
|
|
|
:tuck (xy-yxy) (dupuswpo `100926722 ) ; primitive
|
|
|
|
:over (xy-xyx) (puduposw `67502597 ) ; primitive
|
|
|
|
:nip (xy-y) (swdr.... `772 ) ; primitive
|
|
|
|
:drop-pair (nn-) (drdr.... `771 ) ; primitive
|
|
|
|
:?dup (n-nn|n-n) (duzr.... `6402 ) ; primitive
|
2017-10-16 18:09:39 +02:00
|
|
|
:dup-pair (xy-xyxy) over over ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
## Combinators
|
|
|
|
|
|
|
|
Retro makes use of anonymous functions called *quotations* for
|
|
|
|
much of the execution flow and stack control. The words that
|
|
|
|
operate on these quotations are called *combinators*.
|
|
|
|
|
|
|
|
Combinators are a major part of using Retro. They help in
|
|
|
|
reducing the use of lower level shuffling and allow for a
|
|
|
|
greater overall consistency in the syntax. I also find them
|
|
|
|
to help in reducing visual noise.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
### Combinators: Data
|
|
|
|
|
|
|
|
`dip` executes a quotation after moving a value off the stack.
|
|
|
|
The value is restored after execution completes. These are
|
|
|
|
equivilent:
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
#10 #12 [ #3 - ] dip
|
|
|
|
#10 #12 push #3 - pop
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:dip (nq-n) swap push call pop ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
`sip` is similar to dip, but leaves a copy of the value on the
|
|
|
|
stack while the quotation is executed. These are equivilent:
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
#10 [ #3 * ] sip
|
|
|
|
#10 dup push #3 * pop
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:sip (nq-n) push dup pop swap &call dip ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
Apply each quote to a copy of x.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:bi (xqq-) &sip dip call ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
Apply q1 to x and q2 to y.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:bi* (xyqq-) &dip dip call ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
Apply q to x and y.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:bi@ (xyq-) dup bi* ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
Apply each quote to a copy of x.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:tri (xqqq-) [ &sip dip sip ] dip call ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
Apply q1 to x, q2 to y, and q3 to z.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2019-03-14 18:59:02 +01:00
|
|
|
:tri* (xyzqqq-) [ [ swap &dip dip ] dip dip ] dip call ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
Apply q to x, y, and z.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:tri@ dup dup tri* ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
### Combinators: Control
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
Execute quote until quote returns a flag of 0.
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:while (q-)
|
|
|
|
[ repeat dup dip swap 0; drop again ] call drop ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-04-12 13:28:03 +02:00
|
|
|
Execute quote until quote returns a non-zero flag.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:until (q-)
|
|
|
|
[ repeat dup dip swap #-1 xor 0; drop again ] call drop ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
The `times` combinator runs a quote (n) times.
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2018-05-13 17:24:35 +02:00
|
|
|
:times (nq-)
|
2017-10-16 18:09:39 +02:00
|
|
|
swap [ repeat 0; #1 - push &call sip pop again ] call drop ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
`case` is a conditional combinator. It's actually pretty
|
|
|
|
useful. What it does is compare a value on the stack to a
|
|
|
|
specific value. If the values are identical, it discards the
|
|
|
|
value and calls a quote before exiting the word. Otherwise
|
|
|
|
it leaves the stack alone and allows execution to continue.
|
|
|
|
|
|
|
|
Example:
|
|
|
|
|
|
|
|
:c:vowel?
|
|
|
|
$a [ TRUE ] case
|
|
|
|
$e [ TRUE ] case
|
|
|
|
$i [ TRUE ] case
|
|
|
|
$o [ TRUE ] case
|
|
|
|
$u [ TRUE ] case
|
|
|
|
drop FALSE ;
|
|
|
|
|
|
|
|
~~~
|
|
|
|
:case
|
|
|
|
[ over eq? ] dip swap
|
|
|
|
[ nip call #-1 ] [ drop #0 ] choose 0; pop drop drop ;
|
|
|
|
|
|
|
|
:s:case
|
|
|
|
[ over s:eq? ] dip swap
|
|
|
|
[ nip call #-1 ] [ drop #0 ] choose 0; pop drop drop ;
|
|
|
|
~~~
|
|
|
|
|
2018-10-09 22:33:02 +02:00
|
|
|
## A Shortcut
|
|
|
|
|
|
|
|
~~~
|
|
|
|
:prefix:|
|
|
|
|
d:lookup [ d:xt fetch ] [ d:class fetch ] bi
|
|
|
|
compiling? [ [ class:data ] dip compile:call ]
|
|
|
|
[ call ] choose ; immediate
|
|
|
|
~~~
|
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
## Conditionals
|
|
|
|
|
|
|
|
Taking a break from combinators for a bit, I turn to some words
|
|
|
|
for comparing things. First, constants for TRUE and FALSE.
|
|
|
|
|
|
|
|
Due to the way the conditional execution works, only these
|
|
|
|
values can be used. This is different than in a traditional
|
|
|
|
Forth, where non-zero values are true.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:TRUE (-n) #-1 ;
|
|
|
|
:FALSE (-n) #0 ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
The basic Rx kernel doesn't provide two useful forms which I'll
|
|
|
|
provide here.
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:lteq? (nn-f) dup-pair eq? [ lt? ] dip or ;
|
|
|
|
:gteq? (nn-f) dup-pair eq? [ gt? ] dip or ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2019-01-11 21:27:50 +01:00
|
|
|
~~~
|
2019-01-30 00:05:48 +01:00
|
|
|
:if; (qf-) over [ if ] dip 0; pop drop-pair ;
|
|
|
|
:-if; (qf-) over [ -if ] dip #-1 xor 0; pop drop-pair ;
|
2019-01-11 21:27:50 +01:00
|
|
|
~~~
|
|
|
|
|
2017-10-16 18:09:39 +02:00
|
|
|
And then some numeric comparators.
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:n:MAX (-n) #2147483647 ;
|
2017-10-25 03:36:47 +02:00
|
|
|
:n:MIN (-n) #-2147483648 ;
|
2017-10-16 18:09:39 +02:00
|
|
|
:n:zero? (n-f) #0 eq? ;
|
|
|
|
:n:-zero? (n-f) #0 -eq? ;
|
|
|
|
:n:negative? (n-f) #0 lt? ;
|
|
|
|
:n:positive? (n-f) #-1 gt? ;
|
|
|
|
:n:strictly-positive? (n-f) #0 gt? ;
|
|
|
|
:n:even? (n-f) #2 /mod drop n:zero? ;
|
|
|
|
:n:odd? (n-f) #2 /mod drop n:-zero? ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
## More Stack Shufflers.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
`rot` rotates the top three values.
|
|
|
|
|
2018-11-13 04:12:42 +01:00
|
|
|
High level:
|
|
|
|
|
|
|
|
:rot (abc-bca) [ swap ] dip swap ;
|
|
|
|
|
|
|
|
And low level, for inlining:
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2018-11-13 04:12:42 +01:00
|
|
|
:rot (abc-bca) `67503109 ; primitive
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
## Numeric Operations
|
|
|
|
|
|
|
|
The core Rx language provides addition, subtraction,
|
|
|
|
multiplication, and a combined division/remainder. Retro
|
|
|
|
expands on this.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-11-13 04:12:42 +01:00
|
|
|
I implement the division and remainder as low level words
|
|
|
|
so they can be inlined. Here's the high level forms:
|
|
|
|
|
|
|
|
:/ (nq-d) /mod nip ;
|
|
|
|
:mod (nq-r) /mod drop ;
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2019-03-14 18:59:02 +01:00
|
|
|
:/ (nq-d) (diswdr.. `197652 ) ; primitive
|
|
|
|
:mod (nq-r) (didr.... `788 ) ; primitive
|
2017-10-16 18:09:39 +02:00
|
|
|
:not (n-n) #-1 xor ;
|
|
|
|
:n:pow (bp-n) #1 swap [ over * ] times nip ;
|
|
|
|
:n:negate (n-n) #-1 * ;
|
|
|
|
:n:square (n-n) dup * ;
|
2018-08-29 17:47:21 +02:00
|
|
|
:n:sqrt (n-n)
|
|
|
|
#1 [ repeat dup-pair / over - #2 / 0; + again ] call nip ;
|
2017-10-16 18:09:39 +02:00
|
|
|
:n:min (nn-n) dup-pair lt? [ drop ] [ nip ] choose ;
|
|
|
|
:n:max (nn-n) dup-pair gt? [ drop ] [ nip ] choose ;
|
|
|
|
:n:abs (n-n) dup n:negate n:max ;
|
|
|
|
:n:limit (nlu-n) swap push n:min pop n:max ;
|
|
|
|
:n:inc (n-n) #1 + ;
|
|
|
|
:n:dec (n-n) #1 - ;
|
|
|
|
:n:between? (nul-) rot [ rot rot n:limit ] sip eq? ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
Some of the above, like `n:inc`, are useful with variables. But
|
|
|
|
it's messy to execute sequences like:
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
@foo n:inc !foo
|
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
The `v:` namespace provides words which simplify the overall
|
|
|
|
handling of variables. With this, the above can become simply:
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
&foo v:inc
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:v:inc-by (na-) [ fetch + ] sip store ;
|
|
|
|
:v:dec-by (na-) [ fetch swap - ] sip store ;
|
|
|
|
:v:inc (n-n) #1 swap v:inc-by ;
|
|
|
|
:v:dec (n-n) #1 swap v:dec-by ;
|
2018-08-29 17:47:21 +02:00
|
|
|
:v:limit (alu-)
|
|
|
|
push push dup fetch pop pop n:limit swap store ;
|
2017-10-16 18:09:39 +02:00
|
|
|
:v:on (a-) TRUE swap store ;
|
|
|
|
:v:off (a-) FALSE swap store ;
|
|
|
|
:allot (n-) &Heap v:inc-by ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
`v:preserve` is a combinator that executes a quotation while
|
|
|
|
preserving the contents of a variable.
|
|
|
|
|
|
|
|
E.g., instead of:
|
|
|
|
|
|
|
|
@Base [ #16 !Base ... ] dip !Base
|
|
|
|
|
|
|
|
You can do:
|
|
|
|
|
|
|
|
&Base [ #16 !Base ... ] v:preserve
|
|
|
|
|
|
|
|
This is primarily to aid in readability. I find it to be
|
|
|
|
helpful when revisiting older code as it makes the intent
|
|
|
|
a bit clearer.
|
|
|
|
|
|
|
|
~~~
|
|
|
|
:v:preserve (aq-)
|
|
|
|
swap dup fetch [ [ call ] dip ] dip swap store ;
|
|
|
|
~~~
|
|
|
|
|
|
|
|
If you need to update a stored variable there are two typical
|
|
|
|
forms:
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
#1 'Next var<n>
|
|
|
|
@Next #10 * !Next
|
|
|
|
|
|
|
|
Or:
|
|
|
|
|
|
|
|
#1 'Next var<n>
|
|
|
|
&Next [ fetch #10 * ] sip store
|
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
`v:update-using` replaces this with:
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
#1 'Next var<n>
|
|
|
|
&Next [ #10 * ] v:update-using
|
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
It takes care of preserving the variable address, fetching the
|
|
|
|
stored value, and updating with the resulting value.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:v:update-using (aq-) swap [ fetch swap call ] sip store ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
I have a simple word `copy` which copies memory to another
|
|
|
|
location.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:copy (aan-) [ &fetch-next dip store-next ] times drop drop ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
## Lexical Scope
|
|
|
|
|
2017-10-16 18:09:39 +02:00
|
|
|
Now for something tricky: a system for lexical scoping.
|
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
The dictionary is a simple linked list. Retro allows for some
|
|
|
|
control over what is visible using the `{{`, `---reveal---`,
|
|
|
|
and `}}` words.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
As an example:
|
|
|
|
|
|
|
|
{{
|
|
|
|
:increment dup fetch n:inc swap store ;
|
2017-10-25 03:22:49 +02:00
|
|
|
:Value `0 ; data
|
2017-10-16 18:09:39 +02:00
|
|
|
---reveal---
|
|
|
|
:next-number @Value &Value increment ;
|
|
|
|
}}
|
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
Only the `next-number` function will remain visible once `}}`
|
|
|
|
is executed.
|
|
|
|
|
|
|
|
It's important to note that this only provides a *lexical*
|
|
|
|
scope. Any variables are *global* (though the names may be
|
|
|
|
hidden), so use `v:preserve` if you need reentrancy.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:ScopeList `0 `0 ;
|
|
|
|
:{{ (-)
|
|
|
|
d:last dup &ScopeList store-next store ;
|
|
|
|
:---reveal--- (-)
|
|
|
|
d:last &ScopeList n:inc store ;
|
|
|
|
:}} (-)
|
|
|
|
&ScopeList fetch-next swap fetch eq?
|
|
|
|
[ @ScopeList !Dictionary ]
|
2018-08-29 17:47:21 +02:00
|
|
|
[ @ScopeList
|
|
|
|
[ &Dictionary repeat
|
|
|
|
fetch dup fetch &ScopeList n:inc fetch -eq? 0; drop
|
|
|
|
again ] call store ] choose ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
## Linear Buffers
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
A buffer is a linear memory buffer. Retro provides a `buffer:`
|
|
|
|
namespace for working with them.
|
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
This is something I've used for years. It's simple, but makes
|
|
|
|
it easy to construct strings (as it writes a trailing ASCII
|
|
|
|
null) and other simple structures.
|
|
|
|
|
2018-09-05 17:40:02 +02:00
|
|
|
| word | used for |
|
|
|
|
| --------------- | -------------------------------------- |
|
|
|
|
| buffer:start | return the first address in the buffer |
|
|
|
|
| buffer:end | return the last address in the buffer |
|
|
|
|
| buffer:add | add a value to the end of the buffer |
|
|
|
|
| buffer:get | remove & return the last value |
|
|
|
|
| buffer:empty | remove all values from the buffer |
|
|
|
|
| buffer:size | return the number of stored values |
|
|
|
|
| buffer:set | set an address as the start of the |
|
|
|
|
| | buffer |
|
|
|
|
| buffer:preserve | preserve the current buffer pointers & |
|
|
|
|
| | execute a quotation that may set a new |
|
|
|
|
| | buffer. restores the saved pointers |
|
|
|
|
| | when done |
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
{{
|
|
|
|
:Buffer `0 ; data
|
|
|
|
:Ptr `0 ; data
|
|
|
|
:terminate (-) #0 @Ptr store ;
|
|
|
|
---reveal---
|
|
|
|
:buffer:start (-a) @Buffer ;
|
|
|
|
:buffer:end (-a) @Ptr ;
|
|
|
|
:buffer:add (c-) buffer:end store &Ptr v:inc terminate ;
|
|
|
|
:buffer:get (-c) &Ptr v:dec buffer:end fetch terminate ;
|
|
|
|
:buffer:empty (-) buffer:start !Ptr terminate ;
|
|
|
|
:buffer:size (-n) buffer:end buffer:start - ;
|
|
|
|
:buffer:set (a-) !Buffer buffer:empty ;
|
|
|
|
:buffer:preserve (q-)
|
|
|
|
@Buffer @Ptr [ [ call ] dip !Buffer ] dip !Ptr ;
|
|
|
|
}}
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
## Strings
|
|
|
|
|
2018-09-05 17:40:02 +02:00
|
|
|
Traditional Forth systems have a messy mix of strings. You have
|
|
|
|
counted strings, address/length pairs, and sometimes other
|
|
|
|
forms.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-09-05 17:40:02 +02:00
|
|
|
Retro uses zero terminated strings. Counted strings are better
|
|
|
|
in many ways, but I've used these for years and they are a
|
|
|
|
workable approach. (Though caution in needed to avoid buffer
|
|
|
|
overflow).
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
Temporary strings are allocated in a circular pool (`STRINGS`).
|
|
|
|
This space can be altered as needed by adjusting these
|
|
|
|
variables.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-25 03:10:58 +02:00
|
|
|
:TempStrings ; data #32 !TempStrings
|
|
|
|
:TempStringMax ; data #512 !TempStringMax
|
2017-10-16 18:09:39 +02:00
|
|
|
:STRINGS EOM @TempStrings @TempStringMax * - ;
|
|
|
|
|
|
|
|
{{
|
2018-08-21 03:24:24 +02:00
|
|
|
:Current `0 ; data
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-21 03:24:24 +02:00
|
|
|
:s:pointer (-p) @Current @TempStringMax * STRINGS + ;
|
2017-10-16 18:09:39 +02:00
|
|
|
:s:next (-)
|
2018-08-21 03:24:24 +02:00
|
|
|
&Current v:inc
|
|
|
|
@Current @TempStrings eq? [ #0 !Current ] if ;
|
2017-10-16 18:09:39 +02:00
|
|
|
---reveal---
|
2018-09-06 17:50:08 +02:00
|
|
|
:s:temp (s-s) dup s:length n:inc s:pointer swap copy
|
|
|
|
s:pointer s:next ;
|
2018-12-21 02:47:03 +01:00
|
|
|
:s:empty (-s) s:pointer s:next #0 over store ;
|
2017-10-16 18:09:39 +02:00
|
|
|
}}
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
Permanent strings are compiled into memory. To skip over them a
|
|
|
|
helper function is used. When compiled into a definition this
|
|
|
|
will look like:
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-21 03:24:24 +02:00
|
|
|
i lica....
|
|
|
|
r s:skip
|
|
|
|
d 98
|
|
|
|
d 99
|
|
|
|
d 100
|
|
|
|
d 0
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-09-05 17:40:02 +02:00
|
|
|
It'd be faster to compile a jump over the string instead. I use
|
|
|
|
this approach as it makes it simpler to identify strings when
|
|
|
|
debugging.
|
|
|
|
|
|
|
|
`s:skip` is the helper function which adjusts the Nga instruction
|
|
|
|
pointer to skip to the code following the stored string.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2018-09-05 17:40:02 +02:00
|
|
|
:s:skip (-)
|
|
|
|
pop [ fetch-next n:-zero? ] while n:dec push ;
|
|
|
|
|
|
|
|
:s:keep (s-s)
|
|
|
|
compiling? [ &s:skip compile:call ] if
|
|
|
|
here [ s, ] dip class:data ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
And now a quick `'` prefix. (This will be replaced later). What
|
|
|
|
this does is either move the string token to the temporary
|
|
|
|
buffer or compile it into the current definition.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
This doesn't support spaces. I use underscores instead. E.g.,
|
|
|
|
|
|
|
|
'Hello_World!
|
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
Later in the code I'll add a better implementation which can
|
|
|
|
handle conversion of _ into spaces.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:prefix:' compiling? [ s:keep ] [ s:temp ] choose ; immediate
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
`s:chop` removes the last character from a string.
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:s:chop (s-s) s:temp dup s:length over + n:dec #0 swap store ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
`s:reverse` reverses the order of a string. E.g.,
|
|
|
|
|
2018-09-05 17:40:02 +02:00
|
|
|
'hello -> 'olleh
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:s:reverse (s-s)
|
|
|
|
[ dup s:temp buffer:set &s:length [ dup s:length + n:dec ] bi swap
|
|
|
|
[ dup fetch buffer:add n:dec ] times drop buffer:start s:temp ]
|
|
|
|
buffer:preserve ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
Trimming removes leading (`s:trim-left`) or trailing
|
|
|
|
(`s:trim-right`) spaces from a string. `s:trim` removes
|
|
|
|
both leading and trailing spaces.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2018-09-06 17:50:08 +02:00
|
|
|
:s:trim-left (s-s)
|
|
|
|
s:temp [ fetch-next [ #32 eq? ] [ n:-zero? ] bi and ] while
|
|
|
|
n:dec ;
|
2017-10-16 18:09:39 +02:00
|
|
|
:s:trim-right (s-s) s:temp s:reverse s:trim-left s:reverse ;
|
|
|
|
:s:trim (s-s) s:trim-right s:trim-left ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
`s:prepend` and `s:append` for concatenating strings together.
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:s:prepend (ss-s)
|
|
|
|
s:temp [ dup s:length + [ dup s:length n:inc ] dip swap copy ] sip ;
|
|
|
|
:s:append (ss-s) swap s:prepend ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
`s:for-each` executes a quote once for each cell in string. It is
|
|
|
|
a key part of building the other high-level string operations.
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:s:for-each (sq-)
|
|
|
|
[ repeat
|
|
|
|
over fetch 0; drop
|
|
|
|
dup-pair
|
2018-08-29 17:47:21 +02:00
|
|
|
[ [ &fetch dip call ] dip ] dip
|
2017-10-16 18:09:39 +02:00
|
|
|
[ n:inc ] dip
|
|
|
|
again
|
|
|
|
] call drop-pair ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-04-09 13:38:14 +02:00
|
|
|
Building on `s:for-each`, I am able to implement `s:index-of`, which
|
|
|
|
finds the first instance of a character in a string.
|
|
|
|
|
|
|
|
~~~
|
|
|
|
:s:index-of (sc-n)
|
|
|
|
swap [ repeat
|
|
|
|
fetch-next 0; swap
|
|
|
|
[ over -eq? ] dip
|
|
|
|
swap 0; drop
|
|
|
|
again
|
|
|
|
] sip
|
|
|
|
[ - n:dec nip ] sip
|
|
|
|
s:length over eq? [ drop #-1 ] if ;
|
|
|
|
~~~
|
|
|
|
|
2018-09-06 17:50:08 +02:00
|
|
|
`s:contains-char?` returns a flag indicating whether or not a
|
|
|
|
given character is in a string.
|
2018-04-09 13:38:14 +02:00
|
|
|
|
|
|
|
~~~
|
|
|
|
:s:contains-char? (sc-f) s:index-of #-1 -eq? ;
|
|
|
|
~~~
|
|
|
|
|
2018-09-06 17:50:08 +02:00
|
|
|
`s:contains-string?` returns a flag indicating whether or not
|
|
|
|
a given substring is in a string.
|
2018-04-09 13:38:14 +02:00
|
|
|
|
|
|
|
~~~
|
|
|
|
{{
|
|
|
|
'Src var
|
|
|
|
'Tar var
|
|
|
|
'Pad var
|
|
|
|
'I var
|
|
|
|
'F var
|
|
|
|
'At var
|
|
|
|
|
|
|
|
:terminate (-)
|
|
|
|
#0 @Pad @Tar s:length + store ;
|
|
|
|
|
|
|
|
:extract (-)
|
|
|
|
@Src @I + @Pad @Tar s:length copy ;
|
|
|
|
|
|
|
|
:compare (-)
|
|
|
|
@Pad @Tar s:eq? @F or !F @F [ @I !At ] -if ;
|
|
|
|
|
|
|
|
:next (-)
|
|
|
|
&I v:inc ;
|
|
|
|
---reveal---
|
|
|
|
:s:contains-string? (ss-f)
|
|
|
|
!Tar !Src s:empty !Pad #0 !I #0 !F
|
|
|
|
@Src s:length
|
|
|
|
[ extract terminate compare next ] times
|
|
|
|
@F ;
|
|
|
|
|
|
|
|
:s:index-of-string (ss-a)
|
|
|
|
!Tar !Src s:empty !Pad #0 !I #0 !F #-1 !At
|
|
|
|
@Src s:length
|
|
|
|
[ extract terminate compare next ] times
|
|
|
|
@F [ @At ] [ #-1 ] choose ;
|
|
|
|
}}
|
|
|
|
~~~
|
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
`s:filter` returns a new string, consisting of the characters
|
|
|
|
from another string that are filtered by a quotation.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
'This_is_a_test [ c:-vowel? ] s:filter
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:s:filter (sq-s)
|
|
|
|
[ s:empty buffer:set swap
|
|
|
|
[ dup-pair swap call
|
|
|
|
[ buffer:add ]
|
|
|
|
[ drop ] choose
|
|
|
|
] s:for-each drop buffer:start
|
|
|
|
] buffer:preserve ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
`s:map` Return a new string resulting from applying a quotation
|
|
|
|
to each character in a source string.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
'This_is_a_test [ $_ [ ASCII:SPACE ] case ] s:map
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:s:map (sq-s)
|
|
|
|
[ s:empty buffer:set swap
|
|
|
|
[ over call buffer:add ]
|
|
|
|
s:for-each drop buffer:start
|
|
|
|
] buffer:preserve ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
`s:substr` returns a subset of a string. Provide it with a
|
|
|
|
string, a starting offset, and a length.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:s:substr (sfl-s)
|
|
|
|
[ + s:empty ] dip [ over [ copy ] dip ] sip
|
|
|
|
over [ + #0 swap store ] dip ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
`s:right` and `s:left` are similar to `s:substr`, but operate
|
|
|
|
from fixed ends of the string.
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:s:right (sn-s) over s:length over - swap s:substr ;
|
|
|
|
:s:left (sn-s) #0 swap s:substr ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
Hash (using DJB2)
|
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
I use the djb2 hash algorithm for computing hashes from
|
|
|
|
strings. There are better hashes out there, but this is
|
|
|
|
pretty simple and works well for my needs. This was based
|
|
|
|
on an implementation at http://www.cse.yorku.ca/~oz/hash.html
|
2017-10-23 20:56:56 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:s:hash (s-n) #5381 swap [ swap #33 * + ] s:for-each ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
Copy a string, including the terminator.
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:s:copy (ss-) over s:length n:inc copy ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-09-06 17:50:08 +02:00
|
|
|
RETRO provides string constants for several ranges of
|
|
|
|
characters that are of some general interest.
|
2017-10-25 03:10:58 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:s:DIGITS (-s) '0123456789 ;
|
|
|
|
:s:ASCII-LOWERCASE (-s) 'abcdefghijklmnopqrstuvwxyz ;
|
|
|
|
:s:ASCII-UPPERCASE (-s) 'ABCDEFGHIJKLMNOPQRSTUVWXYZ ;
|
2018-09-06 17:50:08 +02:00
|
|
|
:s:ASCII-LETTERS (-s)
|
|
|
|
'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ ;
|
|
|
|
:s:PUNCTUATION (-s)
|
|
|
|
'_!"#$%&'()*+,-./:;<=>?@[\]^`{|}~ $_ over store ;
|
2018-08-21 03:24:24 +02:00
|
|
|
's:WHITESPACE d:create
|
|
|
|
#32, #9 , #10 , #13 , #0 ,
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
## ASCII Constants
|
|
|
|
|
|
|
|
Not all characters can be obtained via the $ prefix. ASCII has
|
|
|
|
many characters that aren't really intended to be printable.
|
|
|
|
Retro has an `ASCII` namespace providing symbolic names for
|
|
|
|
these.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-11-07 14:40:15 +01:00
|
|
|
#0 'ASCII:NUL const #1 'ASCII:SOH const
|
|
|
|
#2 'ASCII:STX const #3 'ASCII:ETX const
|
|
|
|
#4 'ASCII:EOT const #5 'ASCII:ENQ const
|
|
|
|
#6 'ASCII:ACK const #7 'ASCII:BEL const
|
|
|
|
#8 'ASCII:BS const #9 'ASCII:HT const
|
|
|
|
#10 'ASCII:LF const #11 'ASCII:VT const
|
|
|
|
#12 'ASCII:FF const #13 'ASCII:CR const
|
|
|
|
#14 'ASCII:SO const #15 'ASCII:SI const
|
|
|
|
#16 'ASCII:DLE const #17 'ASCII:DC1 const
|
|
|
|
#18 'ASCII:DC2 const #19 'ASCII:DC3 const
|
|
|
|
#20 'ASCII:DC4 const #21 'ASCII:NAK const
|
|
|
|
#22 'ASCII:SYN const #23 'ASCII:ETB const
|
|
|
|
#24 'ASCII:CAN const #25 'ASCII:EM const
|
|
|
|
#26 'ASCII:SUB const #27 'ASCII:ESC const
|
|
|
|
#28 'ASCII:FS const #29 'ASCII:GS const
|
|
|
|
#30 'ASCII:RS const #31 'ASCII:US const
|
|
|
|
#32 'ASCII:SPACE const #127 'ASCII:DEL const
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
These words operate on character values. Retro currently deals
|
|
|
|
with ASCII, though cells are 32 bits in length, so Unicode
|
|
|
|
values can be stored.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
First are a bunch of words to help identify character values.
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:c:letter? (c-f) $A $z n:between? ;
|
|
|
|
:c:lowercase? (c-f) $a $z n:between? ;
|
|
|
|
:c:uppercase? (c-f) $A $Z n:between? ;
|
|
|
|
:c:digit? (c-f) $0 $9 n:between? ;
|
2018-08-29 17:47:21 +02:00
|
|
|
:c:visible? (c-f) #31 #126 n:between? ;
|
|
|
|
:c:vowel? (c-f) 'aeiouAEIOU swap s:contains-char? ;
|
|
|
|
:c:consonant? (c-f)
|
|
|
|
dup c:letter? [ c:vowel? not ] [ drop FALSE ] choose ;
|
|
|
|
|
2018-04-09 13:38:14 +02:00
|
|
|
{{
|
|
|
|
'WS d:create
|
|
|
|
ASCII:SPACE , ASCII:HT , ASCII:LF , ASCII:CR , #0 ,
|
|
|
|
---reveal---
|
|
|
|
:c:whitespace? (c-f) &WS swap s:contains-char? ;
|
|
|
|
}}
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
And the inverse forms. (These are included for readability and
|
|
|
|
orthiginal completion).
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-25 03:32:19 +02:00
|
|
|
:c:-lowercase? (c-f) c:lowercase? not ;
|
|
|
|
:c:-uppercase? (c-f) c:uppercase? not ;
|
|
|
|
:c:-digit? (c-f) c:digit? not ;
|
|
|
|
:c:-whitespace? (c-f) c:whitespace? not ;
|
|
|
|
:c:-visible? (c-f) c:visible? not ;
|
|
|
|
:c:-vowel? (c-f) c:vowel? not ;
|
|
|
|
:c:-consonant? (c-f) c:consonant? not ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
The next few words perform simple transformations.
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:c:to-upper (c-c) dup c:lowercase? 0; drop ASCII:SPACE - ;
|
|
|
|
:c:to-lower (c-c) dup c:uppercase? 0; drop ASCII:SPACE + ;
|
|
|
|
:c:to-string (c-s) '. s:temp [ store ] sip ;
|
2018-09-06 17:50:08 +02:00
|
|
|
:c:toggle-case (c-c)
|
|
|
|
dup c:lowercase? [ c:to-upper ] [ c:to-lower ] choose ;
|
|
|
|
:c:to-number (c-n)
|
|
|
|
dup c:digit? [ $0 - ] [ drop #0 ] choose ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
## Back to Strings
|
|
|
|
|
2017-10-16 18:09:39 +02:00
|
|
|
With the character transformations a few more string words are
|
|
|
|
possible.
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:s:to-upper (s-s) [ c:to-upper ] s:map ;
|
|
|
|
:s:to-lower (s-s) [ c:to-lower ] s:map ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
Convert a decimal (base 10) number to a string.
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
{{
|
2017-10-25 03:32:19 +02:00
|
|
|
'Value var
|
2017-10-16 18:09:39 +02:00
|
|
|
:correct (c-c)
|
|
|
|
dup $0 lt? [ $0 over - #2 * + ] if ;
|
|
|
|
---reveal---
|
|
|
|
:n:to-string (n-s)
|
|
|
|
[ here buffer:set dup !Value n:abs
|
|
|
|
[ #10 /mod swap $0 + correct buffer:add dup n:-zero? ] while drop
|
|
|
|
@Value n:negative? [ $- buffer:add ] if
|
|
|
|
buffer:start s:reverse s:temp ] buffer:preserve ;
|
|
|
|
}}
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-09-06 17:50:08 +02:00
|
|
|
Now replace the old prefix:' with this one that can optionally
|
|
|
|
turn underscores into spaces.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
TRUE 'RewriteUnderscores var<n>
|
|
|
|
|
|
|
|
{{
|
|
|
|
:sub (c-c) $_ [ ASCII:SPACE ] case ;
|
|
|
|
:rewrite (s-s)
|
2019-02-22 04:35:28 +01:00
|
|
|
@RewriteUnderscores [ &sub s:map ] if ;
|
|
|
|
:handle &prefix:' call ;
|
2017-10-16 18:09:39 +02:00
|
|
|
---reveal---
|
2019-02-22 04:35:28 +01:00
|
|
|
:prefix:' rewrite handle ; immediate
|
2019-01-03 21:12:56 +01:00
|
|
|
:prefix:" rewrite s:keep ; immediate
|
2017-10-16 18:09:39 +02:00
|
|
|
}}
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
The `s:split` splits a string on the first instance of a given
|
|
|
|
character. Results are undefined if the character can not be
|
|
|
|
located.
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:s:split (sc-ss)
|
|
|
|
dup-pair s:index-of nip dup-pair s:left [ + ] dip ;
|
2017-11-09 20:28:01 +01:00
|
|
|
|
|
|
|
:s:split-on-string (ss-ss)
|
|
|
|
dup-pair s:index-of-string n:inc nip dup-pair s:left [ + ] dip ;
|
|
|
|
|
2018-08-21 03:24:24 +02:00
|
|
|
:s:replace (sss-s)
|
|
|
|
over s:length here store
|
|
|
|
[ s:split-on-string swap here fetch + ] dip s:prepend s:append ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-09-06 17:50:08 +02:00
|
|
|
`s:tokenize` takes a string and a character to use as a
|
|
|
|
separator. It splits the string into a set of substrings and
|
|
|
|
returns a set containing pointers to each of them.
|
2017-11-13 13:52:10 +01:00
|
|
|
|
|
|
|
~~~
|
|
|
|
{{
|
|
|
|
'Split-On var
|
|
|
|
:match? (c-f) @Split-On eq? ;
|
|
|
|
:terminate (s-s) #0 over n:dec store ;
|
2018-08-29 17:47:21 +02:00
|
|
|
:step (ss-s)
|
|
|
|
[ n:inc ] dip match? [ dup , terminate ] if ;
|
2017-11-13 13:52:10 +01:00
|
|
|
---reveal---
|
|
|
|
:s:tokenize (sc-a)
|
|
|
|
!Split-On s:keep
|
|
|
|
here #0 , [ dup , dup [ step ] s:for-each drop ] dip
|
|
|
|
here over - n:dec over store ;
|
|
|
|
}}
|
|
|
|
~~~
|
|
|
|
|
2017-11-13 14:05:46 +01:00
|
|
|
`s:tokenize-on-string` is like `s:tokenize`, but for strings.
|
|
|
|
|
|
|
|
~~~
|
|
|
|
{{
|
|
|
|
'Tokens var
|
|
|
|
'Needle var
|
2018-08-29 17:47:21 +02:00
|
|
|
:-match? (s-sf)
|
|
|
|
dup @Needle s:contains-string? ;
|
|
|
|
:save-token (s-s)
|
|
|
|
@Needle s:split-on-string s:keep buffer:add n:inc ;
|
|
|
|
:tokens-to-set (-a)
|
|
|
|
here @Tokens buffer:size dup , [ fetch-next , ] times drop ;
|
2017-11-13 14:05:46 +01:00
|
|
|
---reveal---
|
|
|
|
:s:tokenize-on-string (ss-a)
|
|
|
|
[ s:keep !Needle here #8192 + !Tokens
|
|
|
|
@Tokens buffer:set
|
2018-08-29 17:47:21 +02:00
|
|
|
[ repeat -match? 0; drop save-token again ] call
|
|
|
|
s:keep buffer:add tokens-to-set ] buffer:preserve ;
|
2017-11-13 14:05:46 +01:00
|
|
|
}}
|
|
|
|
~~~
|
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
Use `s:format` to construct a string from multiple items. This
|
|
|
|
can be illustrated with:
|
|
|
|
|
|
|
|
#4 #6 #10 '%n-%n=%n\n s:format
|
|
|
|
|
|
|
|
The format language is simple:
|
|
|
|
|
|
|
|
| \r | Replace with a CR |
|
|
|
|
| \n | Replace with a LF |
|
|
|
|
| \t | Replace with a TAB |
|
|
|
|
| \\ | Replace with a single \ |
|
|
|
|
| \ | Replace with an underscore (_) |
|
2018-09-06 17:50:08 +02:00
|
|
|
| \0 | Replace with NUL |
|
2018-08-29 17:47:21 +02:00
|
|
|
| %c | Replace with a character on the stack |
|
|
|
|
| %s | Replace with a string on the stack |
|
|
|
|
| %n | Replace with the next number on the stack |
|
|
|
|
|
|
|
|
~~~
|
|
|
|
{{
|
|
|
|
:char (c-)
|
|
|
|
ASCII:SPACE [ $_ buffer:add ] case
|
2018-09-06 17:50:08 +02:00
|
|
|
$r [ ASCII:CR buffer:add ] case
|
|
|
|
$n [ ASCII:LF buffer:add ] case
|
|
|
|
$t [ ASCII:HT buffer:add ] case
|
|
|
|
$0 [ ASCII:NUL buffer:add ] case
|
2018-08-29 17:47:21 +02:00
|
|
|
buffer:add ;
|
|
|
|
|
|
|
|
:string (a-a)
|
|
|
|
repeat fetch-next 0; buffer:add again ;
|
|
|
|
|
|
|
|
:type (aac-)
|
|
|
|
$c [ swap buffer:add ] case
|
|
|
|
$s [ swap string drop ] case
|
|
|
|
$n [ swap n:to-string string drop ] case
|
|
|
|
drop ;
|
|
|
|
|
|
|
|
:handle (ac-a)
|
|
|
|
$\ [ fetch-next char ] case
|
|
|
|
$% [ fetch-next type ] case
|
|
|
|
buffer:add ;
|
|
|
|
---reveal---
|
|
|
|
:s:format (...s-s)
|
|
|
|
[ s:empty [ buffer:set
|
|
|
|
[ repeat fetch-next 0; handle again ]
|
|
|
|
call drop ] sip ] buffer:preserve ;
|
|
|
|
}}
|
|
|
|
~~~
|
|
|
|
|
|
|
|
~~~
|
|
|
|
:s:const (ss-) [ s:keep ] dip const ;
|
|
|
|
~~~
|
|
|
|
|
|
|
|
## The Ultimate Stack Shuffler
|
2017-11-13 14:05:46 +01:00
|
|
|
|
2017-10-16 18:09:39 +02:00
|
|
|
Ok, This is a bit of a hack, but very useful at times.
|
|
|
|
|
|
|
|
Assume you have a bunch of values:
|
|
|
|
|
|
|
|
#3 #1 #2 #5
|
|
|
|
|
|
|
|
And you want to reorder them into something new:
|
|
|
|
|
|
|
|
#1 #3 #5 #5 #2 #1
|
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
Rather than using a lot of shufflers, `reorder` simplfies this
|
|
|
|
into:
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
#3 #1 #2 #5
|
|
|
|
'abcd 'baddcb reorder
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
{{
|
|
|
|
'Values var #27 allot
|
|
|
|
:from s:length dup [ [ &Values + store ] sip n:dec ] times drop ;
|
|
|
|
:to dup s:length [ fetch-next $a - n:inc &Values + fetch swap ] times drop ;
|
|
|
|
---reveal---
|
|
|
|
:reorder (...ss-?) [ from ] dip to ;
|
|
|
|
}}
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
## Extending The Language
|
|
|
|
|
|
|
|
`does` is intended to be paired with `d:create` to attach an
|
|
|
|
action to a newly created data structure. An example use might
|
|
|
|
be something like:
|
2017-10-25 03:10:58 +02:00
|
|
|
|
|
|
|
:constant (ns-) d:create , [ fetch ] does ;
|
|
|
|
|
|
|
|
In a traditional Forth this is similar in spirit to DOES>.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2018-09-06 17:50:08 +02:00
|
|
|
:curry (vp-p)
|
|
|
|
here [ swap compile:lit compile:call compile:ret ] dip ;
|
|
|
|
:does (q-)
|
|
|
|
d:last<xt> swap curry d:last d:xt store &class:word reclass ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
`d:for-each` is a combinator which runs a quote once for each
|
2018-09-06 17:50:08 +02:00
|
|
|
header in the dictionary. A pointer to each header will be
|
|
|
|
passed to the quote as it is run.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-25 03:22:49 +02:00
|
|
|
This can be used for implementing `words`:
|
|
|
|
|
2018-05-07 18:24:36 +02:00
|
|
|
[ d:name s:put sp ] d:for-each
|
2017-10-25 03:22:49 +02:00
|
|
|
|
|
|
|
Or finding the length of the longest name in the dictionary:
|
|
|
|
|
|
|
|
#0 [ d:name s:length n:max ] d:for-each
|
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
It's a handy combinator that lets me quickly walk though the
|
|
|
|
entire dictionary in a very clean manner.
|
2017-10-25 03:22:49 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:d:for-each (q-)
|
|
|
|
&Dictionary [ repeat fetch 0;
|
|
|
|
dup-pair [ [ swap call ] dip ] dip again ] call drop ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
Using `d:for-each`, I implement a means of looking up a
|
|
|
|
dictionary header by the `d:xt` field.
|
2017-10-29 03:09:56 +01:00
|
|
|
|
|
|
|
~~~
|
|
|
|
:d:lookup-xt (a-d)
|
|
|
|
#0 swap [ dup-pair d:xt fetch eq?
|
2018-08-29 17:47:21 +02:00
|
|
|
[ swap &nip dip ] &drop choose ] d:for-each drop ;
|
2017-10-20 15:30:31 +02:00
|
|
|
~~~
|
|
|
|
|
2019-02-21 05:19:14 +01:00
|
|
|
## Arrays
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2019-02-21 05:19:14 +01:00
|
|
|
Retro provides words for statically sized arrays. They are
|
|
|
|
represented in memory as:
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
count
|
|
|
|
data #1 (first)
|
|
|
|
...
|
|
|
|
data #n (last)
|
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
Since the count comes first, a simple `fetch` will suffice to
|
|
|
|
get it, but for completeness (and to allow for future changes),
|
2019-02-21 05:19:14 +01:00
|
|
|
we wrap this as `array:length`:
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2019-02-21 05:19:14 +01:00
|
|
|
:array:length (a-n) fetch ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2019-02-21 05:19:14 +01:00
|
|
|
The first couple of words are used to create arrays. The first,
|
|
|
|
`array:counted-results` executes a quote which returns values
|
|
|
|
and a count. It then creates an array with the provided data.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2019-02-21 05:19:14 +01:00
|
|
|
:array:counted-results (q-a)
|
2019-01-11 04:26:11 +01:00
|
|
|
call here [ dup , &, times ] dip ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2019-02-21 05:19:14 +01:00
|
|
|
The second, `array:from-string`, creates a new string with the
|
2018-08-29 17:47:21 +02:00
|
|
|
characters in given a string.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2019-02-21 05:19:14 +01:00
|
|
|
:array:from-string (s-a)
|
2018-11-20 03:56:13 +01:00
|
|
|
here [ dup s:length , [ , ] s:for-each ] dip ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2019-02-21 05:19:14 +01:00
|
|
|
A very crucial piece is `array:for-each`. This runs a quote once
|
|
|
|
against each value in an array. This is leveraged to implement
|
2018-08-29 17:47:21 +02:00
|
|
|
additional combinators.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
{{
|
|
|
|
'Q var
|
|
|
|
---reveal---
|
2019-02-21 05:19:14 +01:00
|
|
|
:array:for-each (aq-)
|
2017-10-25 03:22:49 +02:00
|
|
|
&Q [ !Q fetch-next
|
2017-10-16 18:09:39 +02:00
|
|
|
[ fetch-next swap [ @Q call ] dip ] times drop
|
2017-10-25 03:22:49 +02:00
|
|
|
] v:preserve ;
|
2017-10-16 18:09:39 +02:00
|
|
|
}}
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2019-02-21 05:19:14 +01:00
|
|
|
With this I can easily define `array:dup` to make a copy of an
|
|
|
|
array.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2019-02-21 05:19:14 +01:00
|
|
|
:array:dup (a-a)
|
|
|
|
here [ dup fetch , [ , ] array:for-each ] dip ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2019-02-21 05:19:14 +01:00
|
|
|
Next is `array:filter`, which is extracts matching values from
|
|
|
|
an array. This is used like:
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-11-20 03:56:13 +01:00
|
|
|
{ #1 #2 #3 #4 #5 #6 #7 #8 }
|
2019-02-21 05:19:14 +01:00
|
|
|
[ n:even? ] array:filter
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2019-02-21 05:19:14 +01:00
|
|
|
It returns a new array with the values that the quote returned
|
2018-08-29 17:47:21 +02:00
|
|
|
a `TRUE` flag for.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2019-02-21 05:19:14 +01:00
|
|
|
:array:filter (aq-)
|
2017-10-16 18:09:39 +02:00
|
|
|
[ over [ call ] dip swap [ , ] [ drop ] choose ] curry
|
2019-02-21 05:19:14 +01:00
|
|
|
here [ over fetch , array:for-each ] dip
|
2018-09-06 17:50:08 +02:00
|
|
|
here over - n:dec over store ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2019-02-21 05:19:14 +01:00
|
|
|
Next are `array:contains?` and `array:contains-string?` which
|
2018-08-29 17:47:21 +02:00
|
|
|
compare a given value to each item in the array and returns
|
|
|
|
a flag.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
{{
|
|
|
|
'F var
|
|
|
|
---reveal---
|
2019-02-21 05:19:14 +01:00
|
|
|
:array:contains? (na-f)
|
2017-10-16 18:09:39 +02:00
|
|
|
&F v:off
|
2019-02-21 05:19:14 +01:00
|
|
|
[ over eq? @F or !F ] array:for-each
|
2017-10-16 18:09:39 +02:00
|
|
|
drop @F ;
|
|
|
|
|
2019-02-21 05:19:14 +01:00
|
|
|
:array:contains-string? (sa-f)
|
2017-10-16 18:09:39 +02:00
|
|
|
&F v:off
|
2019-02-21 05:19:14 +01:00
|
|
|
[ over s:eq? @F or !F ] array:for-each
|
2017-10-16 18:09:39 +02:00
|
|
|
drop @F ;
|
|
|
|
}}
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2019-02-21 05:19:14 +01:00
|
|
|
I implemented `array:map` to apply a quotation to each item in
|
|
|
|
an array and construct a new array from the returned values.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
Example:
|
|
|
|
|
2018-11-20 03:56:13 +01:00
|
|
|
{ #1 #2 #3 }
|
2019-02-21 05:19:14 +01:00
|
|
|
[ #10 * ] array:map
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2019-02-21 05:19:14 +01:00
|
|
|
:array:map (aq-a)
|
2017-10-16 18:09:39 +02:00
|
|
|
[ call , ] curry
|
2019-02-21 05:19:14 +01:00
|
|
|
here [ over fetch , array:for-each ] dip ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2019-02-21 05:19:14 +01:00
|
|
|
You can use `array:reverse` to make a copy of an array with the
|
2019-01-11 04:26:11 +01:00
|
|
|
values reversed.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2019-02-21 05:19:14 +01:00
|
|
|
:array:reverse (a-a)
|
2017-10-16 18:09:39 +02:00
|
|
|
here [ fetch-next [ + n:dec ] sip dup ,
|
|
|
|
[ dup fetch , n:dec ] times drop
|
|
|
|
] dip ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2019-02-21 05:19:14 +01:00
|
|
|
`array:nth` provides a quick means of adjusting an array and
|
|
|
|
offset into an address for use with `fetch` and `store`.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2019-02-21 05:19:14 +01:00
|
|
|
:array:nth (an-a)
|
2017-10-16 18:09:39 +02:00
|
|
|
+ n:inc ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2019-02-21 05:19:14 +01:00
|
|
|
`array:reduce` takes an array, a starting value, and a quote. It
|
|
|
|
executes the quote once for each item in the array, passing the
|
2018-08-29 17:47:21 +02:00
|
|
|
item and the value to the quote. The quote should consume both
|
|
|
|
and return a new value.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2019-02-21 05:19:14 +01:00
|
|
|
:array:reduce (pnp-n)
|
|
|
|
[ swap ] dip array:for-each ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2019-02-21 05:19:14 +01:00
|
|
|
When making an array, I often want the values in the original
|
|
|
|
order. The `array:counted-results array:reverse` is a bit long, so
|
|
|
|
I'm defining a new `array:make` which wraps these.
|
2018-05-10 12:45:38 +02:00
|
|
|
|
|
|
|
~~~
|
2019-02-21 05:19:14 +01:00
|
|
|
:array:make (q-a)
|
|
|
|
array:counted-results array:reverse ;
|
2018-07-14 17:22:04 +02:00
|
|
|
|
2018-11-20 04:05:56 +01:00
|
|
|
:{ (-) |[ |depth |[ ; immediate
|
2019-02-21 05:19:14 +01:00
|
|
|
:} (-a) |] |dip |depth |swap |- |n:dec |] |array:make ; immediate
|
2018-05-10 12:45:38 +02:00
|
|
|
~~~
|
|
|
|
|
2017-10-16 18:09:39 +02:00
|
|
|
## Muri: an assembler
|
|
|
|
|
|
|
|
Muri is my minimalist assembler for Nga. This is an attempt to
|
|
|
|
implement something similar in Retro.
|
|
|
|
|
2017-10-23 20:45:49 +02:00
|
|
|
This requires some knowledge of the Nga architecture to be
|
|
|
|
useful. The major elements are:
|
|
|
|
|
|
|
|
**Instruction Set**
|
|
|
|
|
|
|
|
Nga has 27 instructions. These are:
|
|
|
|
|
|
|
|
0 nop 7 jump 14 gt 21 and
|
|
|
|
1 lit <v> 8 call 15 fetch 22 or
|
|
|
|
2 dup 9 ccall 16 store 23 xor
|
|
|
|
3 drop 10 return 17 add 24 shift
|
|
|
|
4 swap 11 eq 18 sub 25 zret
|
|
|
|
5 push 12 neq 19 mul 26 end
|
|
|
|
6 pop 13 lt 20 divmod
|
|
|
|
|
|
|
|
The mnemonics allow for each name to be reduced to just two
|
|
|
|
characters. In the same order as above:
|
|
|
|
|
|
|
|
no ju gt an
|
|
|
|
li ca fe or
|
|
|
|
du cc st xo
|
|
|
|
dr re ad sh
|
|
|
|
sw eq su zr
|
|
|
|
pu ne mu en
|
|
|
|
po lt di
|
|
|
|
|
|
|
|
Up to four instructions can be packed into a single memory
|
|
|
|
location. (You can only use *no*p after a *ju*mp, *ca*ll,
|
|
|
|
*cc*all, *re*t, or *zr*et as these alter the instruction
|
|
|
|
pointer.)
|
|
|
|
|
|
|
|
So a bundled sequence like:
|
|
|
|
|
|
|
|
lit 100
|
|
|
|
lit 200
|
|
|
|
add
|
|
|
|
ret
|
|
|
|
|
|
|
|
Would look like:
|
|
|
|
|
|
|
|
'liliadre i
|
|
|
|
100 d
|
|
|
|
200 d
|
|
|
|
|
|
|
|
And:
|
|
|
|
|
|
|
|
lit s:eq?
|
|
|
|
call
|
|
|
|
|
|
|
|
Would become:
|
|
|
|
|
|
|
|
'lica.... i
|
|
|
|
's:eq? r
|
|
|
|
|
|
|
|
Note the use of `..` instead of `no` for the nop's; this is
|
|
|
|
done to improve readability a little.
|
|
|
|
|
|
|
|
Instruction bundles are specified as strings, and are converted
|
|
|
|
to actual instructions by the `i` word. As in the standard Muri
|
|
|
|
assembler, the RETRO version uses `d` for decimal values and `r`
|
|
|
|
for references to named functions.
|
|
|
|
|
2017-10-16 18:09:39 +02:00
|
|
|
This is kept in the global namespace, but several portions are
|
|
|
|
kept private.
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
{{
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
I allocate a small buffer for each portion of an instruction
|
|
|
|
bundle.
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2018-08-21 03:24:24 +02:00
|
|
|
'I0 d:create #3 allot
|
|
|
|
'I1 d:create #3 allot
|
|
|
|
'I2 d:create #3 allot
|
|
|
|
'I3 d:create #3 allot
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
The `opcode` word maps a two character instruction to an opcode
|
|
|
|
number.
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2018-08-21 03:24:24 +02:00
|
|
|
:opcode (s-n)
|
|
|
|
'.. [ #0 ] s:case 'li [ #1 ] s:case
|
|
|
|
'du [ #2 ] s:case 'dr [ #3 ] s:case
|
|
|
|
'sw [ #4 ] s:case 'pu [ #5 ] s:case
|
|
|
|
'po [ #6 ] s:case 'ju [ #7 ] s:case
|
|
|
|
'ca [ #8 ] s:case 'cc [ #9 ] s:case
|
|
|
|
're [ #10 ] s:case 'eq [ #11 ] s:case
|
|
|
|
'ne [ #12 ] s:case 'lt [ #13 ] s:case
|
|
|
|
'gt [ #14 ] s:case 'fe [ #15 ] s:case
|
|
|
|
'st [ #16 ] s:case 'ad [ #17 ] s:case
|
|
|
|
'su [ #18 ] s:case 'mu [ #19 ] s:case
|
|
|
|
'di [ #20 ] s:case 'an [ #21 ] s:case
|
|
|
|
'or [ #22 ] s:case 'xo [ #23 ] s:case
|
|
|
|
'sh [ #24 ] s:case 'zr [ #25 ] s:case
|
2018-11-22 01:05:28 +01:00
|
|
|
'en [ #26 ] s:case 'ie [ #27 ] s:case
|
|
|
|
'iq [ #28 ] s:case 'ii [ #29 ] s:case
|
|
|
|
drop #0 ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
I use `pack` to combine the individual parts of the instruction
|
|
|
|
bundle into a single cell.
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2018-08-21 03:24:24 +02:00
|
|
|
:pack (-n)
|
|
|
|
&I0 opcode &I1 opcode
|
|
|
|
&I2 opcode &I3 opcode
|
|
|
|
#-24 shift swap
|
|
|
|
#-16 shift + swap
|
|
|
|
#-8 shift + swap + ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
Switch to the public portion of the code.
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
---reveal---
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
With this it's pretty easy to implement the instruction bundle
|
|
|
|
handler. Named `i`, this takes a string with four instruction
|
|
|
|
names, splits it into each part, calls `opcode` on each and
|
|
|
|
then `pack` to combine them before using `,` to write them into
|
|
|
|
the `Heap`.
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2018-08-21 03:24:24 +02:00
|
|
|
:i (s-)
|
|
|
|
dup &I0 #2 copy #2 +
|
|
|
|
dup &I1 #2 copy #2 +
|
|
|
|
dup &I2 #2 copy #2 +
|
|
|
|
&I3 #2 copy
|
|
|
|
pack , ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
The `d` word inlines a data item.
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2018-08-21 03:24:24 +02:00
|
|
|
:d (n-) , ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
And `r` inlines a reference (pointer).
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2018-08-21 03:24:24 +02:00
|
|
|
:r (s-) d:lookup d:xt fetch , ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
The final bits are `as{` and `}as`, which start and stop the
|
|
|
|
assembler. (Basically, they just turn the `Compiler` on and
|
|
|
|
off, restoring its state as needed).
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2018-08-21 03:24:24 +02:00
|
|
|
:as{ (-f)
|
|
|
|
@Compiler &Compiler v:off ; immediate
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-21 03:24:24 +02:00
|
|
|
:}as (f-?)
|
|
|
|
!Compiler ; immediate
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
This finishes by sealing off the private words.
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
}}
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
## Evaluating Source
|
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
The standard interfaces have their own approaches to getting
|
|
|
|
and dealing with user input. Sometimes though it'd be nicer to
|
|
|
|
have a way of evaluating code from within RETRO itself. This
|
|
|
|
provides an `evaluate` word.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
{{
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
First, create a buffer for the string to be evaluated. This is
|
|
|
|
sized to allow for a standard FORTH block to fit, or to easily
|
|
|
|
fit a traditional 1024 character block. It's also long enough
|
|
|
|
for most source lines I expect to encounter when working with
|
|
|
|
files.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
I allocate this immediately prior to the temporary string
|
|
|
|
buffers.
|
2017-10-23 21:27:14 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-23 21:27:14 +02:00
|
|
|
:current-line (-a) STRINGS #1025 - ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
To make use of this, we need to know how many tokens are in the
|
|
|
|
input string. `count-tokens` takes care of this by filtering
|
|
|
|
out anything other than spaces and getting the size of the
|
|
|
|
remaining string.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:count-tokens (s-n)
|
|
|
|
[ ASCII:SPACE eq? ] s:filter s:length ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
The `next-token` word splits the remainimg string on SPACE and
|
|
|
|
returns both parts.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:next-token (s-ss)
|
|
|
|
ASCII:SPACE s:split ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
And then the `process-tokens` uses `next-token` and `interpret`
|
|
|
|
to go through the string, processing each token in turn. Using
|
|
|
|
the standard `interpret` word allows for proper handling of the
|
|
|
|
prefixes and classes so everything works just as if entered
|
|
|
|
directly.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:process-tokens (sn-)
|
|
|
|
[ next-token swap
|
2018-08-29 17:47:21 +02:00
|
|
|
[ dup s:length n:-zero?
|
|
|
|
&interpret &drop choose ] dip n:inc
|
2017-10-16 18:09:39 +02:00
|
|
|
] times interpret ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
---reveal---
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
And finally, tie it all together into the single exposed word
|
|
|
|
`evaluate`.
|
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
:s:evaluate (s-...)
|
2017-10-23 21:27:14 +02:00
|
|
|
current-line s:copy
|
|
|
|
current-line dup count-tokens process-tokens ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
}}
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
|
2018-02-26 15:47:44 +01:00
|
|
|
## Loops, continued
|
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
Sometimes it's useful to be able to access a loop index. The
|
|
|
|
next word, `times<with-index>` adds this to RETRO. It also
|
|
|
|
provides `I`, `J`, and `K` words to access the index of the
|
|
|
|
current, and up to two outer loops as well.
|
2018-02-26 15:47:44 +01:00
|
|
|
|
|
|
|
~~~
|
|
|
|
{{
|
|
|
|
'LP var
|
|
|
|
'Index d:create #128 allot
|
|
|
|
:next (-) @LP &Index + v:inc ;
|
2018-08-29 17:47:21 +02:00
|
|
|
:prep (-) &LP v:inc #0 @LP &Index + store ;
|
2018-02-26 15:47:44 +01:00
|
|
|
:done (-) &LP v:dec ;
|
|
|
|
---reveal---
|
|
|
|
:I (-n) @LP &Index + fetch ;
|
|
|
|
:J (-n) @LP &Index + n:dec fetch ;
|
|
|
|
:K (-n) @LP &Index + #2 - fetch ;
|
|
|
|
:times<with-index>
|
2018-09-06 17:50:08 +02:00
|
|
|
prep swap
|
|
|
|
[ repeat 0; n:dec push &call sip pop next again ] call
|
|
|
|
drop done ;
|
2018-02-26 15:47:44 +01:00
|
|
|
}}
|
|
|
|
~~~
|
|
|
|
|
2019-01-19 05:49:47 +01:00
|
|
|
## Hooks
|
|
|
|
|
|
|
|
In RETRO 11, nearly all definitions could be temporarily
|
|
|
|
replaced by leaving space at the start for compiling in a
|
|
|
|
jump. In the current RETRO I do not do this, though the
|
|
|
|
technique is still useful, especially with I/O. These next
|
|
|
|
few words provide a means of doing this in RETRO 12.
|
|
|
|
|
|
|
|
To allow a word to be overridden, add a call to `hook` as
|
|
|
|
the first word in the definition. This will compile a jump
|
|
|
|
to the actual definition start.
|
|
|
|
|
|
|
|
~~~
|
|
|
|
:hook (-) #1793 , here n:inc , ; immediate
|
|
|
|
~~~
|
|
|
|
|
|
|
|
`set-hook` takes a pointer to the new word or quote and a
|
|
|
|
pointer to the hook to replace. It alters the jump target.
|
|
|
|
|
|
|
|
~~~
|
|
|
|
:set-hook (aa-) n:inc store ;
|
|
|
|
~~~
|
|
|
|
|
|
|
|
The final word, `unhook`, resets the jump target to the
|
|
|
|
original one.
|
|
|
|
|
|
|
|
~~~
|
|
|
|
:unhook (a-) n:inc dup n:inc swap store ;
|
|
|
|
~~~
|
|
|
|
|
2017-10-16 18:09:39 +02:00
|
|
|
## I/O
|
|
|
|
|
2018-11-23 21:38:46 +01:00
|
|
|
~~~
|
|
|
|
:io:enumerate (-n) as{ 'ie...... i }as ;
|
|
|
|
:io:query (n-mN) as{ 'iq...... i }as ;
|
|
|
|
:io:invoke (n-) as{ 'ii...... i }as ;
|
|
|
|
|
|
|
|
{{
|
|
|
|
'Slot var
|
|
|
|
---reveal---
|
|
|
|
:io:scan-for (n-m)
|
|
|
|
#-1 !Slot
|
|
|
|
io:enumerate [ I io:query nip over eq?
|
|
|
|
[ I !Slot ] if ] times<with-index>
|
|
|
|
drop @Slot ;
|
|
|
|
}}
|
|
|
|
~~~
|
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
A Retro system is only required to provide a single I/O word to
|
|
|
|
the user: a word to push a single character to the output log.
|
2019-02-20 16:29:10 +01:00
|
|
|
This is always mapped to device 0, and is exposed as `c:put`.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2019-01-19 05:49:47 +01:00
|
|
|
:c:put (c-) hook #0 io:invoke ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
This can be used to implement words that push other items to
|
|
|
|
the log.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2019-01-19 05:49:47 +01:00
|
|
|
:nl (-) ASCII:LF c:put ;
|
|
|
|
:sp (-) ASCII:SPACE c:put ;
|
|
|
|
:tab (-) ASCII:HT c:put ;
|
|
|
|
:s:put (s-) &c:put s:for-each ;
|
|
|
|
:n:put (n-) n:to-string s:put ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
An interface layer may provide additional I/O words, but these
|
|
|
|
will not be implemented here as they are not part of the core
|
|
|
|
language.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
|
|
|
## Debugging Aids
|
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
I provide a few debugging aids in the core language. The
|
|
|
|
examples provide much better tools, and interface layers can
|
|
|
|
provide much more than I can do here.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2018-05-07 20:25:49 +02:00
|
|
|
:d:words (-) [ d:name s:put sp ] d:for-each ;
|
2017-10-16 18:09:39 +02:00
|
|
|
:reset (...-) depth repeat 0; push drop pop #1 - again ;
|
2018-05-07 18:24:36 +02:00
|
|
|
:dump-stack (-) depth 0; drop push dump-stack pop dup n:put sp ;
|
2017-10-20 03:10:38 +02:00
|
|
|
~~~
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2018-05-09 14:13:01 +02:00
|
|
|
From Kiyoshi Yoneda, this is a variant of `d:words` which displays
|
|
|
|
words containing a specific substring. It's useful to see words in
|
|
|
|
a specific namespace, e.g., by doing `'s: d:words-with`, or words
|
|
|
|
that likely display something: `':puts d:words-with`.
|
|
|
|
|
2018-05-09 14:15:27 +02:00
|
|
|
~~~
|
2018-05-09 14:13:01 +02:00
|
|
|
{{
|
|
|
|
:display-if-matched (s-)
|
|
|
|
dup here s:contains-string? [ s:put sp ] [ drop ] choose ;
|
|
|
|
---reveal---
|
|
|
|
:d:words-with (s-)
|
|
|
|
here s:copy [ d:name display-if-matched ] d:for-each ;
|
|
|
|
}}
|
2018-05-09 14:15:27 +02:00
|
|
|
~~~
|
2018-05-09 14:13:01 +02:00
|
|
|
|
2017-10-23 21:27:14 +02:00
|
|
|
~~~
|
|
|
|
:FREE (-n) STRINGS #1025 - here - ;
|
|
|
|
~~~
|
|
|
|
|
2017-10-16 18:09:39 +02:00
|
|
|
## The End
|
|
|
|
|
|
|
|
## Legalities
|
|
|
|
|
2018-08-29 17:47:21 +02:00
|
|
|
Permission to use, copy, modify, and/or distribute this
|
|
|
|
software for any purpose with or without fee is hereby
|
|
|
|
granted, provided that the copyright notice and this
|
|
|
|
permission notice appear in all copies.
|
|
|
|
|
|
|
|
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS
|
|
|
|
ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL
|
|
|
|
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO
|
|
|
|
EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,
|
|
|
|
INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER
|
|
|
|
RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
|
|
|
|
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
|
|
|
|
ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
|
|
|
|
OF THIS SOFTWARE.
|
2017-10-16 18:09:39 +02:00
|
|
|
|
2019-01-03 15:13:05 +01:00
|
|
|
Copyright (c) 2008 - 2019, Charles Childers
|
2017-10-16 18:09:39 +02:00
|
|
|
Copyright (c) 2012 - 2013, Michal J Wallace
|
|
|
|
Copyright (c) 2009 - 2011, Luke Parrish
|
|
|
|
Copyright (c) 2009 - 2010, JGL
|
|
|
|
Copyright (c) 2010 - 2011, Marc Simpson
|
|
|
|
Copyright (c) 2011 - 2012, Oleksandr Kozachuk
|
2018-08-29 17:47:21 +02:00
|
|
|
Copyright (c) 2018, Kiyoshi Yoneda
|
2017-10-16 18:09:39 +02:00
|
|
|
Copyright (c) 2010, Jay Skeer
|
|
|
|
Copyright (c) 2010, Greg Copeland
|
|
|
|
Copyright (c) 2011, Aleksej Saushev
|
|
|
|
Copyright (c) 2011, Foucist
|
|
|
|
Copyright (c) 2011, Erturk Kocalar
|
|
|
|
Copyright (c) 2011, Kenneth Keating
|
|
|
|
Copyright (c) 2011, Ashley Feniello
|
|
|
|
Copyright (c) 2011, Peter Salvi
|
|
|
|
Copyright (c) 2011, Christian Kellermann
|
|
|
|
Copyright (c) 2011, Jorge Acereda
|
|
|
|
Copyright (c) 2011, Remy Moueza
|
|
|
|
Copyright (c) 2012, John M Harrison
|
|
|
|
Copyright (c) 2012, Todd Thomas
|