├── .builds ├── debian-arm.yml └── disabled │ ├── alpine.yml │ ├── freebsd.yml │ └── openbsd.yml ├── .gitattributes ├── .gitignore ├── BUILDING.md ├── CURRENT.txt ├── Configuration.mk ├── GNUmakefile ├── KNOWN-ISSUES.txt ├── LICENSE ├── Makefile ├── README.md ├── RELEASE-NOTES ├── benchmarks ├── choose.retro ├── nga-c.sh ├── nga-python.sh ├── push-drop.retro └── times.retro ├── doc ├── Architecture.md ├── Book-Cover.png ├── Contributing.md ├── Cross-Reference.md ├── DEVICES.txt ├── Examples.md ├── Glossary-Concise.txt ├── Glossary-Names-and-Stack.txt ├── Glossary.html ├── Glossary.txt ├── Hyperstatic.md ├── Interpreter.md ├── Muri.md ├── Namespaces.md ├── NamingConventions.md ├── Nga.md ├── Python-VM.md ├── QuickRef.md ├── QuotesAndCombinators.md ├── REPORT-BUGS.md ├── RETRO-Book.md ├── SqrtEncoding.pdf ├── StackComments.md ├── Unu.md ├── book │ ├── building │ │ ├── advanced │ │ ├── alternatives │ │ ├── obtaining │ │ ├── unix │ │ └── windows │ ├── general │ │ ├── basic-interactions │ │ ├── copyrights │ │ ├── deprecation │ │ ├── introduction │ │ ├── markdown │ │ ├── quick-tutorial │ │ ├── retro-unu │ │ ├── starting │ │ └── syntax │ ├── glossary │ │ ├── glossary │ │ └── using │ ├── gophermap │ ├── internals │ │ ├── calling-retro-from-c │ │ ├── image │ │ ├── interface-layers │ │ ├── io │ │ ├── io-devices │ │ └── nga │ ├── tech-notes │ │ ├── code-it-yourself │ │ ├── historical-papers │ │ ├── kernel-words │ │ ├── metacompilation │ │ ├── ngaro-to-nga │ │ ├── prefixes │ │ ├── retro11-retrospective │ │ ├── security │ │ ├── self-hosting │ │ └── underscores-in-names │ ├── techniques │ │ ├── arrays │ │ ├── assembly │ │ ├── buffer │ │ ├── characters │ │ ├── checking-the-version │ │ ├── definitions │ │ ├── dictionary │ │ ├── errors │ │ ├── files │ │ ├── floating-point │ │ ├── lexical-scope │ │ ├── loops │ │ ├── multicore │ │ ├── naming-conventions │ │ ├── numbers │ │ ├── pointers │ │ ├── quotes │ │ ├── return-stack │ │ ├── scripting │ │ ├── sockets │ │ ├── stack-diagrams │ │ ├── strings │ │ ├── the-stacks │ │ ├── using-combinators │ │ └── word-classes │ └── toolchain │ │ ├── info │ │ ├── additional-tools │ │ ├── retro-compiler │ │ └── retro-unu │ │ └── man │ │ ├── retro │ │ ├── retro-describe │ │ ├── retro-document │ │ ├── retro-embedimage │ │ ├── retro-extend │ │ ├── retro-locate │ │ ├── retro-muri │ │ ├── retro-tags │ │ └── retro-unu ├── decimal-glossary.txt ├── html │ ├── chapters │ │ ├── building │ │ │ ├── advanced.html │ │ │ ├── alternatives.html │ │ │ ├── obtaining.html │ │ │ ├── unix.html │ │ │ └── windows.html │ │ ├── general │ │ │ ├── basic-interactions.html │ │ │ ├── copyrights.html │ │ │ ├── deprecation.html │ │ │ ├── introduction.html │ │ │ ├── markdown.html │ │ │ ├── quick-tutorial.html │ │ │ ├── retro-unu.html │ │ │ ├── starting.html │ │ │ └── syntax.html │ │ ├── internals │ │ │ ├── calling-retro-from-c.html │ │ │ ├── image.html │ │ │ ├── interface-layers.html │ │ │ ├── io-devices.html │ │ │ ├── io.html │ │ │ └── nga.html │ │ ├── tech-notes │ │ │ ├── code-it-yourself.html │ │ │ ├── historical-papers.html │ │ │ ├── kernel-words.html │ │ │ ├── metacompilation.html │ │ │ ├── ngaro-to-nga.html │ │ │ ├── prefixes.html │ │ │ ├── retro11-retrospective.html │ │ │ ├── security.html │ │ │ ├── self-hosting.html │ │ │ └── underscores-in-names.html │ │ ├── techniques │ │ │ ├── arrays.html │ │ │ ├── assembly.html │ │ │ ├── buffer.html │ │ │ ├── characters.html │ │ │ ├── checking-the-version.html │ │ │ ├── definitions.html │ │ │ ├── dictionary.html │ │ │ ├── errors.html │ │ │ ├── files.html │ │ │ ├── floating-point.html │ │ │ ├── lexical-scope.html │ │ │ ├── loops.html │ │ │ ├── multicore.html │ │ │ ├── naming-conventions.html │ │ │ ├── numbers.html │ │ │ ├── pointers.html │ │ │ ├── quotes.html │ │ │ ├── return-stack.html │ │ │ ├── scripting.html │ │ │ ├── sockets.html │ │ │ ├── stack-diagrams.html │ │ │ ├── strings.html │ │ │ ├── the-stacks.html │ │ │ ├── using-combinators.html │ │ │ └── word-classes.html │ │ └── toolchain │ │ │ ├── info │ │ │ ├── additional-tools.html │ │ │ └── retro-compiler.html │ │ │ └── man │ │ │ ├── retro-describe.html │ │ │ ├── retro-document.html │ │ │ ├── retro-embedimage.html │ │ │ ├── retro-extend.html │ │ │ ├── retro-locate.html │ │ │ ├── retro-muri.html │ │ │ ├── retro-tags.html │ │ │ └── retro.html │ └── index.html └── words.tsv ├── example ├── 1D-Cellular-Automota.retro ├── 7080.retro ├── 99-bottles.retro ├── Atua-WWW.retro ├── Atua.retro ├── Casket-HTTP.retro ├── EDA.retro ├── HTML.retro ├── VT100.retro ├── accumulator.retro ├── adding-vectors.retro ├── advent-of-code-2020-day-1.retro ├── advent-of-code-2020-day-2.retro ├── advent-of-code-2020-day-3.retro ├── advent-of-code-2020-day-4.retro ├── advent-of-code-2020-day-5.retro ├── advent-of-code-2021-day-1.retro ├── advent-of-code-2021-day-2.retro ├── alternate-listener.retro ├── amalgamate-python.retro ├── amalgamate.retro ├── ans-pick-roll.retro ├── archive-extract.retro ├── archive-info.retro ├── archive.retro ├── assertions.retro ├── atua-gemini.retro ├── atua-gophermap.retro ├── autopsy.retro ├── block-editor.retro ├── buffer.retro ├── bury.retro ├── byte-addressing.retro ├── c-style-comments.retro ├── calling-retro-from-c.c ├── capture-output.retro ├── cat.retro ├── chess.retro ├── close-paren.retro ├── colored-dwords.retro ├── compat.retro ├── conways-life.retro ├── curl.retro ├── defstruct.retro ├── delete-file.retro ├── detect-devices.retro ├── dictionary-alias.retro ├── dictionary-stats.retro ├── dictionary-used-in.retro ├── display-names.retro ├── display-word-location-information.retro ├── double.retro ├── echo.retro ├── edit.retro ├── enum.retro ├── evaluate-string.retro ├── export-as-html.retro ├── export-muri-as-html.retro ├── file.retro ├── float-var.retro ├── floating-point-encoding.retro ├── forget.retro ├── forth-style-comments.retro ├── fsl │ ├── README.txt │ ├── cube-rt.forth │ ├── elip.forth │ ├── expint.forth │ └── logistic.forth ├── gcd.retro ├── gopher.retro ├── gott.retro ├── hanoi.retro ├── hiding-words.retro ├── http-get.retro ├── http-post.retro ├── iOS │ ├── GopherClient.forth │ └── README.md ├── ilo-export.retro ├── ilo.retro ├── irc-bot.retro ├── irc-logger.retro ├── is-palindrome.retro ├── is-pangram.retro ├── iterative-fibonacci.retro ├── json.retro ├── key-value-store.retro ├── konilo-wiki.retro ├── least-common-multiple.retro ├── light-weight-flow-control.retro ├── linked-list.retro ├── local-variables.retro ├── magic-8th-ball.retro ├── mail.retro ├── mandelbrot.retro ├── markdown-to-xhtml.retro ├── markdown.retro ├── marker.retro ├── matrix.retro ├── minimize.retro ├── morse.retro ├── muri-with-hex.retro ├── namespaces.retro ├── naming-quotes.retro ├── net-fetch.retro ├── numbers-without-prefix.retro ├── numeric-ranges.retro ├── pali-to-html.retro ├── palindromic-numbers.retro ├── parse-ups.retro ├── paste-to-sprunge.retro ├── paste.retro ├── primes.retro ├── publish-examples.retro ├── quad.retro ├── queue.retro ├── recursive-factorial.retro ├── recursive-fibonacci.retro ├── reforth.retro ├── retro-edit.retro ├── retro-embedimage.retro ├── retro-extend.retro ├── retro-generate-image-js.retro ├── retro-locate.retro ├── retro-muri.retro ├── retro-stats.retro ├── retro-tags.retro ├── retro-unu.retro ├── retro.blocks.gz ├── retro.retro ├── rfc865.retro ├── rfc867.retro ├── rilo-editor.retro ├── rng.retro ├── roo.retro ├── rot13.retro ├── safety-net.retro ├── sandboxed-dictionary.retro ├── save-and-restore-stack.retro ├── sea-level-rise.retro ├── select.retro ├── share.retro ├── shared.retro ├── shell.retro ├── socket-client.retro ├── socket-server.retro ├── sort-on-stack.retro ├── sqlite3 │ ├── sql.forth │ ├── test.db │ └── test.forth ├── string-to-number-with-base.retro ├── strip-html.retro ├── tokenize-string.retro ├── toki-pona-translate.retro ├── top-of-address-stack.retro ├── trail.retro ├── tuporo.retro ├── ulz.retro ├── unicode.retro ├── unix-does-user-exist.retro ├── unsigned.retro ├── uudecode.retro ├── uuencode.retro ├── variables-and-formulas.retro ├── vocabulary.retro ├── words-four-column.retro └── wordwrap.retro ├── future └── utf8.retro ├── image ├── build.retro ├── retro.forth └── retro.muri ├── interface ├── block.retro ├── clock.retro ├── dedup.retro ├── deprecated.retro ├── descriptions.retro ├── devices.retro ├── error.retro ├── ffi.retro ├── filesystem.retro ├── final.retro ├── floatingpoint.retro ├── future.retro ├── gopher.retro ├── ioctl.retro ├── library.retro ├── ll.retro ├── multicore.retro ├── new-strings.retro ├── retro-unix.retro ├── rng.retro ├── scripting.retro ├── sockets.retro ├── sources.retro ├── stack-comments.retro ├── unix.retro └── unsigned.retro ├── library ├── block-editor.retro ├── c-get-ext.retro ├── konilo.retro ├── openbsd.retro ├── py-decimal.retro ├── pythonista-ui.retro ├── termina.retro ├── tob.retro └── x11.retro ├── man ├── retro-compiler.1 ├── retro-describe.1 ├── retro-document.1 ├── retro-embedimage.1 ├── retro-extend.1 ├── retro-locate.1 ├── retro-muri.1 ├── retro-tags.1 ├── retro-unu.1 └── retro.1 ├── ngaImage ├── old ├── Makefile.python └── rel │ └── python │ ├── LICENSE │ ├── README │ ├── retroforth │ ├── __init__.py │ └── retroforth.py │ └── setup.py ├── package ├── dict-words-listing.forth ├── extensions │ ├── README.retro │ ├── double.retro │ └── malloc.retro ├── list.forth ├── load-extensions.retro └── unsupported │ ├── allow-underscores-in-names.forth │ ├── compat-2020.10.retro │ └── compat.forth ├── retroforth.el ├── security ├── 2024-01.pub ├── 2024-02.pub ├── 2024-03.pub ├── 2024-04.pub ├── 2024-05.pub ├── 2024-06.pub ├── 2024-07.pub ├── 2024-08.pub ├── 2024-09.pub ├── 2024-10.pub ├── 2024-11.pub ├── 2024-12.pub └── README ├── takawiri.retro ├── tests ├── Instructions.md ├── ad.muri ├── an.muri ├── ca.muri ├── cc.muri ├── di.muri ├── dr.muri ├── du.muri ├── eq.muri ├── fe.muri ├── gt.muri ├── ha.muri ├── instructions.sh ├── ju.muri ├── li.muri ├── lt.muri ├── malloc.retro ├── mu.muri ├── ne.muri ├── no.muri ├── or.muri ├── po.muri ├── pu.muri ├── re.muri ├── rx.retro ├── sh.muri ├── st.muri ├── su.muri ├── sw.muri ├── test-core.forth ├── xo.muri └── zr.muri ├── tools ├── amalgamate-python.retro ├── amalgamate.retro ├── book-chapters.retro ├── book-check-spelling.retro ├── epub │ └── chapters-to-xhtml.retro ├── find-deprecated.retro ├── generate-devices.retro ├── generate-epub.retro ├── generate-extensions-list.retro ├── generate-html-docs.retro ├── glossary.retro ├── make-book.retro ├── missing-dsource.retro ├── rename-forth-to-retro.sh ├── retro-describe.retro ├── retro-document.sh ├── retro-embedimage.c ├── retro-embedimage.py ├── retro-extend.c ├── retro-extend.py ├── retro-muri.c ├── retro-muri.py ├── retro-unu.c ├── retro-unu.py ├── strl.h └── update-build.retro └── vm ├── libnga-zig ├── LICENSE ├── LICENSE-RETRO ├── build.zig ├── readme.md └── src │ ├── image.c │ └── retro.zig ├── nga-816 ├── LICENSE ├── README.md ├── barebones-2021-02-28.png ├── barebones.asm ├── barebones.hex ├── barebones.image ├── barebones.lst ├── build.sh └── macros_inc.asm ├── nga-c-native-x86 ├── 386.ld ├── 386.s ├── 386flat.ld ├── Makefile ├── README.md ├── bin │ └── .keep ├── image.c ├── retro.c └── x86 │ ├── Block-Editor.retro │ ├── ata.retro │ ├── cmos-rtc.retro │ ├── common.retro │ ├── display.retro │ ├── keyboard.retro │ ├── listener.retro │ └── serial.retro ├── nga-c-no-libc ├── Makefile ├── README ├── bsd-amd64.s ├── bsd-i386.s ├── image.c ├── linux.s ├── macos.s └── retro.c ├── nga-c ├── config.h ├── dev-blocks.c ├── dev-clock.c ├── dev-error.c ├── dev-ffi.c ├── dev-files.c ├── dev-float.c ├── dev-ioctl.c ├── dev-malloc.c ├── dev-multicore.c ├── dev-rng.c ├── dev-sockets.c ├── dev-unix.c ├── devices.h ├── image.c ├── nga-x11.c ├── repl.c ├── retro-compiler.c ├── retro-runtime.c ├── retro.c ├── retro.fnt └── utf32.c ├── nga-csharp └── retro.cs ├── nga-cxx └── nga-arland.cxx ├── nga-d └── nga.d ├── nga-js ├── image.js ├── index.html ├── nga.js └── style.css ├── nga-nim └── retro.nim ├── nga-pascal ├── bridge.pas ├── listener.lpr ├── nga.inc └── nga.pas ├── nga-python ├── BenchmarkDevice.py ├── ClockDevice.py ├── DecimalDevice.py ├── FileSystemDevice.py ├── FloatStack.py ├── InitialImage.py ├── IntegerStack.py ├── Memory.py ├── RNGDevice.py ├── UIDevice.py └── retro.py ├── nga-rust └── nga.rs └── nga-swift └── nga.swift /.builds/debian-arm.yml: -------------------------------------------------------------------------------- 1 | image: debian/unstable 2 | arch: amd64 3 | packages: 4 | - curl 5 | sources: 6 | - https://git.sr.ht/~crc_/retroforth 7 | tasks: 8 | - build: | 9 | cd retroforth 10 | make 11 | - repl: | 12 | cd retroforth 13 | make bin/retro-repl 14 | #- compiler: | 15 | # cd retroforth 16 | # make bin/retro-compiler 17 | - install: | 18 | cd retroforth 19 | sudo make install 20 | - test: | 21 | cd retroforth 22 | retro example/1D-Cellular-Automota.retro 23 | retro example/sea-level-rise.retro 24 | #- test-compiler: | 25 | # cd retroforth 26 | # curl http://forth.works/share/17af8e4329d13fea01e7afcdf3c9aefd -o hello.retro 27 | # ./bin/retro-compiler hello.retro hello 28 | # ./a.out 29 | - check-missing: | 30 | cd retroforth 31 | retro tools/glossary.retro missing 32 | -------------------------------------------------------------------------------- /.builds/disabled/alpine.yml: -------------------------------------------------------------------------------- 1 | image: alpine/edge 2 | sources: 3 | - https://git.sr.ht/~crc_/retroforth 4 | tasks: 5 | - build: | 6 | cd retroforth 7 | make OPTIONS=-DBIT64 8 | - test: | 9 | cd retroforth 10 | ./bin/retro example/1D-Cellular-Automota.retro 11 | -------------------------------------------------------------------------------- /.builds/disabled/freebsd.yml: -------------------------------------------------------------------------------- 1 | image: freebsd/latest 2 | sources: 3 | - https://git.sr.ht/~crc_/retroforth 4 | tasks: 5 | - build: | 6 | cd retroforth 7 | make 8 | - test: | 9 | cd retroforth 10 | ./bin/retro example/1D-Cellular-Automota.retro 11 | -------------------------------------------------------------------------------- /.builds/disabled/openbsd.yml: -------------------------------------------------------------------------------- 1 | image: openbsd/latest 2 | sources: 3 | - https://git.sr.ht/~crc_/retroforth 4 | tasks: 5 | - build: | 6 | cd retroforth 7 | make 8 | - test: | 9 | cd retroforth 10 | ./bin/retro example/1D-Cellular-Automota.retro 11 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | *.retro linguist-language=Forth 2 | *.muri linguist-language=Assembly 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | bin/ 2 | -------------------------------------------------------------------------------- /BUILDING.md: -------------------------------------------------------------------------------- 1 | # Building RetroForth 2 | 3 | This is a quick overview of how to build Retro on a BSD, Linux, 4 | or macOS system. It assumes you already have the requirements 5 | (c compiler, make) setup in your command line environment. 6 | 7 | ## Standard Builds 8 | 9 | A standard build should just require running `make`: 10 | 11 | make 12 | 13 | This will build the toolchain and a binary runtime for retro. 14 | These will be placed in the `bin` directory. 15 | 16 | ## Customized Builds 17 | 18 | The basic system provides most of the functionality, but you 19 | can enable or disable specific elements by editing either 20 | the Makefile (on BSD) or GNUmakefile (or Linux or macOS). 21 | 22 | Find the fourth section in the Makefile and either uncomment 23 | or comment the ENABLED and DEVICES lines for the optional parts 24 | you want to include in your build. 25 | 26 | Most functionality is enabled by default. Optional things you 27 | may wish to enable include sockets, ffi, and multicore. 28 | 29 | ## More Complex Customizations 30 | 31 | There are additional things you can update. Take a look in the 32 | manual for more details on this. 33 | -------------------------------------------------------------------------------- /CURRENT.txt: -------------------------------------------------------------------------------- 1 | Currently Active: 2 | 3 | - Adding missing source data for existing vocabularies 4 | - Improving the D implementation of Nga 5 | -------------------------------------------------------------------------------- /KNOWN-ISSUES.txt: -------------------------------------------------------------------------------- 1 | ==[ Known Issues ]============================================== 2 | 3 | - under tests/* : the instruction tests are not working 4 | currently. (rep: sevan, confirm) 5 | - there appears to be corruption in the source data; 6 | perhaps a bug in s:dedup ? 7 | 8 | -------------------------------------------------------------------------------- /benchmarks/choose.retro: -------------------------------------------------------------------------------- 1 | ~~~ 2 | '1,000,000_iterations_of_choose s:put nl 3 | #1000 [ #500 [ FALSE [ ] [ ] choose ] times ] times 4 | #1000 [ #500 [ TRUE [ ] [ ] choose ] times ] times 5 | ~~~ 6 | 7 | -------------------------------------------------------------------------------- /benchmarks/nga-c.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | time retro times.retro 4 | time retro push-drop.retro 5 | time retro choose.retro 6 | -------------------------------------------------------------------------------- /benchmarks/nga-python.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | cd .. 4 | retro tools/amalgamate-python.retro >benchmarks/retro.py 5 | cd benchmarks 6 | cp ../ngaImage . 7 | 8 | echo Python3 9 | time python3 retro.py times.retro 10 | time python3 retro.py push-drop.retro 11 | time python3 retro.py choose.retro 12 | 13 | echo PyPy 14 | time pypy retro.py times.retro 15 | time pypy retro.py push-drop.retro 16 | time pypy retro.py choose.retro 17 | 18 | rm -f retro.py ngaImage 19 | -------------------------------------------------------------------------------- /benchmarks/push-drop.retro: -------------------------------------------------------------------------------- 1 | ~~~ 2 | 'Push_and_discard_a_value_1,000,000_times s:put nl 3 | #1000 [ #1000 [ #1 drop ] times ] times 4 | ~~~ 5 | 6 | -------------------------------------------------------------------------------- /benchmarks/times.retro: -------------------------------------------------------------------------------- 1 | ~~~ 2 | '1,000,000_iterations_of_empty_loops s:put nl 3 | #100 [ #100 [ #100 [ ] times ] times ] times 4 | ~~~ 5 | 6 | -------------------------------------------------------------------------------- /doc/Architecture.md: -------------------------------------------------------------------------------- 1 | # Architecture 2 | 3 | RETRO has a multilayer design. 4 | 5 | At the heart of the system is a virtual machine called Nga. This emulates 6 | a 32-bit stack processor with a MISC based instruction set. 7 | 8 | The core RETRO language is stored as a memory image for Nga. The *image 9 | file* contains this and is loaded on startup. It holds all of the compiled 10 | words and data and interacts with Nga. 11 | 12 | The third layer is the user interface. RETRO doesn't specify any required 13 | I/O other than a console log capable of receiving a single character at a 14 | time. Each host system can implement this and any additional desired I/O 15 | by extending Nga. 16 | 17 | # Specifics 18 | 19 | On iOS the user interface is setup around an editor and an output area. 20 | The editor extracts code from fenced regions, splits it into tokens 21 | (elements separated by whitespace) and passes each of these into RETRO 22 | for processing. After the tokens are processed, the console is updated. 23 | 24 | The iOS code provides additional I/O functionality. In the `file:` 25 | namespace there are words for creating and using files. There's a 26 | `pb:` vocabulary for interacting with the clipboard. And a `clock:` 27 | namespace which provides access to the system time and date. These 28 | are mapped to higher opcodes outside of the core set used by Nga. 29 | -------------------------------------------------------------------------------- /doc/Book-Cover.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/crcx/retroforth/9a940927934389760261b0d9ebff16765443b3c0/doc/Book-Cover.png -------------------------------------------------------------------------------- /doc/Hyperstatic.md: -------------------------------------------------------------------------------- 1 | # Hyperstatic Global Environment 2 | 3 | This now brings up an interesting subpoint. Retro provides a *hyper- 4 | static global environment.* This can be difficult to explain, so let's 5 | take a quick look at how it works: 6 | 7 | ~~~ 8 | #1000 'a var-n 9 | :scale (x-y) @a * ; 10 | #3 scale n:put 11 | >>> 3000 12 | #100 !a 13 | #3 scale n:put 14 | >>> 300 15 | #5 'a var-n 16 | #3 scale n:put 17 | >>> 300 18 | @a n:put 19 | >>> 5 20 | ~~~ 21 | 22 | Output is marked with **\>\>\>**. 23 | 24 | Note that we create two variables with the same name (*a*). The definition 25 | for `scale` still refers to the old variable, even though we can no longer 26 | directly manipulate it. 27 | 28 | In a hyper-static global environment, functions continue to refer to the 29 | variables and earlier functions that existed when they were defined. If 30 | you create a new variable or function with the same name as an existing 31 | one, it only affects future code. 32 | -------------------------------------------------------------------------------- /doc/Namespaces.md: -------------------------------------------------------------------------------- 1 | # Namespaces 2 | 3 | Retro organizes words into *namespaces*. These are short prefix 4 | strings at the start of a word name. 5 | 6 | | Prefix | Contains | 7 | | ------- | ------------------------------------------------------ | 8 | | ASCII: | ASCII character constants for control characters | 9 | | buffer: | Words for operating on a simple linear LIFO buffer | 10 | | c: | Words for operating on ASCII character data | 11 | | class: | Contains class handlers for words | 12 | | d: | Words operating on the Dictionary | 13 | | err: | Words for handling errors | 14 | | n: | Words operating on numeric data | 15 | | prefix: | Contains prefix handlers | 16 | | s: | Words operating on string data | 17 | | set: | Words operating on sets (simple arrays) | 18 | | v: | Words operating on variables | 19 | | file: | File I/O words | 20 | | f: | Floating Point words | 21 | | gopher: | Gopher protocol words | 22 | | unix: | Unix system call words | 23 | 24 | -------------------------------------------------------------------------------- /doc/NamingConventions.md: -------------------------------------------------------------------------------- 1 | # Naming Conventions 2 | 3 | I use the following general conventions when naming words in RETRO. 4 | 5 | # All 6 | 7 | - Word names must **not** start with a prefix character 8 | - Keep names short, but descriptive 9 | - Spelling out is preferred over symbols 10 | 11 | # Variables 12 | 13 | These use TitleCase. 14 | 15 | Base 16 | Compiler 17 | Dictionary 18 | 19 | # Constants 20 | 21 | These are UPPERCASE, with a dash separating compound names. 22 | 23 | MAX-STRINGS 24 | NORTH 25 | 26 | # Words 27 | 28 | Most named items are words. As such, most of the conventions are under 29 | this category. 30 | 31 | Word names are lowercase, with a dash between compound names. 32 | 33 | drop 34 | drop-pair 35 | 36 | Use a namespace prefix to group related words. This is a short string, 37 | separated from the rest of the name by a colon. See Namespaces.md for a 38 | list of the major namespaces in RETRO. 39 | 40 | d:for-each 41 | s:to-upper 42 | s:length 43 | c:vowel? 44 | n:negate 45 | 46 | Words returning a flag should end in ? 47 | 48 | n:even? 49 | n:positive? 50 | c:vowel? 51 | 52 | The use of a leading dash implies *not*: 53 | 54 | if 55 | -if 56 | c:vowel? 57 | c:-vowel? 58 | 59 | When introducing words, consider including a *not* form if it makes sense. 60 | -------------------------------------------------------------------------------- /doc/REPORT-BUGS.md: -------------------------------------------------------------------------------- 1 | # Reporting Bugs 2 | 3 | Bugs can be reported via the IRC channel, by sending me a 4 | message on Mastodon, or via email. 5 | 6 | **IRC** 7 | 8 | Join #retro on irc.libera.chat or irc.oftc.net. 9 | 10 | If you ask a question, please be patient. The channel has large 11 | idle times, but is logged (see forthworks.com/retro/irc-logs) 12 | and I generally try to answer questions in a reasonable time 13 | period. 14 | 15 | **Mastodon** 16 | 17 | @crc@mastodon.social 18 | 19 | **email** 20 | 21 | crc@forthworks.com 22 | -------------------------------------------------------------------------------- /doc/SqrtEncoding.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/crcx/retroforth/9a940927934389760261b0d9ebff16765443b3c0/doc/SqrtEncoding.pdf -------------------------------------------------------------------------------- /doc/StackComments.md: -------------------------------------------------------------------------------- 1 | Most words in RETRO have a stack comment. These look like: 2 | 3 | (-) 4 | (nn-n) 5 | 6 | As with all comments, a stack comment begins with ( and should end with 7 | a ). There are two parts to the comment. On the left side of the - is 8 | what the word *consumes*. On the right is what it *leaves*. 9 | 10 | RETRO uses a short notation, with one character per value taken or left. 11 | In general, the following symbols represent certain types of values. 12 | 13 | b, n, m, o, x, y, z are generic numeric values 14 | s represents a string 15 | v represents a variable 16 | p, a represent pointers 17 | q represents a quotation 18 | d represents a dictionary header 19 | f represents a `TRUE` or `FALSE` flag. 20 | 21 | In the case of something like: (xyz-m) 22 | RETRO expects z to be on the top of the stack, with y below it and x below 23 | the y value. And after execution, a single value (m) will be left on the 24 | stack. 25 | 26 | Words with no stack effect have a comment of (-) 27 | -------------------------------------------------------------------------------- /doc/book/building/unix: -------------------------------------------------------------------------------- 1 | # Building on BSD, Linux, macOS, and other Unix Targets 2 | 3 | Retro is well supported on BSD (tested on FreeBSD, NetBSD, 4 | OpenBSD), Linux, and macOS systems. It should build on any 5 | of these without issue. 6 | 7 | ## Requirements 8 | 9 | - c compiler & linker 10 | - standard headers 11 | - make 12 | 13 | ## Process 14 | 15 | For a standard 32-bit system: 16 | 17 | Run `make` 18 | 19 | This will build the toolchain and then the main `retro` 20 | executable. 21 | 22 | ## Executables 23 | 24 | In the `bin/` directory, you should see the following: 25 | 26 | retro 27 | retro-unu 28 | retro-muri 29 | retro-extend 30 | retro-embedimage 31 | retro-describe 32 | 33 | ## Test The Build 34 | 35 | You can conduct a quick test of the build by running `bin/retro`: 36 | 37 | ./bin/retro 38 | 39 | Exit by typing `bye` and pressing enter. 40 | 41 | ## Installation 42 | 43 | You can install Retro globally on BSD systems (and possibly Linux) 44 | by doing: 45 | 46 | doas make install 47 | 48 | or: 49 | 50 | sudo make install 51 | 52 | ## Platform Specific Notes 53 | 54 | ### Linux 55 | 56 | To build on Linux, you need to link with *libdl* if using the optional 57 | FFI. To do this, edit the `GNUmakefile` and uncomment this before building: 58 | 59 | # LIBDL += -ldl 60 | 61 | ### Haiku 62 | 63 | To build on Haiku, you need to link with the *network* library if using 64 | sockets. E.g.: 65 | 66 | make LDFLAGS=-lnetwork 67 | 68 | ## Issues 69 | 70 | If you run into any build issues, please send details to 71 | crc@forth.works so I can work on addressing them as quickly 72 | as possible. 73 | -------------------------------------------------------------------------------- /doc/book/building/windows: -------------------------------------------------------------------------------- 1 | # Building Retro on Windows 2 | 3 | It is possible to build Retro on Windows, though a few of the 4 | extensions are not supported: 5 | 6 | - no `unix:` words 7 | - no `gopher:` words 8 | 9 | This is currently more difficult than on a Unix host. If you have 10 | Windows 10 and WSL, it may be better to build under that (using 11 | the Unix instructions). 12 | 13 | ## Setup Build Environment 14 | 15 | Retro on Windows is built with TCC. 16 | 17 | Go to http://download.savannah.gnu.org/releases/tinycc/ 18 | 19 | Download the *winapi-full* and *tcc-xxxx-bin* packages for your 20 | system. Decompress them, copy the headers from the winapi 21 | package into the tcc directory. 22 | 23 | ## Prepare Source 24 | 25 | Copy the `vm/nga-c/retro.c` and the `vm/nga-c/image.c` to 26 | the directory you setup tcc into. 27 | 28 | ## Build 29 | 30 | Building will require use of the command line. Assuming that 31 | tcc.exe is in the current directory along with the Retro sources: 32 | 33 | tcc retro.c -o retro.exe 34 | -------------------------------------------------------------------------------- /doc/book/general/basic-interactions: -------------------------------------------------------------------------------- 1 | # Basic Interactions 2 | 3 | Start Retro in interactive mode: 4 | 5 | ``` 6 | retro -i 7 | ``` 8 | 9 | You should see something similar to this: 10 | 11 | Retro 12 (2021.7) 12 | 8388608 MAX, TIB @ 1025, Heap @ 9374 13 | 14 | At this point you are at the *listener*, which reads and 15 | processes your input. You are now set to begin exploring 16 | Retro. 17 | 18 | Retro is normally silent; unlike other Forth systems, it 19 | does not display an "ok" prompt. 20 | 21 | To exit, run `bye`: 22 | 23 | ``` 24 | bye 25 | ``` 26 | 27 | -------------------------------------------------------------------------------- /doc/book/general/deprecation: -------------------------------------------------------------------------------- 1 | # Deprecation Policy 2 | 3 | As Retro evolves, some words will become obsolete and no longer be 4 | needed. In each release, these will be marked as deprecated in the 5 | glossary. Any deprecated words will be removed in the next quarterly 6 | release. 7 | 8 | E.g., if 2020.1 had deprecated words, these would be removed in the 9 | 2020.4 release. Any words made deprecated in between 2020.1 and 10 | 2020.4 would be removed in the 2020.7 release. 11 | -------------------------------------------------------------------------------- /doc/book/general/introduction: -------------------------------------------------------------------------------- 1 | # Retro: a Modern, Pragmatic Forth 2 | 3 | Welcome to Retro, my personal take on the Forth language. This 4 | is a modern system primarily targeting desktop, mobile, and 5 | servers, though it can also be used on some larger (ARM, MIPS32) 6 | embedded systems. 7 | 8 | The language is Forth. It is untyped, uses a stack to pass data 9 | between functions called words, and a dictionary which tracks 10 | the word names and data structures. 11 | 12 | But it's not a traditional Forth. Retro draws influences from 13 | many sources and takes a unique approach to the language. 14 | 15 | Retro has a large vocabulary of words. Keeping a copy of the 16 | Glossary on hand is highly recommended as you learn to use Retro. 17 | 18 | This book will hopefully help you develop a better understanding 19 | of Retro and how it works. 20 | -------------------------------------------------------------------------------- /doc/book/general/quick-tutorial: -------------------------------------------------------------------------------- 1 | # A Quick Tutorial 2 | 3 | Programming in Retro is all about creating words to solve 4 | the problem at hand. Words operate on data, which can be 5 | kept in memory or on the stack. 6 | 7 | Let's look at this by solving a small problem: writing a 8 | word to determine if a string is a palindrome. 9 | 10 | A palindrome is a phrase which reads the same backward 11 | and forward. 12 | 13 | We first need a string to look at. Starting with something 14 | easy: 15 | 16 | ``` 17 | 'anna 18 | ``` 19 | 20 | Looking in the Glossary, there is a `s:reverse` word for 21 | reversing a string. We can find `dup` to copy a value, and 22 | `s:eq?` to compare two strings. So testing: 23 | 24 | ``` 25 | 'anna dup s:reverse s:eq? 26 | ``` 27 | 28 | This yields -1 (`TRUE`) as expected. So we can easily 29 | name it: 30 | 31 | ``` 32 | :palindrome? dup s:reverse s:eq? ; 33 | ``` 34 | 35 | Naming uses the `:` sigil to add a new word to the dictionary. 36 | The words that make up the definition are then placed, with a 37 | final word (`;`) ending the definition. We can then use this: 38 | 39 | ``` 40 | 'anna palindrome? 41 | ``` 42 | 43 | Once defined there is no difference between our new word and 44 | any of the words already provided by the Retro system. 45 | -------------------------------------------------------------------------------- /doc/book/general/retro-unu: -------------------------------------------------------------------------------- 1 | # Unu: Simple, Literate Source Files 2 | 3 | Retro is written in a literate style. Most of the sources 4 | are in a format called Unu. This allows easy mixing of 5 | commentary and code blocks, making it simple to document 6 | the code. 7 | 8 | As an example, 9 | 10 | # Determine The Average Word Name Length 11 | 12 | To determine the average length of a word name two values 13 | are needed. First, the total length of all names in the 14 | Dictionary: 15 | 16 | ~~~ 17 | #0 [ d:name s:length + ] d:for-each 18 | ~~~ 19 | 20 | And then the number of words in the Dictionary: 21 | 22 | ~~~ 23 | #0 [ drop n:inc ] d:for-each 24 | ~~~ 25 | 26 | With these, a simple division is all that's left. 27 | 28 | ~~~ 29 | / 30 | ~~~ 31 | 32 | Finally, display the results: 33 | 34 | 35 | ~~~ 36 | 'Average_name_length:_%n\n s:format s:put 37 | ~~~ 38 | 39 | This illustrates the format. Only code in the fenced blocks 40 | (between \~~~ pairs) get extracted and run. 41 | 42 | (Note: this only applies to source files; fences are not used 43 | when entering code interactively). 44 | 45 | ## On The Name 46 | 47 | The name Unu comes from the Maori language, where it means: 48 | 49 | (verb) (-hia) pull out, withdraw, draw out, extract. 50 | Taken from https://maoridictionary.co.nz/ 51 | -------------------------------------------------------------------------------- /doc/book/general/starting: -------------------------------------------------------------------------------- 1 | # Starting Retro 2 | 3 | Retro can be run for scripting or interactive use. 4 | 5 | ## Interactive 6 | 7 | To start it interactively, run: `retro` without any command line 8 | arguments, or with `-i`. 9 | 10 | Starting the interactive system: 11 | 12 | ``` 13 | retro 14 | ``` 15 | 16 | Or: 17 | 18 | ``` 19 | retro -i 20 | ``` 21 | 22 | This should be sufficient for most uses. 23 | 24 | ## Using In a Pipe 25 | 26 | Retro will work with piped input. 27 | 28 | E.g., 29 | 30 | ``` 31 | echo "'lol s:put nl" | retro 32 | ``` 33 | 34 | ## Running A Program In A File 35 | 36 | You can run code in a file very easily. This is simply: 37 | 38 | ``` 39 | retro filename 40 | ``` 41 | 42 | You can follow the filename with any arguments that it may need. 43 | These will be accessible to the program via the `script:arguments` 44 | and `script:get-argument` words. 45 | 46 | Source files must be written in Unu format. 47 | 48 | ## Scripting 49 | 50 | You can use Retro to write scripts. Add a shebang: 51 | 52 | ``` 53 | #!/usr/bin/env retro 54 | ``` 55 | 56 | And make the file executable. 57 | 58 | Source files must be written in Unu format. 59 | 60 | ## Command Line Arguments 61 | 62 | For a summary of the full command line arguments available: 63 | 64 | Scripting Usage: 65 | 66 | retro filename [script arguments...] 67 | 68 | Interactive Usage: 69 | 70 | retro [-h] [-i] [-f filename] [-t] 71 | 72 | -h Display this help text 73 | -i Interactive mode (line buffered) 74 | -f filename Run the contents of the specified file 75 | -t Run tests (in ``` blocks) in any loaded files 76 | -------------------------------------------------------------------------------- /doc/book/glossary/using: -------------------------------------------------------------------------------- 1 | # Using The Glossary 2 | 3 | The Glossary is a valuable resource. It provides information 4 | on the RETRO words. 5 | 6 | ## Example Entry 7 | 8 | f:+ 9 | 10 | Data: - 11 | Addr: - 12 | Float: FF-F 13 | 14 | Add two floating point numbers, returning the result. 15 | 16 | Class: class:word | Namespace: f | Interface Layer: rre 17 | 18 | Example #1: 19 | 20 | .3.1 .22 f:+ 21 | 22 | ## Reading The Entry 23 | 24 | An entry starts with the word name. 25 | 26 | This is followed by the stack effect for each stack. All RETRO 27 | systems have Data and Address stacks, some also include a 28 | floating point stack). 29 | 30 | The stack effect diagrams are followed by a short description 31 | of the word. 32 | 33 | After the description is a line providing some useful data. This 34 | includes the class handler, namespace prefix, and the interface 35 | layer that provides the word. 36 | 37 | Words in all systems will be listed as `all`. Some words (like 38 | the `pb:` words) are only on specific systems like iOS. These 39 | can be identified by looking at the interface layer field. 40 | 41 | At the end of the entry may be an example or two. 42 | 43 | ## Access Online 44 | 45 | The latest Glossary can be browsed at http://forthworks.com:9999 46 | or gopher://forthworks.com:9999 47 | -------------------------------------------------------------------------------- /doc/book/internals/interface-layers: -------------------------------------------------------------------------------- 1 | # Internals: Interface Layers 2 | 3 | Nga provides a virtual processor and an extensible way of adding 4 | I/O devices, but does not provide any I/O itself. Adding I/O is 5 | the responsability of the *interface layer*. 6 | 7 | An interface layer will wrap Nga, providing at least one I/O 8 | device (a generic output target), and a means of interacting 9 | with the *retro image*. 10 | 11 | It's expected that this layer will be host specific, adding any 12 | system interactions that are needed via the I/O instructions. 13 | The image will typically be extended with words to use these. 14 | 15 | 16 | -------------------------------------------------------------------------------- /doc/book/internals/io: -------------------------------------------------------------------------------- 1 | # Internals: I/O 2 | 3 | Retro provides three words for interacting with I/O. These are: 4 | 5 | io:enumerate returns the number of attached devices 6 | io:query returns information about a device 7 | io:invoke invokes an interaction with a device 8 | 9 | As an example, with an implementation providing an output source, 10 | a block storage system, and keyboard: 11 | 12 | io:enumerate will return `3` since there are three 13 | i/o devices 14 | #0 io:query will return 0 0, since the first device 15 | is a screen (device class 0) with a version 16 | of 0 17 | #1 io:query will return 1 3, since the second device is 18 | block storage (device class 3), with a version 19 | of 1 20 | #2 io:query will return 0 1, since the last device is a 21 | keyboard (device class 1), with a version 22 | of 0 23 | 24 | In this case, some interactions can be defined: 25 | 26 | :c:put #0 io:invoke ; 27 | :c:get #2 io:invoke ; 28 | 29 | Setup the stack, push the device handle, and then use `io:invoke` 30 | to invoke the interaction. 31 | 32 | A Retro system requires one I/O device (a generic output for a 33 | single character). This must be the first device, and must have 34 | a device class and handle of 0. 35 | 36 | All other devices are optional and can be specified in any 37 | order. 38 | 39 | -------------------------------------------------------------------------------- /doc/book/techniques/characters: -------------------------------------------------------------------------------- 1 | # Working With Characters 2 | 3 | RETRO provides words for working with ASCII characters. 4 | 5 | ## Sigil 6 | 7 | Character constants are returned using the `$` sigil. 8 | 9 | ## Namespace 10 | 11 | Words operating on characters are in the `c:` namespace. 12 | 13 | ## Classification 14 | 15 | RETRO provides a number of words to determine if a character 16 | fits into predefined groups. 17 | 18 | The primary words for this are: 19 | 20 | * `c:consonant?` 21 | * `c:digit?` 22 | * `c:letter?` 23 | * `c:lowercase?` 24 | * `c:uppercase?` 25 | * `c:visible?` 26 | * `c:vowel?` 27 | * `c:whitespace?` 28 | 29 | There are also corresponding "not" forms: 30 | 31 | * `c:-consonant?` 32 | * `c:-digit?` 33 | * `c:-lowercase?` 34 | * `c:-uppercase?` 35 | * `c:-visible?` 36 | * `c:-vowel?` 37 | * `c:-whitespace?` 38 | 39 | All of these take a character and return either a `TRUE` or 40 | `FALSE` flag. 41 | 42 | ## Conversions 43 | 44 | A few words are provided to convert case. Each takes a character 45 | and returns the modified character. 46 | 47 | * `c:to-lower` 48 | * `c:to-number` 49 | * `c:to-upper` 50 | * `c:toggle-case` 51 | 52 | RETRO also has `c:to-string`, which takes a character and 53 | creates a new temporary string with the character. 54 | 55 | ## I/O 56 | 57 | Characters can be displayed using `c:put`. 58 | 59 | ``` 60 | $a c:put 61 | ``` 62 | 63 | With the default system on BSD, Linux, and macOS (and other 64 | Unix style hosts), `c:get` is provided to read input. This 65 | may be buffered, depending on the host. 66 | -------------------------------------------------------------------------------- /doc/book/techniques/checking-the-version: -------------------------------------------------------------------------------- 1 | # Checking The Version 2 | 3 | RETRO releases add and change things. You can use the `Version` 4 | variable to determine the version in use and react accordingly. 5 | 6 | ``` 7 | @Version #201906 eq? [ 'Needs_2019.6! s:put nl bye ] if 8 | ``` 9 | 10 | This can be also be used to conditionally load compatibility files: 11 | 12 | ``` 13 | (If_newer_than_2016.6,_load_aliases_for_renamed_words) 14 | @Version #201906 gt? [ 'Renamed_2019.6.forth include ] if 15 | ``` 16 | 17 | ## Version Number Format 18 | 19 | The version is a six digit number encoding the year and month of 20 | the release. So: 21 | 22 | 201901 is 2019.1 23 | 201906 is 2019.6 24 | 201911 is 2019.11 25 | 26 | A `#100 /mod` will suffice to split these if needed. 27 | -------------------------------------------------------------------------------- /doc/book/techniques/definitions: -------------------------------------------------------------------------------- 1 | # Defining Words 2 | 3 | Words are named functions. To start a word, preceed it's name 4 | with a colon. Follow this by the definition, and end with a 5 | semicolon. 6 | 7 | E.g., 8 | 9 | :do-nothing ; 10 | :square dup * ; 11 | -------------------------------------------------------------------------------- /doc/book/techniques/errors: -------------------------------------------------------------------------------- 1 | # Errors 2 | 3 | RETRO does only minimal error checking. 4 | 5 | ## Non-Fatal 6 | 7 | A non-fatal error will be reported on *word not found* during 8 | interactive or compile time. Note that this only applies to 9 | calls: if you try to get a pointer to an undefined word, the 10 | returned pointer will be zero. 11 | 12 | ## Fatal 13 | 14 | A number of conditions are known to cause fatal errors. The 15 | main ones are stack overflow, stack underflow, and division 16 | by zero. 17 | 18 | On these, RETRO will generally exit. For stack depth issues, 19 | the VM will attempt to display an error prior to exiting. 20 | 21 | In some cases, the VM may get stuck in an endless loop. If this 22 | occurs, try using CTRL+C to kill the process, or kill it using 23 | whatever means your host system provides. 24 | 25 | ## Rationale 26 | 27 | Error checks are useful, but slow - especially on a minimal 28 | system like RETRO. The overhead of doing depth or other checks 29 | adds up quickly. 30 | 31 | As an example, adding a depth check to `drop` increases the 32 | time to use it 250,000 times in a loop from 0.16 seconds to 33 | 1.69 seconds. 34 | 35 | -------------------------------------------------------------------------------- /doc/book/techniques/lexical-scope: -------------------------------------------------------------------------------- 1 | # Lexical Scope 2 | 3 | RETRO has a single dictionary, but does provide a means of using 4 | lexical scope to keep this dictionary clean. 5 | 6 | ## Example 7 | 8 | ``` 9 | {{ 10 | 'A var 11 | :++A &A v:inc ; 12 | ---reveal--- 13 | :B ++A ++A @A n:put nl ; 14 | }} 15 | ``` 16 | 17 | In this example, the lexical namespace is created with `{{`. A 18 | variable (`A`) and word (`++A`) are defined. Then a marker is 19 | set with `---reveal---`. Another word (`B`) is defined, and the 20 | lexical area is closed with `}}`. 21 | 22 | The headers between `{{` and `---reveal---` are then hidden from 23 | the dictionary, leaving only the headers between `---reveal---` 24 | and `}}` exposed. 25 | 26 | If you wish to hide all headers in a `{{` ... `}}` block, leave 27 | out the `---reveal---`. 28 | 29 | ``` 30 | {{ 31 | :a #3 ; 32 | :b a dup * ; 33 | }} 34 | ``` 35 | 36 | ## Notes 37 | 38 | This only affects word visibility within the scoped area. As an 39 | example: 40 | 41 | ``` 42 | :a #1 ; 43 | 44 | {{ 45 | :a #2 ; 46 | ---reveal--- 47 | :b 'a s:evaluate n:put ; 48 | }} 49 | ``` 50 | 51 | In this, after `}}` closes the area, the `:a #2 ;` is hidden and 52 | the `s:evaluate` will find the `:a #1 ;` when `b` is run. 53 | 54 | ## A Word of Warning 55 | 56 | Use of these words can result in a corrupt dictionary and system 57 | crashes. Specifically, use of `---reveal---` with an empty private 58 | or public section will result in dictionary corruption. 59 | 60 | If you don't need private words, don't put them in a scope. And if 61 | you don't need public words, don't include the `---reveal---`. 62 | -------------------------------------------------------------------------------- /doc/book/techniques/numbers: -------------------------------------------------------------------------------- 1 | # Working With Numbers 2 | 3 | Numbers in RETRO are signed integers. 4 | 5 | ## Sigil 6 | 7 | All numbers start with a `#` sigil. 8 | 9 | ## Namespace 10 | 11 | Most words operating on numbers are in the `n:` namespace. 12 | 13 | ## Range of Values 14 | 15 | A default RETRO system with 32 bit cells provides a range of 16 | -2,147,483,648 to 2,147,483,647. For 64 bit systems, the range 17 | will be -9,223,372,036,854,775,807 to 9,223,372,036,854,775,806. 18 | 19 | You can check the range your VM and image support using: 20 | 21 | n:MIN 22 | n:MAX 23 | 24 | These will return the limits for your system. 25 | 26 | ## Comparisons 27 | 28 | RETRO provides a number of comparison words for numeric values. 29 | 30 | The basic comparators are: 31 | 32 | -eq? 33 | eq? 34 | lt? 35 | lteq? 36 | gt? 37 | gteq? 38 | 39 | Additionally RETRO also provides: 40 | 41 | n:-zero? 42 | n:between? 43 | n:even? 44 | n:negative? 45 | n:odd? 46 | n:positive? 47 | n:strictly-positive? 48 | n:zero? 49 | 50 | ## Basic Operations 51 | 52 | + 53 | - 54 | * 55 | / 56 | mod 57 | /mod 58 | n:abs 59 | n:dec 60 | n:inc 61 | n:limit 62 | n:max 63 | n:min 64 | n:negate 65 | n:pow 66 | n:sqrt 67 | n:square 68 | 69 | ## Conversions 70 | 71 | You can convert a number to a string with `n:to-string` or 72 | to a floating point value with `n:to-float`. 73 | 74 | #123 n:to-float f:put 75 | 76 | #123 n:to-string s:put 77 | 78 | ## Display 79 | 80 | To display a number, use `n:put`. 81 | 82 | #123 n:put 83 | -------------------------------------------------------------------------------- /doc/book/techniques/pointers: -------------------------------------------------------------------------------- 1 | # Working With Pointers 2 | 3 | ## Sigil 4 | 5 | Pointers are returned by the `&` sigil. 6 | 7 | ## Examples 8 | 9 | ``` 10 | 'Base var 11 | &Base fetch 12 | #10 &Base store 13 | 14 | #10 &n:inc call 15 | ``` 16 | 17 | ## Notes 18 | 19 | The use of `&` to get a pointer to a data structure (with a 20 | word class of `class:data`) is not required. I like to use it 21 | anyway as it makes my intent a little clearer. 22 | 23 | Pointers are useful with combinators. Consider: 24 | 25 | ``` 26 | :abs dup n:negative? [ n:negate ] if ; 27 | ``` 28 | 29 | Since the target quote body is a single word, it is more 30 | efficient to use a pointer instead: 31 | 32 | ``` 33 | :abs dup n:negative? &n:negate if ; 34 | ``` 35 | 36 | The advantages are speed (saves a level of call/return by 37 | avoiding the quotation) and size (for the same reason). 38 | This may be less readable though, so consider the balance 39 | of performance to readability when using this approach. 40 | -------------------------------------------------------------------------------- /doc/book/techniques/return-stack: -------------------------------------------------------------------------------- 1 | # The Return Stack 2 | 3 | RETRO has two stacks. The primary one is used to pass data 4 | between words. The second one primarily holds return addresses. 5 | 6 | Each time a word is called, the next address is pushed to 7 | the return stack. 8 | -------------------------------------------------------------------------------- /doc/book/techniques/scripting: -------------------------------------------------------------------------------- 1 | # Unix Scripting 2 | 3 | RETRO on Unix hosts is designed to play well with scripting. 4 | 5 | Shebang 6 | 7 | To run an entire program directly, start the file with the standard 8 | shebang and make the file executable: 9 | 10 | #!/usr/bin/env retro 11 | 12 | This requires the retro binary to be in your path. 13 | 14 | ## Arguments 15 | 16 | RETRO provides several words in the `script:` namespace for accessing 17 | command line arguments. 18 | 19 | The number of arguments can be accessed via `script:arguments`. This 20 | will return a number with the arguments, other than the script name. 21 | 22 | script:arguments '%n_arguments_passed\n s:format s:put 23 | 24 | To retreive an argument, pass the argument number to `script:get-argument`: 25 | 26 | script:arguments [ I script:get-argument s:put nl ] indexed-times 27 | 28 | And to get the name of the script, use `script:name`. 29 | 30 | script:name s:put 31 | 32 | ## Mixing 33 | 34 | With use of the Unu literate format, it's possible to mix both shell 35 | and RETRO code into a single script. As an example, this is a bit of 36 | shell that runs itself via retro for each .retro file in the current 37 | directory tree: 38 | 39 | #!/bin/sh 40 | 41 | # shell part 42 | find . -name '*.retro' -print0 | xargs -0 -n 1 retro $0 43 | exit 44 | 45 | # retro part 46 | 47 | This will scan a source file and do something with it: 48 | 49 | ~~~ 50 | ... do stuff ... 51 | ~~~ 52 | -------------------------------------------------------------------------------- /doc/book/techniques/stack-diagrams: -------------------------------------------------------------------------------- 1 | # Stack Diagrams 2 | 3 | Most words in RETRO have a stack comment. These look like: 4 | 5 | (-) 6 | (nn-n) 7 | 8 | As with all comments, a stack comment begins with `(` and 9 | should end with a `)`. There are two parts to the comment. 10 | On the left side of the `-` is what the word *consumes*. On 11 | the right is what it *leaves*. 12 | 13 | RETRO uses a short notation, with one character per value 14 | taken or left. In general, the following symbols represent 15 | certain types of values. 16 | 17 | | Notation | Represents | 18 | | ------------------- | ----------------------- | 19 | | b, n, m, o, x, y, z | generic numeric values | 20 | | s | string | 21 | | v | variable | 22 | | p, a | pointers | 23 | | q | quotation | 24 | | d | dictionary header | 25 | | f | `TRUE` or `FALSE` flag. | 26 | 27 | In the case of something like `(xyz-m)`, RETRO expects z to be 28 | on the top of the stack, with y below it and x below the y 29 | value. And after execution, a single value (m) will be left on 30 | the stack. 31 | 32 | Words with no stack effect have a comment of (-) 33 | 34 | For combinators (words consuming quotations), you can include 35 | a sub-comment indicating the expected stack effect of the 36 | quote. E.g., 37 | 38 | (q(-f)-) 39 | 40 | Indicates a word consuming a quote and returning nothing. The 41 | quote should return a flag. 42 | -------------------------------------------------------------------------------- /doc/book/toolchain/info/retro-compiler: -------------------------------------------------------------------------------- 1 | # The Optional Retro Compiler 2 | 3 | In addition to the base system, users of RETRO on Unix hosts 4 | with ELF executables can build and use the `retro-compiler` 5 | to generate turnkey executables. 6 | 7 | ## Requirements 8 | 9 | - Unix host 10 | - ELF executable support 11 | - `objcopy` in the $PATH 12 | 13 | ## Building 14 | 15 | make bin/retro-compiler 16 | 17 | ## Installing 18 | 19 | Copy `bin/retro-compiler` to somewhere in your $PATH. 20 | 21 | ## Using 22 | 23 | `retro-compiler` takes two arguments: the source file to 24 | compile and the name of the word to use as the main entry 25 | point. 26 | 27 | Example: 28 | 29 | Given a `hello.forth`: 30 | 31 | ~~~ 32 | :hello 'Hello_World! s:put nl ; 33 | ~~~ 34 | 35 | Use: 36 | 37 | retro-compiler hello.forth hello 38 | 39 | The compiler will generate an `a.out` file which you can 40 | then rename. 41 | 42 | ## Known Limitations 43 | 44 | This does not provide the scripting support for command line 45 | arguments that the standard `retro` interface offers. 46 | 47 | A copy of `objcopy` needs to be in the path for compilation 48 | to work. 49 | 50 | The current working directory must be writable. 51 | 52 | This only supports hosts using ELF executables. 53 | 54 | The output file name is fixed to `a.out`. 55 | -------------------------------------------------------------------------------- /doc/book/toolchain/info/retro-unu: -------------------------------------------------------------------------------- 1 | # Unu: Simple, Literate Source Files 2 | 3 | RETRO is written in a literate style. Most of the sources 4 | are in a format called Unu. This allows easy mixing of 5 | commentary and code blocks, making it simple to document 6 | the code. 7 | 8 | The Unu format does not support writing code and commentary "out 9 | of order". 10 | 11 | As an example, 12 | 13 | # Determine The Average Word Name Length 14 | 15 | To determine the average length of a word name two values 16 | are needed. First, the total length of all names in the 17 | Dictionary: 18 | 19 | ~~~ 20 | #0 [ d:name s:length + ] d:for-each 21 | ~~~ 22 | 23 | And then the number of words in the Dictionary: 24 | 25 | ~~~ 26 | #0 [ drop n:inc ] d:for-each 27 | ~~~ 28 | 29 | With these, a simple division is all that's left. 30 | 31 | ~~~ 32 | / 33 | ~~~ 34 | 35 | Finally, display the results: 36 | 37 | 38 | ~~~ 39 | 'Average_name_length:_%n\n s:format s:put 40 | ~~~ 41 | 42 | This illustrates the format. Only code in the fenced blocks 43 | (between \~~~ pairs) get extracted and run. 44 | 45 | (Note: this only applies to *source files*; fences are not used 46 | when entering code interactively). 47 | 48 | ## On The Name 49 | 50 | The name Unu comes from the Maori language, where it means: 51 | 52 | (verb) (-hia) pull out, withdraw, draw out, extract. 53 | Taken from https://maoridictionary.co.nz/ 54 | -------------------------------------------------------------------------------- /doc/book/toolchain/man/retro: -------------------------------------------------------------------------------- 1 | RETRO(1) General Commands Manual RETRO(1) 2 | 3 | RETRO 4 | retro - a modern, pragmatic forth development system 5 | 6 | SYNOPSIS 7 | retro [-h] [-i] [-t] [-f filename] [-u filename] [-r filename] 8 | [filename script-args] 9 | 10 | DESCRIPTION 11 | RETRO is a modern, pragmatic Forth drawing influences from many sources. 12 | It's clean, elegant, tiny, and easy to grasp and adapt to various uses. 13 | 14 | retro is the main interface for interacting with Retro. It provides both 15 | an interactive and a scripting model. 16 | 17 | OPTIONS 18 | -h Display a help screen. 19 | 20 | -i Start Retro in interactive mode. 21 | 22 | -s Start Retro in interactive mode and supress the startup message. 23 | 24 | -t Run any test blocks in the loaded files. 25 | 26 | -f filename 27 | Run any code blocks in the specified file. 28 | 29 | -u filename 30 | Load and use the specified image file rather than the integral 31 | one. 32 | 33 | -r filename 34 | Load and run the code in the specified image file rather than 35 | the integral one. 36 | 37 | filename script-args 38 | Run code blocks in a single file. Pass script-args to the code 39 | being run. 40 | 41 | AUTHORS 42 | Charles Childers 43 | 44 | OpenBSD 6.4 September 2019 OpenBSD 6.4 45 | -------------------------------------------------------------------------------- /doc/book/toolchain/man/retro-describe: -------------------------------------------------------------------------------- 1 | RETRO-DESCRIBE(1) General Commands Manual RETRO-DESCRIBE(1) 2 | 3 | RETRO-DESCRIBE 4 | retro-describe - a modern, pragmatic forth development system 5 | 6 | SYNOPSIS 7 | retro-describe wordname [additional wordnames] 8 | 9 | DESCRIPTION 10 | RETRO is a modern, pragmatic Forth drawing influences from many sources. 11 | It's clean, elegant, tiny, and easy to grasp and adapt to various uses. 12 | 13 | retro-describe is a tool for looking up the description and stack 14 | comments for words in the core language and extensions. It will write 15 | output to stdout. 16 | 17 | AUTHORS 18 | Charles Childers 19 | 20 | OpenBSD 6.4 May 2019 OpenBSD 6.4 21 | -------------------------------------------------------------------------------- /doc/book/toolchain/man/retro-document: -------------------------------------------------------------------------------- 1 | RETRO-DOCUMENT(1) General Commands Manual RETRO-DOCUMENT(1) 2 | 3 | RETRO-DOCUMENT 4 | retro-document - a modern, pragmatic forth development system 5 | 6 | SYNOPSIS 7 | retro-document filename 8 | 9 | DESCRIPTION 10 | RETRO is a modern, pragmatic Forth drawing influences from many sources. 11 | It's clean, elegant, tiny, and easy to grasp and adapt to various uses. 12 | 13 | retro-document is a tool for generating a listing of the descriptions and 14 | stack comments for all standard word used in a source file. It will write 15 | output to stdout. 16 | 17 | AUTHORS 18 | Charles Childers 19 | 20 | OpenBSD 6.4 May 2019 OpenBSD 6.4 21 | -------------------------------------------------------------------------------- /doc/book/toolchain/man/retro-embedimage: -------------------------------------------------------------------------------- 1 | RETRO-EMBEDIMAGE(1) General Commands Manual RETRO-EMBEDIMAGE(1) 2 | 3 | RETRO-EMBEDIMAGE 4 | retro-embedimage - a modern, pragmatic forth development system 5 | 6 | SYNOPSIS 7 | retro-embedimage [filename] 8 | 9 | DESCRIPTION 10 | RETRO is a modern, pragmatic Forth drawing influences from many sources. 11 | It's clean, elegant, tiny, and easy to grasp and adapt to various uses. 12 | 13 | retro-embedimage loads the specified image (or `ngaImage` from the 14 | current directory if none is specified). It converts this into C code 15 | that can be compiled for inclusion in a RETRO executable. It will write 16 | the output to stdout. 17 | 18 | AUTHORS 19 | Charles Childers 20 | 21 | OpenBSD 6.4 February 2019 OpenBSD 6.4 22 | -------------------------------------------------------------------------------- /doc/book/toolchain/man/retro-extend: -------------------------------------------------------------------------------- 1 | RETRO-EXTEND(1) General Commands Manual RETRO-EXTEND(1) 2 | 3 | RETRO-EXTEND 4 | retro-extend - a modern, pragmatic forth development system 5 | 6 | SYNOPSIS 7 | retro-extend image filename [filenames] 8 | 9 | DESCRIPTION 10 | RETRO is a modern, pragmatic Forth drawing influences from many sources. 11 | It's clean, elegant, tiny, and easy to grasp and adapt to various uses. 12 | 13 | retro-extend is a tool to load additional code into an image file. It 14 | takes the name of an image file and one or more source files to load into 15 | the image. After completion the image file will be updated with the 16 | changes. 17 | 18 | 19 | CAVEATS 20 | retro-extend only emulates the minimal console output device. If the 21 | source files require additional I/O to be present, the extend process 22 | will likely fail to work correctly. 23 | 24 | 25 | AUTHORS 26 | Charles Childers 27 | 28 | OpenBSD 6.4 January 2021 OpenBSD 6.4 29 | -------------------------------------------------------------------------------- /doc/book/toolchain/man/retro-locate: -------------------------------------------------------------------------------- 1 | RETRO-LOCATE(1) General Commands Manual RETRO-LOCATE(1) 2 | 3 | RETRO-LOCATE 4 | retro-locate - a modern, pragmatic forth development system 5 | 6 | SYNOPSIS 7 | retro-locate wordname 8 | 9 | DESCRIPTION 10 | RETRO is a modern, pragmatic Forth drawing influences from many sources. 11 | It's clean, elegant, tiny, and easy to grasp and adapt to various uses. 12 | 13 | retro-locate searches the tags file generated by retro-tags for the 14 | desired word name. Any matches are displayed, along with the line number. 15 | 16 | AUTHORS 17 | Charles Childers 18 | 19 | OpenBSD 6.6 January 2020 OpenBSD 6.6 20 | -------------------------------------------------------------------------------- /doc/book/toolchain/man/retro-muri: -------------------------------------------------------------------------------- 1 | RETRO-MURI(1) General Commands Manual RETRO-MURI(1) 2 | 3 | RETRO-MURI 4 | retro-muri - a modern, pragmatic forth development system 5 | 6 | SYNOPSIS 7 | retro-muri filename 8 | 9 | DESCRIPTION 10 | RETRO is a modern, pragmatic Forth drawing influences from many sources. 11 | It's clean, elegant, tiny, and easy to grasp and adapt to various uses. 12 | 13 | retro-muri is an assembler for Nga, the virtual machine at the heart of 14 | Retro. It is used to build the image file containing the actual Retro 15 | language. 16 | 17 | This will extract the code blocks in the specified file and generate an 18 | image file named `ngaImage`. 19 | 20 | AUTHORS 21 | Charles Childers 22 | 23 | OpenBSD 6.4 February 2019 OpenBSD 6.4 24 | -------------------------------------------------------------------------------- /doc/book/toolchain/man/retro-tags: -------------------------------------------------------------------------------- 1 | RETRO-TAGS(1) General Commands Manual RETRO-TAGS(1) 2 | 3 | RETRO-TAGS 4 | retro-tags - a modern, pragmatic forth development system 5 | 6 | SYNOPSIS 7 | retro-tags 8 | 9 | DESCRIPTION 10 | RETRO is a modern, pragmatic Forth drawing influences from many sources. 11 | It's clean, elegant, tiny, and easy to grasp and adapt to various uses. 12 | 13 | retro-tags is a tool for extracting code from fenced blocks in literate 14 | sources and generating a tags file compatible with ctags. 15 | 16 | AUTHORS 17 | Charles Childers 18 | 19 | OpenBSD 6.4 August 2019 OpenBSD 6.4 20 | -------------------------------------------------------------------------------- /doc/book/toolchain/man/retro-unu: -------------------------------------------------------------------------------- 1 | RETRO-UNU(1) General Commands Manual RETRO-UNU(1) 2 | 3 | RETRO-UNU 4 | retro-unu - a modern, pragmatic forth development system 5 | 6 | SYNOPSIS 7 | retro-unu filename 8 | 9 | DESCRIPTION 10 | RETRO is a modern, pragmatic Forth drawing influences from many sources. 11 | It's clean, elegant, tiny, and easy to grasp and adapt to various uses. 12 | 13 | retro-unu is a tool for extracting code from fenced blocks in literate 14 | sources. It will write output to stdout. 15 | 16 | retro-unu does not support "out of order" structuring of code, commentary, 17 | and test blocks. 18 | 19 | AUTHORS 20 | Charles Childers 21 | 22 | OpenBSD 6.4 January 2019 OpenBSD 6.4 23 | -------------------------------------------------------------------------------- /example/99-bottles.retro: -------------------------------------------------------------------------------- 1 | # 99 Bottles 2 | 3 | Display the text for the *99 Bottles of Beer* song. 4 | 5 | For this, I'm using `s:evaluate` to construct words which 6 | display a string when called. This lets the majority of the 7 | code read nicely. 8 | 9 | ~~~ 10 | { 'bottle 'bottles 'of 'beer 'on 'the 'wall 'no 'more 11 | 'Take 'one 'down, 'pass 'it 'around } 12 | [ dup ':%s_'%s_s:put_sp_; s:format s:evaluate ] a:for-each 13 | ~~~ 14 | 15 | Handling of the exact text related to the number of bottles 16 | is done with a simple array of functions that get selected 17 | based on the number of bottles left. This is done with a 18 | very simple filter, where the number of bottles for the 19 | purpose of the text is in a set of 2 or more, 1, or none. 20 | 21 | ~~~ 22 | { [ no more bottles ] 23 | [ #1 n:put sp bottle ] 24 | [ dup n:put sp bottles ] 25 | } 'BOTTLES const 26 | 27 | :number-bottles 28 | dup #2 n:min BOTTLES swap a:fetch call ; 29 | ~~~ 30 | 31 | Thanks to the programatically generated words for the 32 | verse text, the main code is nicely readable. 33 | 34 | ~~~ 35 | :display-verse 36 | number-bottles of beer on the wall nl 37 | number-bottles of beer nl 38 | n:dec Take one down, pass it around nl 39 | number-bottles of beer on the wall nl ; 40 | 41 | :verses (n-) 42 | repeat 0; nl display-verse again ; 43 | 44 | #99 verses 45 | ~~~ 46 | -------------------------------------------------------------------------------- /example/EDA.retro: -------------------------------------------------------------------------------- 1 | # EDA.forth 2 | 3 | ## Description 4 | 5 | Forth EDA, ported to RETRO 6 | http://www.0xff.in/bin/A_Language_for_Digital_Design.pdf 7 | 8 | ## Code & Commentary 9 | 10 | ~~~ 11 | #32768 'STATUS const 12 | #32767 'TIME const 13 | ~~~ 14 | 15 | ### Digital logic simulator 16 | 17 | ~~~ 18 | :S. dup STATUS and n:-zero? [ '+ s:put ] if TIME and n:put ; 19 | :_ (n-n) STATUS xor ; 20 | :eda:and (nn-n) over TIME and over TIME and n:max rot STATUS and rot STATUS and and + ; 21 | :eda:or (nn-n) _ swap _ eda:and _ ; 22 | ~~~ 23 | 24 | ### Technology 25 | 26 | ~~~ 27 | :2and (nn-n) eda:and _ #9 + ; 28 | :3or (nnn-n) eda:or eda:or #30 + ; 29 | :2xor (nn-n) over _ over eda:and [ _ eda:and ] dip eda:or #35 + ; 30 | ~~~ 31 | 32 | ### Logic equations 33 | 34 | ~~~ 35 | #0 'A const 36 | #10 'B const 37 | #10 _ 'C const 38 | :enb_ (-n) A B 2xor ; (45) 39 | :xy (-n) enb_ C 2and A B 3or ; (+84) 40 | ~~~ 41 | 42 | ## Test 43 | 44 | ``` 45 | enb_ S. nl 46 | xy S. nl 47 | ``` 48 | -------------------------------------------------------------------------------- /example/HTML.retro: -------------------------------------------------------------------------------- 1 | # HTML Generation 2 | 3 | This is a little experiment in combinator-driven HTML generation. 4 | 5 | ~~~ 6 | :a:href (ss-) ' s:put s:put ' s:put ; 7 | :p (q-) '

s:put call '

s:put nl ; 8 | :strong (q-) ' s:put call ' s:put nl ; 9 | :em (q-) ' s:put call ' s:put nl ; 10 | :h1 (s-) '

s:put s:put '

s:put nl ; 11 | :div (q-) '
s:put call '
s:put nl ; 12 | :body (q-) ' s:put call ' s:put nl ; 13 | :sigil:" s:keep &s:put compile:call ; immediate 14 | ~~~ 15 | 16 | Test case: 17 | 18 | ``` 19 | [ 'Hello h1 20 | [ 'This_is_a_test_of_HTML_generation._Please_ 21 | 'follow_the_link 'page2.html a:href '. ] p 22 | [ 'This_is_a_second_paragraph ] p 23 | ] body 24 | ``` 25 | -------------------------------------------------------------------------------- /example/accumulator.retro: -------------------------------------------------------------------------------- 1 | # Accumulator 2 | 3 | ## Description 4 | 5 | This implements a function that takes an initial value and constructs a 6 | new function that returns the value before incrementing the stored value 7 | by 1. 8 | 9 | So, given an initial value of 1, the first time the function is called, 10 | 1 is returned. The second, 2, and so on. 11 | 12 | In traditional Forth, this would be done using a CREATE/DOES> construct. 13 | RETRO allows for something similar using the `does` combinator. 14 | 15 | An example in a traditional Forth: 16 | 17 | : acc ( n "name" -- ) 18 | create , does> dup >r @ dup 1+ r> ! ; 19 | 20 | In RETRO, we could begin by rewriting this using the RETRO words: 21 | 22 | :acc (ns-) 23 | d:create , [ dup push fetch n:inc pop store ] does ; 24 | 25 | The `dup push ... pop` pattern is the `sip` combinator, so we can 26 | simplify it: 27 | 28 | :acc (ns-) 29 | d:create , [ [ fetch n:inc ] sip store ] does ; 30 | 31 | This is better, but not quite done. RETRO has a `v:inc` for incrementing 32 | variables, which would eliminate the n:inc and store. And a `bi` 33 | combinator to run two quotes against a value. So we could simplify yet 34 | again, resulting in: 35 | 36 | ~~~ 37 | :acc (ns-) 38 | d:create , [ [ fetch ] [ v:inc ] bi ] does ; 39 | ~~~ 40 | 41 | This removes the primitive stack shuffling, and leaves something that 42 | expresses the intent more clearly. 43 | 44 | Finally, here's a little test case: 45 | 46 | ``` 47 | #10 'foo acc 48 | foo 49 | foo 50 | foo 51 | ``` 52 | -------------------------------------------------------------------------------- /example/adding-vectors.retro: -------------------------------------------------------------------------------- 1 | This is an example adding two three element vectors. 2 | 3 | ~~~ 4 | :vadd (v1v2v3-) 5 | 'abc 'cabcabcab reorder 6 | [ #2 + ] tri@ [ fetch ] bi@ + swap store 7 | [ n:inc ] tri@ [ fetch ] bi@ + swap store 8 | [ fetch ] bi@ + swap store ; 9 | ~~~ 10 | 11 | A test case: 12 | 13 | ``` 14 | 'a d:create #1 , #2 , #3 , 15 | 'b d:create #2 , #3 , #4 , 16 | 'c d:create #3 allot 17 | 18 | &a &b &c vadd 19 | 20 | &c fetch-next n:put nl 21 | fetch-next n:put nl 22 | fetch n:put nl 23 | ``` 24 | 25 | -------------------------------------------------------------------------------- /example/advent-of-code-2021-day-1.retro: -------------------------------------------------------------------------------- 1 | # Part 1 2 | 3 | This is a pretty easy problem. 4 | 5 | Using the `file:for-each-line` to iterate over each line, 6 | I increment a variable for each increase. I also leave the 7 | most recently read value on the stack for the next comparison. 8 | 9 | The variable is initialized to -1. My initial comparison 10 | value is 0, so the first data from the file will be greater 11 | than this. Using an initial -1 value ensures that the needed 12 | adjustment is factored in. 13 | 14 | ~~~ 15 | #-1 'Increased var-n 16 | 17 | :process (ns-n) s:to-number tuck lt? [ &Increased v:inc ] if ; 18 | #0 'day1.input [ process ] file:for-each-line drop 19 | 20 | @Increased n:put nl 21 | ~~~ 22 | 23 | # Part 2 24 | 25 | The introduction of a three value sliding window makes this 26 | a little trickier. I chose to use only a single accumulator 27 | variable, keeping the values for the window and the latest 28 | sum on the stack. 29 | 30 | I use `reorder` to update the stack orderings when adjusting 31 | the values for the sliding window and when moving the newest 32 | sum to the bottom. 33 | 34 | I'm using the same trick with a negative starting value 35 | (-3 in this case) for my count, to allow for the initial 36 | non-existant entries of zero. 37 | 38 | 39 | ~~~ 40 | #-3 'Increased var-n 41 | 42 | :slide 'abcde 'cdeacde reorder ; 43 | :sum + + ; 44 | :check [ lt? [ &Increased v:inc ] if ] sip ; 45 | :update 'abcd 'dabc reorder ; 46 | :process s:to-number slide sum check update ; 47 | 48 | #0 #0 #0 #0 'day1.input [ process ] file:for-each-line 49 | drop-pair drop-pair 50 | 51 | @Increased n:put nl 52 | ~~~ 53 | -------------------------------------------------------------------------------- /example/advent-of-code-2021-day-2.retro: -------------------------------------------------------------------------------- 1 | As with day 1, the first part of this is easy. I'm "parsing" 2 | the input data by using `s:tokenize` and then unpacking the 3 | two element array. Convert the numeric part to a number, then 4 | a simple set of `s:case`s to process things. 5 | 6 | ~~~ 7 | :a:unpack [ ] a:for-each ; 8 | :parse ASCII:SPACE s:tokenize a:unpack s:to-number swap ; 9 | 10 | :process 11 | parse 12 | 'forward [ + ] s:case 13 | 'down [ swap [ + ] dip ] s:case 14 | 'up [ swap [ - ] dip ] s:case 15 | drop-pair ; 16 | 17 | (depth,horizontal) 18 | #0 #0 'day2.input [ process ] file:for-each-line 19 | * n:put nl 20 | ~~~ 21 | 22 | The second half is modestly more difficult. As I'm minimizing 23 | any use of variables, this is a little messier than I'd prefer, 24 | but it's still pretty straightforward. 25 | 26 | I'm reusing the "parsing" part from the first half. 27 | 28 | My stack values are: aim depth horizontal 29 | 30 | ~~~ 31 | :process 32 | parse 33 | 'forward [ [ + ] [ 'abcd 'acbda reorder * + swap ] bi ] s:case 34 | 'down [ [ rot ] dip + rot rot ] s:case 35 | 'up [ [ rot ] dip - rot rot ] s:case 36 | drop-pair ; 37 | 38 | (aim,depth,horizontal) 39 | #0 #0 #0 'day2.input [ process ] file:for-each-line 40 | 41 | * n:put nl drop (discard_the_aim_field) 42 | ~~~ 43 | -------------------------------------------------------------------------------- /example/amalgamate-python.retro: -------------------------------------------------------------------------------- 1 | # Amalgamate 2 | 3 | The standard RETRO system is built using the Nga VM[1] and an 4 | image file. The Python implementation consists of several files, 5 | but it's nice to have a single file copy for easier deployment. 6 | This tool combines the pieces into a single source file. 7 | 8 | Output will be written to stdout. 9 | 10 | ## Code 11 | 12 | Extract and generate the single file source. 13 | 14 | ~~~ 15 | {{ 16 | :include-file 17 | #6 + s:chop 'vm/nga-python/ s:prepend here swap file:slurp here s:put ; 18 | 19 | :source:line 20 | dup 'from_" s:begins-with? 21 | [ include-file ] [ s:put nl ] choose ; 22 | 23 | ---reveal--- 24 | 25 | :amalgamate 26 | 'vm/nga-python/retro.py [ source:line ] file:for-each-line ; 27 | }} 28 | 29 | amalgamate 30 | ~~~ 31 | -------------------------------------------------------------------------------- /example/amalgamate.retro: -------------------------------------------------------------------------------- 1 | # Amalgamate 2 | 3 | The standard RETRO system is built using the Nga VM[1] and a 4 | copy of the image exported as a C source file[2]. I sometimes 5 | prefer to have these as a single file for easier sharing. This 6 | is a quick little tool to combine them. 7 | 8 | Output will be written to stdout. 9 | 10 | ## References 11 | 12 | [1] vm/nga-c/retro.c 13 | [2] vm/nga-c/image.c 14 | 15 | ## Code 16 | 17 | Include compilation instructions and enable i/o devices. 18 | 19 | ~~~ 20 | '/*_Build_with_`cc_-lm_-O2_retro-unix.c_-o_retro`_*/ s:put nl nl 21 | 22 | '#define_BIT64 s:put nl 23 | 24 | { 'CLOCK 25 | 'FILES 26 | 'FLOATS 27 | 'MALLOC 28 | 'MULTICORE 29 | 'RNG 30 | 'SCRIPTING 31 | 'SIGNALS 32 | 'UNIX 33 | 'UNSIGNED 34 | } [ '#define_ENABLE\_%s s:format s:put nl ] a:for-each nl 35 | ~~~ 36 | 37 | Then extract and generate the single file source. 38 | 39 | ~~~ 40 | {{ 41 | :include-file 42 | #10 + s:chop 'vm/nga-c/ s:prepend here swap file:slurp here s:put ; 43 | 44 | :source:line 45 | dup '#include_" s:begins-with? 46 | [ include-file ] [ s:put nl ] choose ; 47 | 48 | ---reveal--- 49 | 50 | :amalgamate 51 | 'vm/nga-c/retro.c [ source:line ] file:for-each-line ; 52 | }} 53 | 54 | amalgamate 55 | ~~~ 56 | -------------------------------------------------------------------------------- /example/ans-pick-roll.retro: -------------------------------------------------------------------------------- 1 | PICK and ROLL are problematic in that they require the ability 2 | to address the stack as if it were an array. The implementations 3 | here are not efficient as RETRO's stacks are *not* addressable. 4 | 5 | These will never be added to the standard image, but are provided 6 | here as an aid in porting ANS FORTH code or for those curious as 7 | to how such things could be added. 8 | 9 | # PICK 10 | 11 | 6.2.2030 PICK 12 | CORE EXT 13 | 14 | ( xu ... x1 x0 u -- xu ... x1 x0 xu ) 15 | 16 | Remove u. Copy the xu to the top of the stack. An ambiguous 17 | condition exists if there are less than u+2 items on the stack 18 | before PICK is executed. 19 | 20 | 21 | ~~~ 22 | {{ 23 | :save-stack (...-a) 24 | here [ depth &, times ] dip ; 25 | :fetch-prior (a-n[a-1]) 26 | dup fetch swap n:dec ; 27 | :restore-stack (a-...) 28 | here swap - here n:dec swap [ fetch-prior ] times drop ; 29 | ---reveal--- 30 | :PICK (...n-...m) 31 | &Heap [ [ save-stack ] dip 32 | over + fetch [ restore-stack ] dip ] v:preserve ; 33 | }} 34 | ~~~ 35 | 36 | # ROLL 37 | 38 | 6.2.2150 ROLL 39 | CORE EXT 40 | 41 | ( xu xu-1 ... x0 u -- xu-1 ... x0 xu ) 42 | 43 | Remove u. Rotate u+1 items on the top of the stack. An ambiguous 44 | condition exists if there are less than u+2 items on the stack 45 | before ROLL is executed. 46 | 47 | ~~~ 48 | {{ 49 | :save-values (...n-a) 50 | [ , ] times here ; 51 | :restore-values (a-...) 52 | here - here swap [ fetch-next swap ] times drop ; 53 | ---reveal--- 54 | :ROLL (...n-...m) 55 | &Heap [ save-values ] v:preserve swap [ restore-values ] dip ; 56 | }} 57 | ~~~ 58 | -------------------------------------------------------------------------------- /example/archive-extract.retro: -------------------------------------------------------------------------------- 1 | This is archive-extract, an un-archiver. Pass it a file created 2 | by `archive.retro` to extract the files. 3 | 4 | As a recap of the file format. 5 | 6 | # of files 7 | filename 8 | length in bytes 9 | ... data ... 10 | filename 11 | length in bytes 12 | ... data ... 13 | [ ... repeat for each file ... ] 14 | 15 | I track the input (the archive) in `In` and the current file 16 | being extracted in `Out`. 17 | 18 | ~~~ 19 | 'In var 20 | 'Out var 21 | ~~~ 22 | 23 | The filename is passed in via the command line. Open it, save 24 | the pointer. 25 | 26 | ~~~ 27 | #0 script:get-argument file:open-for-reading nip !In 28 | ~~~ 29 | 30 | I define a helper that will be used write data to the output 31 | file. 32 | 33 | ~~~ 34 | :write @Out file:write ; 35 | ~~~ 36 | 37 | Define words to process the archive data. 38 | 39 | ~~~ 40 | :get-count @In file:read-line s:to-number ; 41 | :filename @In file:read-line file:open-for-writing !Out ; 42 | :size @In file:read-line s:to-number ; 43 | :extract [ @In file:read write ] times ; 44 | :skip-nl @In file:read-line drop ; 45 | :close @Out file:close ; 46 | ~~~ 47 | 48 | Then use them to process the file. 49 | 50 | ~~~ 51 | get-count [ filename size extract close skip-nl ] times 52 | @In file:close 53 | ~~~ 54 | -------------------------------------------------------------------------------- /example/archive-info.retro: -------------------------------------------------------------------------------- 1 | This displays the contents (file names, sizes) of an archive. 2 | 3 | I track the input (the archive) in `In`. 4 | 5 | ~~~ 6 | 'In var 7 | ~~~ 8 | 9 | The filename is passed in via the command line. Open it, save 10 | the pointer. 11 | 12 | ~~~ 13 | #0 script:get-argument file:open-for-reading nip !In 14 | ~~~ 15 | 16 | Define words to process the archive data. 17 | 18 | ~~~ 19 | :get-count @In file:read-line s:to-number dup n:put '_files s:put nl ; 20 | :pad s:length #32 swap - #0 n:max [ sp ] times ; 21 | :filename @In file:read-line dup s:put pad ; 22 | :size @In file:read-line s:to-number dup n:put '_bytes s:put nl ; 23 | :skip [ @In file:read drop ] times ; 24 | :skip-nl @In file:read-line drop ; 25 | ~~~ 26 | 27 | Then use them to process the file. 28 | 29 | ~~~ 30 | get-count [ filename size skip skip-nl ] times 31 | @In file:close 32 | ~~~ 33 | -------------------------------------------------------------------------------- /example/bury.retro: -------------------------------------------------------------------------------- 1 | This is a word to bury a value by moving it to the bottom 2 | of the stack. 3 | 4 | It does this in a quick and dirty way: copy the values other 5 | than TOS into a new array, then copy the values from the 6 | array back to the stack. This is slow, but it's not something 7 | that I've ever needed in actual use, so I see no reason to 8 | devote time to finding a faster solution. 9 | 10 | ~~~ 11 | :bury (...n-n...) 12 | &Heap [ here [ [ depth dup , [ , ] times ] dip ] dip 13 | a:reverse [ ] a:for-each ] v:preserve ; 14 | ~~~ 15 | 16 | Test Case: 17 | 18 | ``` 19 | #12 #23 #34 #45 #56 20 | dump-stack nl 21 | bury 22 | nl dump-stack nl 23 | ``` 24 | -------------------------------------------------------------------------------- /example/c-style-comments.retro: -------------------------------------------------------------------------------- 1 | # C Style Comments 2 | 3 | This adds support for comments with embedded spaces. It is useful 4 | for quickly commenting out portions of lines or larger chunks of 5 | code during debugging. 6 | 7 | Specifically, this provides for C style /* ... */ comments. It 8 | works by patching `interpret` to make it ignore tokens until the 9 | token is `*/`. 10 | 11 | ~~~ 12 | {{ 13 | :done? '*/ s:eq? ; 14 | :revert &interpret unhook ; 15 | ---reveal--- 16 | :/* (-a) [ (a-) done? &revert if ] &interpret set-hook ; immediate 17 | }} 18 | ~~~ 19 | 20 | # Test Case 21 | 22 | ``` 23 | :test /* hello world */ 24 | #1 25 | 26 | /* 27 | this is a test. drop stuff. 28 | more lines 29 | */ 30 | 31 | #2 + /* display */ n:put nl ; 32 | 33 | test 34 | ``` 35 | -------------------------------------------------------------------------------- /example/capture-output.retro: -------------------------------------------------------------------------------- 1 | # Capturing Output 2 | 3 | By taking advantage of the hook in `c:put`, it's possible to 4 | write a combinator to capture output to a user specified 5 | buffer. 6 | 7 | ~~~ 8 | {{ 9 | :capture{ &buffer:add &c:put set-hook ; 10 | :} &c:put unhook ; 11 | ---reveal--- 12 | :capture-output (qa-) 13 | [ buffer:set capture{ call } ] buffer:preserve ; 14 | }} 15 | ~~~ 16 | 17 | ## A Test Case 18 | 19 | ``` 20 | 'Output d:create #256 #1024 * n:inc allot 21 | [ d:words ] &Output capture-output 22 | Output s:length n:put nl 23 | ``` 24 | -------------------------------------------------------------------------------- /example/cat.retro: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env retro 2 | 3 | ~~~ 4 | #0 script:get-argument [ s:put nl ] file:for-each-line 5 | ~~~ 6 | -------------------------------------------------------------------------------- /example/close-paren.retro: -------------------------------------------------------------------------------- 1 | I find `)` useful to punctuate code chunks. 2 | 3 | ~~~ 4 | :) ; immediate (code_chunk_punctuation_that_does_nothing 5 | ~~~ 6 | 7 | Here is an example: 8 | 9 | :i@ (an-n) a:fetch ; 10 | 11 | ~~~ 12 | {{ 13 | :I@ (an-n) I a:fetch ; 14 | 'Index 'Value [ var ] bi@ 15 | :lt?-or-gt? hook ; 16 | :pre.min (a-an) 17 | (comparison <? <?-or-gt? set-hook ) 18 | (begin_with #-1 !Index n:MAX !Value dup a:length ) ; 19 | :pre.max (a-an) 20 | (comparison >? <?-or-gt? set-hook ) 21 | (begin_with #-1 !Index n:MIN !Value dup a:length ) ; 22 | :min-or-max (a-nn) [ dup I@ dup @Value lt?-or-gt? 23 | [ !Value I !Index ] [ drop ] choose ] indexed-times 24 | (a-nn drop @Index @Value ) ; 25 | ---reveal--- 26 | :a:min (a-iv) pre.min min-or-max ; 27 | :a:max (a-iv) pre.max min-or-max ; 28 | }} 29 | ~~~ 30 | 31 | ``` 32 | { #3 #2 #5 #7 #3 } a:min dump-stack nl reset 33 | { #3 #2 #5 #7 #3 } a:max dump-stack nl 34 | ``` 35 | 36 | -------------------------------------------------------------------------------- /example/colored-dwords.retro: -------------------------------------------------------------------------------- 1 | This show use of the termina color words to display the contents 2 | of the dictionary, using colors for various word classes. 3 | 4 | ~~~ 5 | 'termina library:load 6 | 7 | :d:words/c 8 | [ dup d:class fetch 9 | [ &class:data [ fg:magenta ] case 10 | &class:macro [ fg:red ] case 11 | &class:primitive [ fg:yellow ] case 12 | drop fg:green 13 | ] call d:name s:put sp vt:reset ] d:for-each ; 14 | ~~~ 15 | 16 | 17 | ``` 18 | d:words/c 19 | ``` 20 | -------------------------------------------------------------------------------- /example/defstruct.retro: -------------------------------------------------------------------------------- 1 | LISP provides a function, `defstruct`, which creates a data 2 | structure and functions for accessing various fields in it. 3 | This can be useful, so I'm doing something similar here. 4 | 5 | (defstruct book title author subject book-id ) 6 | 7 | ~~~ 8 | {{ 9 | :make-helper (nsq-) [ d:create , ] dip does ; 10 | :make-struct (ns-) d:create , [ here swap fetch allot ] does ; 11 | ---reveal--- 12 | :defstruct (sa-) 13 | &s:keep dip dup a:length 14 | [ n:dec swap 15 | [ 'ab 'aabab reorder 16 | '@ s:append [ fetch + fetch ] make-helper 17 | '! s:append [ fetch + store ] make-helper 18 | n:dec 19 | ] a:for-each drop 20 | ] sip swap make-struct ; 21 | }} 22 | ~~~ 23 | 24 | ``` 25 | 'book { 'title 'author 'subject 'book-id } defstruct 26 | 27 | book 'A const 28 | 'The_Hobbit s:keep &A title! 29 | 'J.R.R._Tolkien s:keep &A author! 30 | 'Fantasy s:keep &A subject! 31 | 32 | :info (a-) 33 | [ subject@ ] [ author@ ] [ title@ ] tri 34 | '%s_by_%s_is_a_%s_book. s:format s:put nl ; 35 | 36 | &A info 37 | ``` 38 | -------------------------------------------------------------------------------- /example/delete-file.retro: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env retro 2 | 3 | This will delete the file specified on the command 4 | line. 5 | 6 | Example: 7 | 8 | ./delete-file.retro /tmp/foo 9 | 10 | ~~~ 11 | #0 script:get-argument file:delete 12 | ~~~ 13 | 14 | -------------------------------------------------------------------------------- /example/detect-devices.retro: -------------------------------------------------------------------------------- 1 | This will iterate over the attached devices, displaying a short 2 | description of each. 3 | 4 | ~~~ 5 | :id 6 | #0 [ 'generic-output s:put nl ] case 7 | #1 [ 'generic-input s:put nl ] case 8 | #2 [ 'floating-point s:put nl ] case 9 | #3 [ 'block-store s:put nl ] case 10 | #4 [ 'filesystem s:put nl ] case 11 | #5 [ 'clock s:put nl ] case 12 | #6 [ 'reserved s:put nl ] case 13 | #7 [ 'sockets s:put nl ] case 14 | #8 [ 'unix-syscalls s:put nl ] case 15 | #9 [ 'scripting s:put nl ] case 16 | #10 [ 'random-number-generator s:put nl ] case 17 | #1000 [ 'saving-image s:put nl ] case 18 | 'unknown:_ s:put n:put nl ; 19 | 20 | 'Detecting_devices... s:put nl 21 | io:enumerate [ $# c:put I dup n:put io:query nip tab id ] indexed-times 22 | 'Complete. s:put nl 23 | ~~~ 24 | -------------------------------------------------------------------------------- /example/dictionary-alias.retro: -------------------------------------------------------------------------------- 1 | The easiest way to make an alias is by 2 | 3 | :s2 s1 ; 4 | 5 | which adds a layer of `call`. 6 | `d:alias` eliminates this overhead. 7 | 8 | ~~~ 9 | {{ 10 | :d: (as-)_also_known_as 11 | d:create &class:word reclass d:last d:xt swap d:xt fetch swap store ; 12 | ---reveal--- 13 | :d:aka (s-)_make_alias_of_the_last_defined_word [ d:last ] dip d: ; 14 | 'aka d:aka 15 | :d:alias (ss-)_make_alias_s2_of_s1 [ d:lookup ] dip d: ; 'alias aka 16 | }} 17 | ~~~ 18 | 19 | ``` 20 | :t #8 + ; 'tt aka 21 | #9 tt 22 | 't 'ttt alias 23 | #10 ttt 24 | ``` 25 | -------------------------------------------------------------------------------- /example/dictionary-stats.retro: -------------------------------------------------------------------------------- 1 | It's sometimes interesting to take some measurements of dictionary names. 2 | 3 | Determine the number of words in the dictionary. 4 | 5 | ~~~ 6 | #0 [ drop n:inc ] d:for-each 7 | '%n_names_defined\n s:format s:put 8 | ~~~ 9 | 10 | Determine the average length of a word name. 11 | 12 | ~~~ 13 | #0 [ d:name s:length + ] d:for-each 14 | #0 [ drop n:inc ] d:for-each 15 | / 'Average_name_length:_%n\n s:format s:put 16 | ~~~ 17 | 18 | And without the namespaces... 19 | 20 | ~~~ 21 | #0 #0 [ d:name dup $: s:index/char n:inc + s:length + [ n:inc ] dip ] d:for-each swap / 22 | 'Average_name_without_namespace:_%n\n s:format s:put 23 | ~~~ 24 | 25 | Longest name are... 26 | 27 | ~~~ 28 | #0 [ d:name s:length n:max ] d:for-each 29 | 'Longest_names_are_%n_characters\n s:format s:put 30 | ~~~ 31 | -------------------------------------------------------------------------------- /example/display-word-location-information.retro: -------------------------------------------------------------------------------- 1 | # Display Word Information Upon Definition 2 | 3 | This uses the `script:current-file` and `script:current-line` words from 4 | the Unix implementation of RETRO to display some information about 5 | a word's location as the words are defined. 6 | 7 | Something similar could be used to generate a *tags* file or to 8 | populate a runtime database of location information. 9 | 10 | ~~~ 11 | [ (Display_the_word_name) 'abc 'abca reorder s:put tab 12 | (and_the_current_line_#) script:current-line n:put tab 13 | (and_the_current_file) script:current-file s:put nl 14 | (call_the_original_d:add-header) &d:add-header #2 + call ] 15 | 16 | &d:add-header set-hook 17 | ~~~ 18 | -------------------------------------------------------------------------------- /example/double.retro: -------------------------------------------------------------------------------- 1 | This is a vocabulary for working with double cell numeric 2 | values. By using two cells we can achieve a greater range 3 | than the standard 32-bit cells. This probably will not work 4 | correctly on a Retro with 64-bit cells unless you make some 5 | small changes (see the `dn:div` in particular). 6 | 7 | ~~~ 8 | '~res var 9 | 10 | :dn:h@ (D-n) fetch ; 11 | :dn:l@ (D-n) n:inc fetch ; 12 | :dn:h! (nD-) store ; 13 | :dn:l! (nD-) n:inc store ; 14 | 15 | :dn:new (-D) here #0 dup comma comma ; 16 | 17 | :dn:lows (DD-nn) [ dn:l@ ] bi@ ; 18 | :dn:highs (DD-nn) [ dn:h@ ] bi@ ; 19 | 20 | :dn:make (nn-D) here [ swap comma comma ] dip ; 21 | :dn:put fetch-next n:put sp fetch n:put nl ; 22 | 23 | :dn:add (DD-D) 24 | dn:new !~res 25 | dup-pair dn:lows n:add @~res dn:l! 26 | over @~res dn:lows gt? n:abs [ dn:highs n:add ] dip n:add 27 | @~res dn:h! 28 | @~res ; 29 | 30 | :dn:sub (DD-D) 31 | dn:new !~res 32 | dup-pair dn:lows n:sub @~res dn:l! 33 | over @~res dn:lows lt? n:abs [ dn:highs n:sub ] dip n:sub 34 | @~res dn:h! 35 | @~res ; 36 | 37 | :dn:mul (DD-D) 38 | dn:new !~res 39 | dup-pair dn:lows n:mul @~res dn:l! 40 | @~res dn:l@ n:negative? n:abs 41 | [ dup-pair 42 | [ dn:h@ ] [ dn:l@ ] bi* n:mul 43 | [ [ dn:l@ ] [ dn:h@ ] bi* n:mul ] dip n:add 44 | ] dip n:add 45 | @~res dn:h! 46 | @~res ; 47 | 48 | :dn:div (DD-D) 49 | dn:new !~res 50 | dup-pair dn:lows n:div @~res dn:l! 51 | dup-pair 52 | [ dn:h@ ] [ dn:l@ ] bi* n:div #-1 shift 53 | [ [ dn:l@ ] [ dn:h@ ] bi* n:mod #31 shift ] dip n:add 54 | @~res dn:h! 55 | @~res ; 56 | ~~~ 57 | -------------------------------------------------------------------------------- /example/echo.retro: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env retro 2 | 3 | This is a simple `echo` style example. 4 | 5 | ~~~ 6 | #0 script:arguments 7 | ~~~ 8 | 9 | Then a simple loop: 10 | 11 | - duplicate the argument number 12 | - get the argument as a string 13 | - display it, followed by a space 14 | - increment the argument number 15 | 16 | ~~~ 17 | [ dup script:get-argument s:put sp n:inc ] times 18 | ~~~ 19 | 20 | And at the end, discard the argument number and inject a 21 | newline. 22 | 23 | ~~~ 24 | drop nl 25 | ~~~ 26 | -------------------------------------------------------------------------------- /example/enum.retro: -------------------------------------------------------------------------------- 1 | # enumeration 2 | 3 | This is a method of creating a set of constants from names 4 | provided in an array. 5 | 6 | The approach was inspired by 8th[1], in which a short modifier 7 | allows setting the enum value at any time. In use this looks 8 | like: 9 | 10 | { 'a 'b=10 'c 'd=998 'e 'f 'g=33 } a:enum 11 | 12 | In this case: 13 | 14 | a is 0 15 | b is 10 16 | c is 11 17 | d is 998 18 | e is 999 19 | f is 1000 20 | g is 33 21 | 22 | Enumerations start at zero by default. 23 | 24 | # Code 25 | 26 | The approach used here is to iterate over strings in an array. 27 | If the string contains a `=`, split the string, convert the 28 | part after the `=` to a number, which will replace the enum 29 | value. It then creates a constant using the string and 30 | increments the counter. 31 | 32 | ~~~ 33 | :a:enum (a-) 34 | #0 swap 35 | [ dup $= s:contains/char? 36 | [ nip $= s:split/char [ n:inc s:to-number ] dip ] if 37 | over &const dip n:inc 38 | ] a:for-each drop ; 39 | ~~~ 40 | 41 | # Test 42 | 43 | ``` 44 | { 'a=10 'b 'c 'd=998 'e 'f } a:enum 45 | ``` 46 | 47 | # References 48 | 49 | [1] https://8th-dev.com/forum/index.php/topic,1979.msg11377.html 50 | -------------------------------------------------------------------------------- /example/evaluate-string.retro: -------------------------------------------------------------------------------- 1 | ## s:(evaluate) 2 | 3 | Show string being evaluated 4 | 5 | ~~~ 6 | :s:() (s-) nl '(_ s:prepend '_) s:append s:put nl ; 7 | :s:(evaluate) (s-) dup s:() s:evaluate nl ; 8 | ~~~ 9 | 10 | ``` 11 | :s:testing (s--) 'Testing_ s:prepend s:put nl ; 12 | 's:(evaluate) s:testing 13 | '#2_#3_#136_dump-stack s:(evaluate) 14 | 'reset_dump-stack s:(evaluate) 15 | ``` 16 | -------------------------------------------------------------------------------- /example/forth-style-comments.retro: -------------------------------------------------------------------------------- 1 | # Forth-style comments 2 | 3 | End-of-Comment `Eo(` is a char, `)` by default. 4 | If inconvenient, use some other char like 5 | 6 | $| !Eo( -( blah foo| 7 | 8 | Then `Eo(` is reverted to `)` . 9 | 10 | ~~~ 11 | 'Eo( var (end-of-comment_char 12 | {{ 13 | :parse (-s) [ @Eo( eq? ] parse-until ; 14 | :revert (-) $) !Eo( ; 15 | revert 16 | ---reveal--- 17 | :-( (c-) parse drop revert ; immediate 18 | :+( (c-) parse s:put nl revert ; immediate 19 | }} 20 | ~~~ 21 | 22 | ``` 23 | #0 -( #1 #2 ) $| !Eo( +( #3 #4 | #5 -( #6 #7 ) #8 24 | ``` 25 | -------------------------------------------------------------------------------- /example/fsl/cube-rt.forth: -------------------------------------------------------------------------------- 1 | \ Cube root of real number by Newton's method 2 | \ ANS compatible version V1.2 10/6/1994 3 | 4 | \ Forth Scientific Library Algorithm #5 5 | 6 | \ This code conforms with ANS requiring: 7 | \ The FLOAT and FLOAT EXT word sets 8 | \ Non STANDARD words 9 | \ : FTUCK ( F: x y -- y x y) FSWAP FOVER ; 10 | \ : F2* ( F: x -- 2x ) FDUP F+ ; 11 | \ : F**2 FDUP F* ; 12 | 13 | 14 | \ (c) Copyright 1994 Julian V. Noble. Permission is granted 15 | \ by the author to use this software for any application provided 16 | \ the copyright notice is preserved. 17 | 18 | 19 | 3 S>D D>F FCONSTANT F=3 20 | 21 | : X' ( F: N x -- x') 22 | FTUCK F**2 F/ FSWAP F2* F+ F=3 F/ ; 23 | 24 | \ The magic number 1E-8 needs no change, even when extended (80-bit) precision 25 | \ is needed. 26 | : CONVERGED? ( F: x' x x' --) ( -- f) 27 | F- FOVER F/ FABS 1.0E-8 F< ; 28 | 29 | : FCBRT ( F: N -- N^1/3) 30 | FDUP F0< FABS ( F: -- |N|) ( -- f) 31 | FDUP FSQRT ( F: -- N x0 ) 32 | BEGIN FOVER FOVER X' FTUCK CONVERGED? UNTIL 33 | X' IF FNEGATE THEN ; 34 | 35 | ~~~ 36 | :x' (f:nx-X) 37 | f:tuck f:dup f:* f:/ f:swap f:dup f:+ f:+ .3 f:/ ; 38 | 39 | :converged? (f:XxX-) (-f) 40 | f:- f:over f:/ f:abs .1.0e-8 f:lt? ; 41 | 42 | :fcbrt (f:n-[n^1/3]) 43 | f:dup .0 f:lt? f:abs 44 | f:dup f:sqrt 45 | [ f:over f:over x' f:tuck converged? ] until 46 | x' n:-zero? [ f:negate ] if ; 47 | ~~~ 48 | 49 | ~~~ 50 | .9 fcbrt f:put nl 51 | ~~~ 52 | 53 | -------------------------------------------------------------------------------- /example/fsl/logistic.forth: -------------------------------------------------------------------------------- 1 | \ logistic The Logistic function and its first derivative 2 | \ logistic = Exp( c + a x ) / (1 + Exp( c + a x ) ) 3 | \ d_logistic = a Exp( c + a x ) / (1 + Exp( c + a x ) )^2 4 | 5 | \ Forth Scientific Library Algorithm #4 6 | 7 | \ This code conforms with ANS requiring: 8 | \ 1. The Floating-Point word set 9 | \ 10 | 11 | \ (c) Copyright 1994 Everett F. Carter. Permission is granted by the 12 | \ author to use this software for any application provided this 13 | \ copyright notice is preserved. 14 | 15 | 16 | cr .( Logistic V1.2 17 October 1994 EFC ) 17 | 18 | 19 | : logistic ( --, f: x a c -- z ) 20 | FROT FROT 21 | F* F+ 22 | FEXP 23 | FDUP 1.0e0 F+ 24 | F/ 25 | ; 26 | 27 | : d_logistic ( -- , f: x a c -- z ) 28 | FSWAP FROT 29 | FOVER F* FROT F+ 30 | FEXP 31 | 32 | FDUP 1.0e0 F+ FDUP F* 33 | F/ F* 34 | ; 35 | 36 | \ Examples % 1.0 % 1.0 % 0.0 logistic f. 0.731059 37 | \ % 3.2 % 1.5 % 0.2 logistic f. 0.993307 38 | \ % 3.2 % 1.5 % 0.2 d_logistic f. 0.00997209 39 | 40 | # The Code 41 | 42 | ~~~ 43 | :logistic (-,f:xac-z) 44 | f:rot f:rot 45 | f:* f:+ 46 | f:E f:swap f:power 47 | f:dup .1.0e0 f:+ 48 | f:/ ; 49 | 50 | :d_logistic (-,f:xac-z) 51 | f:swap f:rot 52 | f:over f:* f:rot f:+ 53 | f:E f:swap f:power 54 | f:dup .1.0e0 f:+ f:dup f:* 55 | f:/ f:* ; 56 | ~~~ 57 | 58 | # Tests 59 | 60 | ``` 61 | .1.0 .1.0 .0.0 logistic f:put nl 62 | .3.2 .1.5 .0.2 logistic f:put nl 63 | ``` 64 | -------------------------------------------------------------------------------- /example/gcd.retro: -------------------------------------------------------------------------------- 1 | # example|GreatestCommonDivisor 2 | 3 | ~~~ 4 | :gcd (ab-n) 5 | [ tuck mod dup ] while drop ; 6 | ~~~ 7 | -------------------------------------------------------------------------------- /example/gopher.retro: -------------------------------------------------------------------------------- 1 | gopher:get 2 | 3 | Data: asns-n 4 | Addr: - 5 | Float: - 6 | 7 | Takes an address, a server, a port, and a selector. Fetch the 8 | resource and store it at address. Return the number of bytes 9 | received. 10 | 11 | Class: class:word | Namespace: gopher | Interface Layer: ios 12 | 13 | Example #1: 14 | 15 | here 'forthworks.com #70 '/ gopher:get 16 | here s:put 17 | 18 | 19 | ~~~ 20 | :set (asns-sns) 'abcd 'bcda reorder buffer:set ; 21 | :url (sns-s) 'abc 'cba reorder 'gopher://%s:%n/0%s s:format ; 22 | :command (s-s) 'curl_-s_%s s:format ; 23 | :connect (s-p) file:R unix:popen ; 24 | :read (p-p) [ dup file:read dup buffer:add n:zero? ] until ; 25 | :complete (p-n) unix:pclose buffer:end buffer:start - ; 26 | ---reveal--- 27 | :gopher:get (asns-n) 28 | [ set url command connect read complete ] buffer:preserve ; 29 | ~~~ 30 | 31 | ## Test Case 32 | 33 | ~~~ 34 | 'Data d:create #256001 allot 35 | &Data 'forthworks.com #70 '/retro gopher:get 36 | '%n_bytes_read\n s:format s:put 37 | ~~~ 38 | -------------------------------------------------------------------------------- /example/hanoi.retro: -------------------------------------------------------------------------------- 1 | The Tower of Hanoi (also called the Tower of Brahma or Lucas' Tower 2 | and sometimes pluralized) is a mathematical game or puzzle. It 3 | consists of three rods and a number of disks of different sizes, 4 | which can slide onto any rod. The puzzle starts with the disks in 5 | a neat stack in ascending order of size on one rod, the smallest 6 | at the top, thus making a conical shape. 7 | 8 | The objective of the puzzle is to move the entire stack to another 9 | rod, obeying the following simple rules: 10 | 11 | - Only one disk can be moved at a time. 12 | - Each move consists of taking the upper disk from one of the 13 | stacks and placing it on top of another stack. 14 | - No disk may be placed on top of a smaller disk. 15 | 16 | With 3 disks, the puzzle can be solved in 7 moves. The minimal 17 | number of moves required to solve a Tower of Hanoi puzzle is 18 | 2^n-1, where n is the number of disks. 19 | 20 | Taken from https://en.m.wikipedia.org/wiki/Tower_of_Hanoi 21 | 22 | ~~~ 23 | { 'Num 'From 'To 'Via } [ var ] a:for-each 24 | 25 | :set !Via !To !From !Num ; 26 | :display @To @From 'Move_a_ring_from_%n_to_%n\n s:format s:put ; 27 | 28 | :hanoi (num,from,to,via-) 29 | set @Num n:-zero? 30 | [ @Num @From @To @Via 31 | @Num n:dec @From @Via @To hanoi set display 32 | @Num n:dec @Via @To @From hanoi ] if ; 33 | 34 | #3 #1 #3 #2 hanoi nl 35 | ~~~ 36 | -------------------------------------------------------------------------------- /example/hiding-words.retro: -------------------------------------------------------------------------------- 1 | # Hiding Words 2 | 3 | It's often useful to be able to hide a word from the global 4 | dictionary. This can be done with the lexical scope words, 5 | but here I present a different approach. 6 | 7 | To hide a word, it is sufficient to change its name to 8 | something that will never be matched. Since strings are 9 | null terminated, just replacing the first character with 10 | a null suffices. 11 | 12 | So all that needs to be done is to create an array of headers 13 | we want to hide, then iterate over that to smudge out the 14 | names. 15 | 16 | # Code 17 | 18 | ~~~ 19 | 'To-Hide d:create #65 allot 20 | 21 | :private @Dictionary @To-Hide &To-Hide + n:inc store &To-Hide v:inc ; 22 | 23 | :hide-private 24 | &To-Hide [ d:name v:off ] a:for-each &To-Hide v:off ; 25 | ~~~ 26 | 27 | # Example 28 | 29 | ``` 30 | :a ; 31 | :b ; private 32 | :f ; private 33 | :c ; 34 | :d ; private 35 | :e ; 36 | 37 | hide-private 38 | ``` 39 | 40 | -------------------------------------------------------------------------------- /example/iOS/README.md: -------------------------------------------------------------------------------- 1 | This directory contains examples for the iOS implementation of RETRO. 2 | 3 | These are not tested on other platforms as they use iOS-specific I/O 4 | words. 5 | -------------------------------------------------------------------------------- /example/is-palindrome.retro: -------------------------------------------------------------------------------- 1 | # rosetta|is-palindrome 2 | 3 | A palindrome is a phrase which reads the same backward and forward. 4 | 5 | Write a function or program that checks whether a given sequence of 6 | characters (or, if you prefer, bytes) is a palindrome. 7 | 8 | 9 | In Retro this is fairly easy. We can use `s:hash` to identify a unique 10 | string. So make a copy, take he hash, reverse the copy, get its hash, 11 | and compare them. 12 | 13 | ~~~ 14 | :s:palindrome? (s-f) 15 | [ s:hash ] 16 | [ s:reverse s:hash ] bi eq? ; 17 | 18 | 'ingirumimusnocteetconsumimurigni s:palindrome? 19 | ~~~ 20 | -------------------------------------------------------------------------------- /example/is-pangram.retro: -------------------------------------------------------------------------------- 1 | A pangram is a sentence that uses all the letters in the alphabet. 2 | 3 | This is one way to determine if a sentence is a pangram using RETRO. 4 | 5 | First, define a string containing the alphabet: 6 | 7 | ~~~ 8 | 'abcdefghijklmnopqrstuvwxyz 'FULL s:const 9 | ~~~ 10 | 11 | Then a blank string of the same length for the test data: 12 | 13 | ~~~ 14 | '__________________________ 'TEST s:const 15 | ~~~ 16 | 17 | Now a word to do the actual test. 18 | 19 | ~~~ 20 | :s:pangram? (s-f) 21 | '__________________________ &TEST #26 copy 22 | s:to-lower [ c:letter? ] s:filter 23 | [ dup $a - &TEST + store ] s:for-each 24 | &TEST &FULL s:eq? ; 25 | ~~~ 26 | 27 | Breaking this down, the first line: 28 | 29 | '__________________________ &TEST #26 copy 30 | 31 | Copies a blank string over the TEST string. Then: 32 | 33 | s:to-lower [ c:letter? ] s:filter 34 | 35 | Converts the string to lowercase and strips out anything that's not a 36 | letter. Then a quick iteration over each character: 37 | 38 | [ dup $a - &TEST + store ] s:for-each 39 | 40 | Reduces the letter to an index into the TEST string and stores the 41 | letter at the appropriate spot. And finally: 42 | 43 | &TEST &FULL s:eq? ; 44 | 45 | Just compares the TEST and FULL strings to get the result. 46 | 47 | Here's a couple of test cases: 48 | 49 | ~~~ 50 | 'Hello_world! s:pangram? 51 | 'The_quick_brown_fox_jumped_over_the_lazy_dogs. s:pangram? 52 | ~~~ 53 | -------------------------------------------------------------------------------- /example/iterative-fibonacci.retro: -------------------------------------------------------------------------------- 1 | # example|IterativeFibonacci 2 | 3 | ~~~ 4 | :fib (n-m) 5 | [ #0 #1 ] dip 6 | [ over + swap ] times drop ; 7 | ~~~ 8 | -------------------------------------------------------------------------------- /example/json.retro: -------------------------------------------------------------------------------- 1 | This is a wrapper over `jq` (https://stedolan.github.io/jq/) to 2 | provide some access to JSON using RETRO. 3 | 4 | ~~~ 5 | {{ 6 | :input swap '/tmp/r.json file:spew ; 7 | :command 'cat_/tmp/r.json_|_jq_'%s'_>/tmp/r.json2 s:format ; 8 | :process unix:system here '/tmp/r.json2 file:slurp ; 9 | :results '/tmp/r.json '/tmp/r.json2 &file:delete bi@ here ; 10 | ---reveal--- 11 | :jq (ss-s) input command process results ; 12 | }} 13 | ~~~ 14 | 15 | With this, I can begin to parse JSON and do things with it. 16 | 17 | Import a JSON test set (`https://api.github.com/repos/stedolan/jq/commits?per_page=5`) 18 | 19 | ~~~ 20 | 'JSON d:create 21 | here 'test.json file:slurp here s:length n:inc !Heap 22 | ~~~ 23 | 24 | Extract the commit messages using `jq`. 25 | 26 | ~~~ 27 | JSON '.[]_|_{message:_.commit.message}_|_flatten jq s:temp 28 | ~~~ 29 | 30 | This leaves output like: 31 | 32 | [ 33 | "Improve jv_is_integer()" 34 | ] 35 | [ 36 | "Dockerfile: Change base image to Debian Stable" 37 | ] 38 | 39 | I can tokenize this and filter out the [ ] pairs: 40 | 41 | ~~~ 42 | ASCII:LF s:tokenize [ fetch [ $[ eq? ] [ $] eq? ] bi or not ] a:filter 43 | ~~~ 44 | 45 | And then display the resulting lines: 46 | 47 | ~~~ 48 | [ s:put nl ] a:for-each 49 | ~~~ 50 | -------------------------------------------------------------------------------- /example/least-common-multiple.retro: -------------------------------------------------------------------------------- 1 | # Least Common Multiple 2 | 3 | The least common multiple of two integers a and b, is the 4 | smallest positive integer that is divisible by both a and b. 5 | 6 | This implements a word to find this in RETRO. 7 | 8 | It uses a formula that reduces the problem to computing the 9 | greatest common divisor (gcd), as in: 10 | 11 | lcm(a,b) = |a*b| / gcd(a,b) 12 | 13 | ~~~ 14 | :gcd (ab-n) 15 | [ tuck mod dup ] while drop ; 16 | 17 | :lcm (ab-n) 18 | dup-pair gcd [ * ] dip / ; 19 | ~~~ 20 | -------------------------------------------------------------------------------- /example/light-weight-flow-control.retro: -------------------------------------------------------------------------------- 1 | # Lightweight Flow Control 2 | 3 | These were adapted from HerkForth. 4 | 5 | | 0=; | n- | exit word if TOS = 0 | 6 | | 0<>; | n- | exit word if TOS <> 0 | 7 | | <; | nn- | exit word if NOS < TOS | 8 | | >; | nn- | exit word if NOS > TOS | 9 | | <>; | nn- | exit word if NOS <> TOS | 10 | | if; | f- | exit word if TOS is TRUE | 11 | | ?; | f- | exit word if TOS is TRUE. Leave Flag on stack if TRUE. | 12 | 13 | ~~~ 14 | :0=; n:zero? [ as{ 'popopodr i 'drdrre.. i }as ] if ; 15 | :0<>; n:zero? [ as{ 'popopodr i 'drdrre.. i }as ] -if ; 16 | :<; lt? [ as{ 'popopodr i 'drdrre.. i }as ] if ; 17 | :>; gt? [ as{ 'popopodr i 'drdrre.. i }as ] if ; 18 | :<>; -eq? [ as{ 'popopodr i 'drdrre.. i }as ] if ; 19 | :if; [ as{ 'popopodr i 'drdrre.. i }as ] if ; 20 | :?; dup [ as{ 'popopodr i 'drdrre.. i }as ] if drop ; 21 | ~~~ 22 | 23 | # Tests 24 | 25 | ``` 26 | :test (n-) n:even? if; 'Odd! s:put nl ; 27 | 28 | #1 test 29 | #2 test 30 | ``` 31 | 32 | ``` 33 | nl '----------------- s:put nl 34 | :test (n-) n:even? ?; 'Odd! s:put nl ; 35 | #1 test dump-stack reset nl 36 | #2 test dump-stack reset nl 37 | ``` 38 | -------------------------------------------------------------------------------- /example/local-variables.retro: -------------------------------------------------------------------------------- 1 | # Local Variables 2 | 3 | RETRO does not provide local variables. Similar functionality 4 | can be achieved using globals along with the `v:preserve` 5 | combinator, but this can lead to ugly code. 6 | 7 | Consider: 8 | 9 | 'Counter var 10 | :average (...n-v) 11 | &Counter [ #0 !Counter 12 | [ + &Counter v:inc ] times @Counter / ] v:preserve ; 13 | :run-tests 14 | #0 !Counter 15 | #1 #2 #3 #4 #3 average n:put nl &Counter v:inc 16 | #10 #20 #30 #40 #3 average n:put nl &Counter v:inc 17 | #11 #21 #31 #41 #3 average n:put nl &Counter v:inc 18 | @Counter n:put sp '_tests_finished s:put nl ; 19 | 20 | run-tests 21 | 22 | The code implemented here allows for wrapping the most recent 23 | word within a `v:preserve` clause, letting the above definition 24 | of `test` become: 25 | 26 | :average (...n-v) 27 | #0 !Counter [ + &Counter v:inc ] times @Counter / ; 28 | &Counter make-local 29 | 30 | And if you need multiple variables to be localized: 31 | 32 | :average ... ; 33 | { &Array &Of &Variables } locals 34 | 35 | # The Code 36 | 37 | ~~~ 38 | :make-local (a-) 39 | here [ compile:lit 40 | d:last.xt compile:lit 41 | &v:preserve compile:call 42 | compile:ret ] dip d:last d:xt store ; 43 | 44 | :locals (a-) &make-local a:for-each ; 45 | ~~~ 46 | 47 | -------------------------------------------------------------------------------- /example/magic-8th-ball.retro: -------------------------------------------------------------------------------- 1 | This is based on Ron Aaron's "Magic 8th Ball" - CLI version. 2 | See https://8th-dev.com/forum/index.php/topic,1864.msg10733.html 3 | 4 | First is the list of responses. This is just an array. 5 | 6 | ~~~ 7 | { 'OK 8 | 'Yes 9 | 'Absolutely! 10 | 'Surely 11 | 'Perhaps 12 | 'Could_be 13 | 'Hard_to_say 14 | 'Maybe 15 | 'Unclear 16 | 'Ask_later 17 | 'Down_for_maintenance 18 | 'ABEND_12345 19 | 'No 20 | 'Definitely_not! 21 | 'Leave_me_alone 22 | } 'PROPHESIES const 23 | ~~~ 24 | 25 | To get a random prophecy: get the length of the array, a random 26 | number, and calculate an index based on these to fetch. 27 | 28 | ~~~ 29 | :prophesy (-s) 30 | PROPHESIES dup a:length n:random n:abs swap mod a:fetch ; 31 | ~~~ 32 | 33 | This finishes the core of the application. The remaining part is 34 | the user interface. RETRO doesn't have GUI bindings, so I'm only 35 | implementing the CLI interface. 36 | 37 | My approach is a little different from the original. I split the 38 | input "processing" into a separate word. RETRO doesn't have a 39 | null string, so I left out the check for that. Exit with CTRL+C. 40 | 41 | ~~~ 42 | :process-input (s-) 43 | s:empty [ 'C'mon,_don't_be_like_that!_Ask_a_question: s:put nl ] s:case 44 | drop prophesy '\nThe_8th_ball_says:\n\t%s\n\n s:format s:put 45 | '\nAsk_again_and_you_shall_be_answered:\n s:format s:put ; 46 | 47 | :8th-ball-cli (-) 48 | 'Ask_your_question_of_the_8th-ball.__Satisfaction_guaranteed! s:put nl 49 | repeat 50 | s:get process-input 51 | again ; 52 | ~~~ 53 | -------------------------------------------------------------------------------- /example/mail.retro: -------------------------------------------------------------------------------- 1 | This is a tiny wrapper over the `mail` application to allow 2 | sending emails from within RETRO. 3 | 4 | ~~~ 5 | :mail:send (sss-) 6 | swap 'mail_-s_"%s"_%s s:format file:W unix:popen 7 | swap [ over file:write ] s:for-each unix:pclose ; 8 | ~~~ 9 | 10 | # Send a Message 11 | 12 | ``` 13 | (Body 'This_is_a_test\n\nSending_mail_via_RETRO s:format 14 | (Subject 'Test 15 | (Recipient 'crc@forthworks.com 16 | mail:send 17 | ``` 18 | -------------------------------------------------------------------------------- /example/marker.retro: -------------------------------------------------------------------------------- 1 | Marker provides a way to quickly reset the dictionary and heap 2 | to the state it was in prior to the creation of the marker. 3 | 4 | ## The Code 5 | 6 | ~~~ 7 | :class:marker (a-) 8 | compiling? [ compile:lit &class:marker compile:call ] 9 | [ fetch-next !Dictionary fetch !Heap ] choose ; 10 | 11 | :marker (s-) [ @Heap @Dictionary ] dip d:create , , &class:marker reclass ; 12 | ~~~ 13 | 14 | ## A Test Case 15 | 16 | ``` 17 | :a #1 #2 #3 ; 18 | :b a + + ; 19 | :c b n:put nl ; 20 | c 21 | 'd marker 22 | :a #4 #5 #6 ; 23 | :b a + + ; 24 | :c b n:put nl ; 25 | c 26 | d 27 | c 28 | ``` 29 | -------------------------------------------------------------------------------- /example/matrix.retro: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env retro -i -s 2 | 3 | By WilhelmVonWeiner: Matrices that store their bounds and a 4 | couple rushedly written tests. 5 | 6 | ~~~ 7 | {{ 8 | :prepare (nms--knms) push dup-pair * rot rot pop ; 9 | :create (nms--) d:create dup-pair * #2 + allot ; 10 | :initialise (nm--) d:last.xt store-next store-next ; 11 | :fill (na--a) [ store-next ] times ; 12 | ---reveal--- 13 | :matrix (nms--a) create initialise ; 14 | :matrix (xn...x1nms-) prepare matrix swap fill drop ; 15 | }} 16 | ~~~ 17 | 18 | Test matrix, should print "matrix works!" and not "broken!". 19 | 20 | ``` 21 | :get-next n:dec dup fetch ; 22 | :broken 'broken s:put nl ; 23 | #3 #1 'tester matrix 24 | get-next #3 -eq? [ broken ] if 25 | get-next #1 -eq? [ broken ] if 26 | 'matrix_works!_at_ s:put n:put nl 27 | ``` 28 | 29 | Test matrix, should be "contained!" thrice. 30 | 31 | ``` 32 | #30 #20 #10 #3 #1 'tester matrix 33 | { tester #2 + #3 [ fetch-next swap ] times drop } 34 | [ { #10 #20 #30 } a:contains? [ 'contained! s:put sp nl ] if ] a:for-each 35 | ``` 36 | -------------------------------------------------------------------------------- /example/namespaces.retro: -------------------------------------------------------------------------------- 1 | This is a little set of words to create an array with all of the 2 | currently defined namespaces in a RETRO image. 3 | 4 | Three words will be exposed. 5 | 6 | Namespace Array, holds the namespace strings 7 | namespaces:identify Rebuild the array 8 | namespaces:put Display the namespaces 9 | 10 | ~~~ 11 | 'Namespaces d:create #513 allot 12 | 13 | {{ 14 | :has-namespace? dup $: s:contains/char? ; 15 | :get-namespace $: s:split nip ; 16 | :known? dup &Namespaces a:contains/string? ; 17 | :add s:keep buffer:add &Namespaces v:inc ; 18 | :process get-namespace known? &drop &add choose ; 19 | ---reveal--- 20 | :namespaces:identify 21 | [ &Namespaces buffer:set #0 buffer:add 22 | [ d:name has-namespace? &process &drop choose ] d:for-each 23 | ] buffer:preserve ; 24 | :namespaces:put &Namespaces [ s:put sp ] a:for-each ; 25 | }} 26 | ~~~ 27 | 28 | A quick test: 29 | 30 | ``` 31 | namespaces:identify 32 | namespaces:put nl 33 | ``` 34 | -------------------------------------------------------------------------------- /example/naming-quotes.retro: -------------------------------------------------------------------------------- 1 | # Naming Quotes 2 | 3 | Anonymous functions called quotes are used heavily by Retro. 4 | This shows a way to attach names to them. 5 | 6 | In a classic Forth, words are created using `:`, which is 7 | one of numerous parsing words. So a named function looks 8 | like: 9 | 10 | : foo ... ; 11 | 12 | In Retro, there are no parsing words. There is a sigil 13 | handler `:`, yielding: 14 | 15 | :foo ... ; 16 | 17 | Quotes start with `[` and end with `]`. So they look like: 18 | 19 | [ ... ] 20 | 21 | If we want to name a quote, we need to: 22 | 23 | - create a header 24 | - assign the xt field to the quote address 25 | - set the class handler 26 | 27 | This word, `def`, does these. 28 | 29 | ~~~ 30 | :def (as-) d:create d:last d:xt store &class:word reclass ; 31 | ~~~ 32 | 33 | An example of using this: 34 | 35 | ``` 36 | [ 'Hello_%s!\n s:format s:put ] 'hello def 37 | '#forth hello 38 | ``` 39 | -------------------------------------------------------------------------------- /example/net-fetch.retro: -------------------------------------------------------------------------------- 1 | # net:fetch 2 | 3 | This is a simple wrapper over `curl` (https://curl.haxx.se). It 4 | uses the `unix:popen` word to initiate a pipe to curl and stores 5 | the returned data into a buffer. 6 | 7 | This takes in three values: 8 | 9 | - the URL to fetch 10 | - the destination buffer 11 | - a maximum number of bytes to read 12 | 13 | The buffer should be at least one cell longer than the max to 14 | allow for the NULL termination. 15 | 16 | ## The Code 17 | 18 | ~~~ 19 | :net:fetch (san-n) 20 | [ [ buffer:set 21 | 'curl_-s_%s s:format file:R unix:popen ] dip 22 | [ dup file:read 0; buffer:add ] times unix:pclose 23 | buffer:start s:length ] buffer:preserve ; 24 | ~~~ 25 | 26 | ## Test Case 27 | 28 | ``` 29 | 'Data d:create #256001 allot 30 | 'gopher://forthworks.com &Data #300009 net:fetch 31 | '%n_bytes_read\n s:format s:put 32 | ``` 33 | -------------------------------------------------------------------------------- /example/numeric-ranges.retro: -------------------------------------------------------------------------------- 1 | This implements some words to return a range of numbers on the stack. 2 | It's probably best to capture these values in an array. 3 | 4 | First is a word to return values from a lower to upper limit, incrementing 5 | upwards. The returned values are inclusive of the limits. 6 | 7 | ~~~ 8 | :range-inc (lh-a) 9 | over - n:inc [ I over + swap ] indexed-times drop ; 10 | ~~~ 11 | 12 | Next is a word to return values from an upper to lower limit, decrementing 13 | upwards. The returned values are inclusive of the limits. 14 | 15 | ~~~ 16 | :range-dec (hl-a) 17 | over &- dip swap n:inc [ I over swap - swap ] indexed-times drop ; 18 | ~~~ 19 | 20 | The last word takes the limits and calls the appropriate word. 21 | 22 | ~~~ 23 | :range (nn-a) 24 | dup-pair gt? [ range-dec ] [ range-inc ] choose ; 25 | ~~~ 26 | 27 | As a simple test case: 28 | 29 | ``` 30 | { #1 #5 range } [ n:put sp ] a:for-each 31 | ``` 32 | -------------------------------------------------------------------------------- /example/parse-ups.retro: -------------------------------------------------------------------------------- 1 | This code parses a UPS Type 1Z tracking number and returns the 2 | subsections in a readable format. 3 | 4 | See http://osiris.978.org/~alex/ups.html for a list of service codes. 5 | 6 | ~~~ 7 | :valid? [ #0 #2 s:substr '1Z s:eq? ] sip swap ; 8 | :account [ #2 #6 s:substr 'Account:_ swap s:append ] sip ; 9 | :service-code [ #8 #2 s:substr 'Service_code:_ swap s:append ] sip ; 10 | :package-id [ #10 #7 s:substr 'Package_ID:_ swap s:append ] sip ; 11 | :checksum #17 + 'Checksum:_ swap s:append ; 12 | :parse-ups 13 | valid? [ account service-code package-id checksum 14 | #4 [ s:put nl ] times ] 15 | [ drop 'invalid_tracking_number s:put nl ] choose ; 16 | ~~~ 17 | 18 | ``` 19 | '1Z6x36270342495730 parse-ups 20 | ``` 21 | -------------------------------------------------------------------------------- /example/paste-to-sprunge.retro: -------------------------------------------------------------------------------- 1 | # Paste to Sprunge 2 | 3 | sprunge.us is a command line pastebin services. It's 4 | normally used like: 5 | 6 | | curl -F 'sprunge=<-' http://sprunge.us 7 | 8 | This is a wrapper for sharing snippits from within 9 | RETRO. 10 | 11 | ## The Code 12 | 13 | ~~~ 14 | {{ 15 | :write '/tmp/rx.paste file:spew ; 16 | :curl 'curl_-s_-F_'sprunge= 5 | dup #1 -eq? 0; drop 6 | dup n:dec * ; 7 | 8 | :factorial 9 | dup n:zero? 10 | [ n:inc ] 11 | [ ] choose ; 12 | ~~~ 13 | 14 | -------------------------------------------------------------------------------- /example/recursive-fibonacci.retro: -------------------------------------------------------------------------------- 1 | # example|RecursiveFibonacci 2 | 3 | ~~~ 4 | :fib (n-m) 5 | dup 6 | [ n:zero? ] [ #1 eq? ] bi or 7 | not 0; drop 8 | [ n:dec fib ] sip 9 | [ #2 - fib ] call + ; 10 | ~~~ 11 | -------------------------------------------------------------------------------- /example/retro-locate.retro: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env retro 2 | 3 | ~~~ 4 | 'Line var 5 | :parse (s-a) ASCII:HT s:tokenize dup !Line ; 6 | :word (-s) #0 script:get-argument ; 7 | :match? (a-f) #0 a:fetch word s:eq? ; 8 | :fields (-ss) @Line [ #2 a:fetch ] [ #1 a:fetch ] bi ; 9 | :display (-) fields s:put $: c:put s:put nl ; 10 | 'tags [ &Heap [ parse match? [ display ] if ] v:preserve ] file:for-each-line 11 | ~~~ 12 | -------------------------------------------------------------------------------- /example/retro-unu.retro: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env retro 2 | 3 | # Unu 4 | 5 | unu 6 | (verb) (-hia) pull out, withdraw, draw out, extract. 7 | 8 | Unu is a tool for extracting fenced code blocks from Markdown 9 | documents. 10 | 11 | I always found documenting my projects annoying. Eventually I 12 | decided to start mixing the code and commentary using Markdown. 13 | Unu is the tool I use to extract the sources from the original 14 | files. I've found that this makes it easier for me to keep the 15 | commentary up to date, and has lead to better commented code. 16 | 17 | ## The Code 18 | 19 | ~~~ 20 | {{ 21 | 'Fenced var 22 | :toggle-fence @Fenced not !Fenced ; 23 | :fenced? (-f) @Fenced ; 24 | :handle-line (s-) 25 | fenced? [ over call ] [ drop ] choose ; 26 | ---reveal--- 27 | :unu (sq-) 28 | swap [ dup '~~~ s:eq? 29 | [ drop toggle-fence ] 30 | [ handle-line ] choose 31 | ] file:for-each-line drop ; 32 | }} 33 | 34 | #0 script:get-argument [ s:put nl ] unu 35 | ~~~ 36 | 37 | ## Commentary 38 | 39 | The basic process for this is simple: 40 | 41 | - Read a line from a file 42 | - If the line is a fence (~~~) boundary, toggle the fence state 43 | - If not a fence boundary and the fence state is true process the 44 | line 45 | - Repeat until done 46 | 47 | The C implementation displays the lines to *stdout*. For this I 48 | decided that the `unu` word should be a combinator. This makes 49 | it easy to use as the basis for other tools. (See 50 | *example/retro-muri.forth* as a demonstration of this) 51 | -------------------------------------------------------------------------------- /example/retro.blocks.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/crcx/retroforth/9a940927934389760261b0d9ebff16765443b3c0/example/retro.blocks.gz -------------------------------------------------------------------------------- /example/rfc865.retro: -------------------------------------------------------------------------------- 1 | This implements a simple socket based server for RFC865, the "Quote of 2 | the Day Protocol". 3 | 4 | ~~~ 5 | 'Socket var 6 | 7 | {{ 8 | 'Sock var 9 | 'Quote var 10 | :if-failed swap [ 'ERROR:_ s:put s:put nl bye ] &drop choose ; 11 | :bind n:to-string @Sock socket:bind drop 'binding_to_port if-failed ; 12 | :listen #5 @Sock socket:listen drop 'preparing_socket if-failed ; 13 | :accept @Sock socket:accept n:-zero? 'accept_failed if-failed ; 14 | :send '_ [ store ] sip @Socket socket:send drop-pair ; 15 | :remap &send &c:put set-hook ; 16 | :unmap &c:put unhook ; 17 | :process [ remap !Socket @Quote call reset unmap ] sip socket:close ; 18 | ---reveal--- 19 | :server:for-each-connection (nq-) 20 | !Quote socket:create !Sock 21 | bind listen repeat accept process again ; 22 | }} 23 | ~~~ 24 | 25 | A test case, sending a message and the time to the user. 26 | 27 | ~~~ 28 | #9999 [ here '/etc/motd file:slurp here s:put ] server:for-each-connection 29 | ~~~ 30 | -------------------------------------------------------------------------------- /example/rfc867.retro: -------------------------------------------------------------------------------- 1 | This implements a simple socket based server for RFC867, the "Daytime 2 | Protocol". 3 | 4 | ~~~ 5 | 'Socket var 6 | 7 | {{ 8 | 'Sock var 9 | 'Quote var 10 | :if-failed swap [ 'ERROR:_ s:put s:put nl bye ] &drop choose ; 11 | :bind n:to-string @Sock socket:bind drop 'binding_to_port if-failed ; 12 | :listen #5 @Sock socket:listen drop 'preparing_socket if-failed ; 13 | :accept @Sock socket:accept n:-zero? 'accept_failed if-failed ; 14 | :send '_ [ store ] sip @Socket socket:send drop-pair ; 15 | :remap &send &c:put set-hook ; 16 | :unmap &c:put unhook ; 17 | :process [ remap !Socket @Quote call reset unmap ] sip socket:close ; 18 | ---reveal--- 19 | :server:for-each-connection (nq-) 20 | !Quote socket:create !Sock 21 | bind listen repeat accept process again ; 22 | }} 23 | ~~~ 24 | 25 | ~~~ 26 | :now clock:second clock:minute clock:hour clock:day clock:month clock:year 27 | '%n-%n-%n__%n:%n:%n\n s:format ; 28 | 29 | #13 [ now s:put ] server:for-each-connection 30 | ~~~ 31 | -------------------------------------------------------------------------------- /example/rot13.retro: -------------------------------------------------------------------------------- 1 | ROT13 ("rotate by 13 places", sometimes hyphenated ROT-13) is a simple 2 | letter substitution cipher that replaces a letter with the letter 13 3 | letters after it in the alphabet. ROT13 is a special case of the Caesar 4 | cipher, developed in ancient Rome. 5 | 6 | Because there are 26 letters (21^3) in the basic Latin alphabet, ROT13 7 | is its own inverse; that is, to undo ROT13, the same algorithm is 8 | applied, so the same action can be used for encoding and decoding. The 9 | algorithm provides virtually no cryptographic security, and is often 10 | cited as a canonical example of weak encryption. 11 | 12 | (Taken from https://en.m.wikipedia.org/wiki/ROT13) 13 | 14 | This is an implementation of ROT13 in RETRO. 15 | 16 | ~~~ 17 | 'nopqrstuvwxyzabcdefghijklm 'MAP s:const 18 | :encode (c-c) $a - MAP + fetch ; 19 | :rot13 (s-s) s:to-lower [ dup c:letter? [ encode ] if ] s:map ; 20 | ~~~ 21 | -------------------------------------------------------------------------------- /example/safety-net.retro: -------------------------------------------------------------------------------- 1 | This implements a sort of "safety net", adding some compile and runtime 2 | error checking and reporting. 3 | 4 | 5 | The first of these is to extend the `@` and `!` sigils to check for 6 | the existence of a word name. In a basic image, if the name isn't found, 7 | it will resolve to address 0 silently. This will have it report an error 8 | if the word is not found. 9 | 10 | ~~~ 11 | :err:var-not-defined 12 | '\nERROR:_variable_%s_not_defined\n s:format s:put bye ; 13 | 14 | :if:not-defined (sq-s) 15 | over d:lookup n:zero? swap if ; 16 | 17 | :sigil:@ 18 | [ err:var-not-defined ] if:not-defined 19 | d:lookup d:xt fetch class:data |fetch ; immediate 20 | 21 | :sigil:! 22 | [ err:var-not-defined ] if:not-defined 23 | d:lookup d:xt fetch class:data |store ; immediate 24 | ~~~ 25 | -------------------------------------------------------------------------------- /example/sandboxed-dictionary.retro: -------------------------------------------------------------------------------- 1 | # Sandboxed Dictionaries 2 | 3 | This implements some words to create a sandboxed dictionary and 4 | to execute a word or quotation within the sandbox. 5 | 6 | # Making A Sandboxed Dictionary 7 | 8 | The dictionary is structured as a linked list. To make a new one, 9 | I take an array with the names from the global dictionary, extract 10 | the header fields for each, and make a new list using them. 11 | 12 | The `make-dict` will return a pointer to the last entry in the new 13 | dictionary. 14 | 15 | ~~~ 16 | {{ 17 | 'D var 18 | :unpack (d-saa) 19 | d:lookup [ d:name ] [ d:class fetch ] [ d:xt fetch ] tri ; 20 | :add-header (saa-) 21 | here [ @D , , , s, ] dip !D ; 22 | ---reveal--- 23 | :make-dict (a-a) 24 | #0 !D [ unpack add-header ] a:for-each @D ; 25 | }} 26 | ~~~ 27 | 28 | The `{ ... } make-dict` can be wrapped in something to make this 29 | a little more obvious. 30 | 31 | ~~~ 32 | :dict{ (-) |{ ; immediate 33 | :}dict (-a) |} |make-dict ; immediate 34 | ~~~ 35 | 36 | # Using The Sandboxed Dictionary 37 | 38 | I implement a very simple `d:with` to run a quote with a 39 | sandboxed dictionary. This works by temporarily replacing 40 | the global dictionary with the sandboxed one. 41 | 42 | ~~~ 43 | :d:with (qa-) 44 | &Dictionary [ !Dictionary call ] v:preserve ; 45 | ~~~ 46 | 47 | # A Test Case 48 | 49 | This will expose a dictionary with just two words that can be 50 | used with a new `%` sigil. 51 | 52 | ``` 53 | {{ 54 | :swap $A ; 55 | :dup $B ; 56 | dict{ 'swap 'dup }dict 'SANDBOX const 57 | ---reveal--- 58 | :sigil:% (s) [ s:evaluate c:put ] SANDBOX d:with ; 59 | }} 60 | 61 | #70 dup swap 62 | %swap %dup 63 | n:put n:put 64 | nl bye 65 | ``` 66 | -------------------------------------------------------------------------------- /example/save-and-restore-stack.retro: -------------------------------------------------------------------------------- 1 | # Save and Restore Stack 2 | 3 | It's sometimes useful to temporarily save and restore the entire 4 | stack. These two words allow for this. 5 | 6 | ## The Code 7 | 8 | ~~~ 9 | :stack:save (-a) 10 | here [ depth dup , &, times ] dip ; 11 | 12 | :stack:restore (a-) 13 | &reset dip 14 | dup fetch over + swap fetch [ dup fetch swap n:dec ] times drop ; 15 | ~~~ 16 | 17 | ## Test Case 18 | 19 | ``` 20 | #1 #2 #3 #4 #5 21 | stack:save #3 swap stack:restore 22 | ``` 23 | -------------------------------------------------------------------------------- /example/sea-level-rise.retro: -------------------------------------------------------------------------------- 1 | This is a small thing to calculate the potential impact of ice cap melt 2 | on the global sea level. 3 | 4 | ~~~ 5 | :ice:ANTARTIC .26.54 .1000000 f:* ; (from_the_bedrock2_survey 6 | :ice:GREENLAND .2900000 ; (from_web.viu.ca/earle/geol305 7 | :ice:total ice:ANTARTIC ice:GREENLAND f:+ ; 8 | :ice:rise ice:total .361 f:/ ; 9 | :ice:rise ice:rise .1000 f:/ ; 10 | :ice:rise ice:rise .0.91 f:* ; 11 | 12 | ice:total 'Total_volume_(km^3):_ s:put f:put nl 13 | ice:rise 'Rise_(mm):___________ s:put f:put nl 14 | ice:rise 'Rise_(m):____________ s:put f:put nl nl 15 | 16 | ice:rise 'Rise_(m,_adjusted_for_density):_ s:put f:put nl 17 | ~~~ 18 | 19 | Output: 20 | 21 | Total volume (km^3): 29440000.000000 22 | Rise (mm): 81551.246537 23 | Rise (m): 81.551247 24 | 25 | Rise (m, adjusted for density): 74.211634 26 | 27 | Sources: 28 | 29 | - bedrock2 survey: https://www.the-cryosphere.net/7/375/2013/tc-7-375-2013.pdf 30 | - greenland ice: https://web.viu.ca/earle/geol305/The%20Greenland%20Ice%20Sheet.pdf 31 | - sea level rise: https://www.realworldvisuals.com/blog-1/could-rocks-cause-sea-levels-to-rise 32 | -------------------------------------------------------------------------------- /example/select.retro: -------------------------------------------------------------------------------- 1 | Select will discard one of two values based on a passed 2 | flag. 3 | 4 | ~~~ 5 | :select (abf-) &drop &nip choose ; 6 | ~~~ 7 | 8 | ``` 9 | #100 #200 TRUE select n:put nl 10 | #100 #200 FALSE select n:put nl 11 | ``` 12 | -------------------------------------------------------------------------------- /example/share.retro: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env retro 2 | 3 | This is a small tool I wrote to let me quickly share code on IRC 4 | or via other channels. 5 | 6 | First, get the MD5 of the source. Start by construting a pipe: 7 | 8 | ~~~ 9 | #0 script:get-argument 'md5_%s s:format file:R unix:popen 'FID const 10 | ~~~ 11 | 12 | Then read in until past the prolog (MD5 filename = ...): 13 | 14 | ~~~ 15 | [ FID file:read $= eq? ] until FID file:read drop 16 | ~~~ 17 | 18 | And then read in the sum and close the pipe. The sum in kept 19 | in a string constant MD5. 20 | 21 | ~~~ 22 | #1000 [ FID file:read , ] here × dip s:chop 'MD5 s:const 23 | FID unix:pclose 24 | ~~~ 25 | 26 | Next, I construct string constants for the destination file 27 | and URL's for Gopher and HTTPS. 28 | 29 | ~~~ 30 | MD5 '/home/crc/public/share/%s s:format 'DEST s:const 31 | MD5 'http://forth.works/share/%s s:format 'HTTP s:const 32 | MD5 'gopher://forth.works/0/share/%s s:format 'GOPH s:const 33 | ~~~ 34 | 35 | Then copy the source file to the destination directory. 36 | 37 | ~~~ 38 | here #0 script:get-argument file:slurp here DEST file:spew 39 | ~~~ 40 | 41 | And finally display the URL's. 42 | 43 | ~~~ 44 | HTTP s:put nl 45 | GOPH s:put nl 46 | ~~~ 47 | -------------------------------------------------------------------------------- /example/shared.retro: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env retro 2 | 3 | This is a little server for the pastebin. Use it with inetd or similar: 4 | 5 | gopher stream tcp nowait/6/30/2 nope /home/crc/retro/example/shared.forth 6 | http stream tcp nowait/6/30/2 nope /home/crc/retro/example/shared.forth 7 | 8 | It understands HTTP and Gopher, so can work for either. Use it with the 9 | `share.forth` tool. 10 | 11 | ~~~ 12 | s:get 'REQUEST s:const 13 | 14 | :http? REQUEST #0 #3 s:substr 'GET s:eq? ; 15 | :extract REQUEST #32 s:tokenize #2 + fetch ; 16 | :ok 'HTTP/1.0_200_OK\n s:format s:put ; 17 | :mime 'Content-type:_text/plain\n\n s:format s:put ; 18 | :file '/home/crc/public%s s:format ; 19 | :read here swap file:slurp here ; 20 | :missing drop 'Selector_not_found. ; 21 | :get dup file:exists? [ read ] if; missing ; 22 | :http ok mime extract file get s:put ; 23 | :gopher REQUEST file get s:put ; 24 | :serve http? [ http ] if; gopher ; 25 | 26 | serve 27 | ~~~ 28 | -------------------------------------------------------------------------------- /example/socket-client.retro: -------------------------------------------------------------------------------- 1 | This uses the new `socket:` words to download a file via Gopher. 2 | 3 | Open a file to store the data and a socket. 4 | 5 | ~~~ 6 | 'Output.txt file:open-for-writing 'File var-n 7 | socket:create dup n:put nl 'Sock var-n 8 | ~~~ 9 | 10 | Connect to the server. 11 | 12 | ~~~ 13 | 'forthworks.com '70 socket:configure 14 | @Sock socket:connect drop 15 | ~~~ 16 | 17 | Next, send the request. 18 | 19 | ~~~ 20 | '/\n\n s:format @Sock socket:send drop-pair 21 | ~~~ 22 | 23 | After this, I can just read in the data, writing it to 24 | the file. 25 | 26 | ~~~ 27 | [ here #1024 @Sock socket:recv (discard_errno: drop 28 | here [ @File file:write ] s:for-each 29 | dup '%n_bytes_received\n s:format s:put 30 | (check_for_disconnect: n:zero? ] until 31 | ~~~ 32 | 33 | And finally, clean up by closing the socket and file. 34 | 35 | ~~~ 36 | @Sock socket:close 37 | @File file:close 38 | ~~~ 39 | -------------------------------------------------------------------------------- /example/socket-server.retro: -------------------------------------------------------------------------------- 1 | Get a socket. 2 | 3 | ~~~ 4 | socket:create 'Sock var-n 5 | ~~~ 6 | 7 | Bind to port 9998. 8 | 9 | ~~~ 10 | '9998 @Sock socket:bind drop-pair 11 | ~~~ 12 | 13 | Prepare to listen for connections. 14 | 15 | ~~~ 16 | #3 @Sock socket:listen drop-pair 17 | ~~~ 18 | 19 | Serve the user some data. 20 | 21 | ~~~ 22 | [ @Sock socket:accept (discard_error_code: drop ) 23 | 'Hello_from_RETRO\n s:format swap [ socket:send drop-pair ] sip socket:close 24 | ] forever 25 | ~~~ 26 | 27 | Clean up. 28 | 29 | ~~~ 30 | @Sock socket:close 31 | ~~~ 32 | -------------------------------------------------------------------------------- /example/sort-on-stack.retro: -------------------------------------------------------------------------------- 1 | # Sorting Numbers on the Stack 2 | 3 | This is a recursive approach to sorting values on the stack. I 4 | won't try to claim that this is efficient, but it works. 5 | 6 | ~~~ 7 | :sort-pair dup-pair lt? &swap if ; 8 | :perform-sort sort-pair depth #2 gt? [ &perform-sort dip ] if ; 9 | :sort depth &perform-sort times ; 10 | ~~~ 11 | 12 | ``` 13 | #3 #33 #22 #333 #5 sort 14 | ``` 15 | -------------------------------------------------------------------------------- /example/sqlite3/test.db: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/crcx/retroforth/9a940927934389760261b0d9ebff16765443b3c0/example/sqlite3/test.db -------------------------------------------------------------------------------- /example/sqlite3/test.forth: -------------------------------------------------------------------------------- 1 | This is a test case, using an sqlite3 database to track time off 2 | requests at my employer. 3 | 4 | The database schema is: 5 | 6 | CREATE TABLE pto(id integer primary key, 7 | month blob, start blob, end blob, year blob, who blob, 8 | reason blob, status blob); 9 | 10 | 11 | Requests are a range, with a start and ending day. Requests for a single 12 | day off have identical start and end days. 13 | 14 | ~~~ 15 | 'sql.forth include (include_the_sqlite3_wrapper 16 | 'test.db sql:set-database (set_the_database_file 17 | 'pto sql:accessors-for (generate_accessors_for_each_column_in_"pto" 18 | ~~~ 19 | 20 | I can query for approved requests (status=y) in the current month. 21 | 22 | ~~~ 23 | [ 'pto FROM '* SELECT 'status="y"_AND_month=5_ORDER_BY_start WHERE ] sql:statement sql:query 24 | ~~~ 25 | 26 | And then iterate over the results, generating some readable output like: 27 | 28 | Charles Childers 29 | From: 2019-4-18 through 2019-4-22 30 | 31 | (This part should be refactored to aid in readability, but this works 32 | ok for a quick test.) 33 | 34 | ~~~ 35 | [ sql:split-line 36 | dup pto:who s:put nl 37 | [ &pto:start &pto:month &pto:year tri 38 | '\tFrom:_%s-%s-%s_through_ s:format s:put ] sip 39 | [ &pto:end &pto:month &pto:year tri 40 | '%s-%s-%s\n s:format s:put ] sip 41 | drop ] a:for-each 42 | ~~~ 43 | -------------------------------------------------------------------------------- /example/strip-html.retro: -------------------------------------------------------------------------------- 1 | This is a quick little tool to strip some HTML and leave text behind. 2 | 3 | It's not factored, and doesn't filter blocks that don't exactly match 4 | the tags listed in the code. It's still useful for quick looks, and 5 | may serve as a starting point for something more useful later on. 6 | 7 | ~~~ 8 | 'Tag d:create #1025 allot 9 | 'In-Tag var 10 | 11 | #0 script:get-argument file:open-for-reading swap 12 | [ dup file:read 13 | $< [ &Tag buffer:set &In-Tag v:on ] case 14 | $> [ &Tag 'head [ here buffer:set ] s:case 15 | 'title [ here buffer:set ] s:case 16 | 'script [ here buffer:set ] s:case 17 | 'script_type="text/javascript" [ here buffer:set ] s:case 18 | 'style [ here buffer:set ] s:case 19 | drop &In-Tag v:off ] case 20 | @In-Tag [ buffer:add ] [ c:put ] choose ] times 21 | file:close 22 | ~~~ 23 | -------------------------------------------------------------------------------- /example/tokenize-string.retro: -------------------------------------------------------------------------------- 1 | If you want to tokenize a string into a set, this is one approach. 2 | 3 | ~~~ 4 | {{ 5 | 'Split-On var 6 | :match? (c-f) @Split-On eq? ; 7 | :terminate (s-s) #0 over n:dec store ; 8 | :step (ss-s) [ n:inc ] dip match? [ dup , terminate ] if ; 9 | ---reveal--- 10 | :s:tokenize (sc-a) 11 | !Split-On s:keep 12 | here #0 , [ dup , dup [ step ] s:for-each drop ] dip 13 | here over - n:dec over store ; 14 | }} 15 | ~~~ 16 | 17 | -------------------------------------------------------------------------------- /example/top-of-address-stack.retro: -------------------------------------------------------------------------------- 1 | Short for *top of return stack*, this returns the top item on the 2 | address stack. As an analog to traditional Forth, this is equivilent 3 | to `R@`. 4 | 5 | ~~~ 6 | :tors (-n) pop pop dup push swap push ; 7 | ~~~ 8 | -------------------------------------------------------------------------------- /example/unicode.retro: -------------------------------------------------------------------------------- 1 | RETRO tries to allow names to use unicode via UTF-8. 2 | 3 | ~~~ 4 | 'Δ var 5 | #1 !Δ 6 | @Δ n:put nl 7 | ~~~ 8 | 9 | Display the last defined word (the variable defined above): 10 | 11 | ~~~ 12 | @Dictionary d:name s:put nl 13 | ~~~ 14 | -------------------------------------------------------------------------------- /example/unix-does-user-exist.retro: -------------------------------------------------------------------------------- 1 | This implements a word to determine if a user exists. This is done by 2 | parsing the results of `finger`. 3 | 4 | ~~~ 5 | :pipe> (s-s) file:R unix:popen [ file:read-line ] [ unix:pclose ] bi ; 6 | 7 | {{ 8 | :command 'finger_%s_2>&1 s:format ; 9 | :parse ASCII:SPACE s:tokenize ; 10 | :login? #0 a:th fetch 'Login: s:eq? ; 11 | ---reveal--- 12 | :user:exists? (s-f) 13 | &Heap [ command pipe> parse login? ] v:preserve ; 14 | }} 15 | 16 | 'crc user:exists? 17 | 'fakeuser user:exists? 18 | 'root user:exists? 19 | ~~~ 20 | 21 | A second way is to parse the `/etc/passwd` file. 22 | 23 | ~~~ 24 | {{ 25 | :setup (s-fs) FALSE swap ': s:append s:keep ; 26 | :match? (fss-fsf) over s:begins-with? ; 27 | :found (fs-fs) drop-pair TRUE s:empty s:keep ; 28 | :check (fss-fs) match? [ found ] if ; 29 | :seek (fs-fs) '/etc/passwd [ check ] file:for-each-line ; 30 | ---reveal--- 31 | :user:exists? (s-f) 32 | &Heap [ setup seek drop ] v:preserve ; 33 | }} 34 | 35 | 'crc user:exists? 36 | 'fakeuser user:exists? 37 | 'root user:exists? 38 | ~~~ 39 | -------------------------------------------------------------------------------- /example/unsigned.retro: -------------------------------------------------------------------------------- 1 | This is a vocabulary for doing some basic operations on unsigned 2 | numbers. 3 | 4 | ~~~ 5 | :u:patch (n-n) 6 | dup n:negative? 7 | [ #2147483647 n:add n:inc swap #-2147483648 n:sub n:add ] if ; 8 | 9 | :u:add (nn-n) n:add u:patch ; 10 | :u:sub (nn-n) n:sub u:patch ; 11 | :u:mul (nn-n) n:mul u:patch ; 12 | :u:div (nn-n) 13 | dup n:zero? [ drop-pair n:MAX ] [ n:div u:patch ] choose ; 14 | :u:mod (nn-n) 15 | dup n:zero? [ drop-pair n:MAX ] [ n:mod u:patch ] choose ; 16 | 17 | :u:eq? (nn-f) or not ; 18 | :u:-eq? (nn-f) u:eq? not ; 19 | :u:lt? (nn-f) over or and n:negative? ; 20 | :u:gt? (nn-f) tuck or and n:negative? ; 21 | ~~~ 22 | -------------------------------------------------------------------------------- /example/vocabulary.retro: -------------------------------------------------------------------------------- 1 | # An Experiment in Vocabularies 2 | 3 | Retro provides a single dictionary. By convention, we use short 4 | prefixes for namespaces and have some limited ability to hide 5 | definitions using `{{`, `---reveal---`, and `}}`. But it's 6 | sometimes nice to be able to hide words and reveal them only 7 | when actually needed. 8 | 9 | These words provide a minimal form of vocabulary by allowing 10 | temporarily relinking the main dictionary to follow a different 11 | path. The idea is to provide a word that points to a data stru- 12 | cture with the current Dictonary pointer. When in use, the main 13 | Dictionary is relinked to this, and when closed, the stored 14 | pointer is updated. 15 | 16 | ~~~ 17 | {{ 18 | 'a var 'b var 19 | ---reveal--- 20 | :forth (-) @b @a @Dictionary swap store !Dictionary ; 21 | :with (a-) @Dictionary swap dup fetch !Dictionary !a !b ; 22 | :voc (s-) d:create @Dictionary comma ; 23 | }} 24 | ~~~ 25 | 26 | # Some Tests 27 | 28 | ``` 29 | :a #3 n:put nl ; 30 | :b #5 n:put nl ; 31 | a b 32 | 33 | 'test voc &test with 34 | :a #1 n:put nl ; 35 | :b #2 n:put nl ; 36 | a b 37 | 38 | forth 39 | a b 40 | &test 41 | :b #7 n:put nl ; 42 | a b 43 | &test with 44 | a b 45 | forth 46 | 'foo voc &foo with 47 | :b #9 n:put nl ; 48 | a b 49 | forth 50 | 51 | a b 52 | &test with a b :c #100 n:put nl ; c forth 53 | c 54 | &foo with c forth 55 | &test with c forth 56 | ``` 57 | -------------------------------------------------------------------------------- /example/words-four-column.retro: -------------------------------------------------------------------------------- 1 | This is a four column version of `d:words`. It's pretty straightforward. 2 | 3 | The code first scans through the dictionary to find the longest name. Shorter 4 | names will be padded to make sure all columns line up. It then displays each 5 | name, updating a column counter and adding newlines when needed. 6 | 7 | ~~~ 8 | {{ 9 | #3 'Columns var-n 10 | 'PadTo var 11 | :determine-padding 12 | #0 [ d:name s:length n:max ] d:for-each !PadTo ; 13 | :print-name 14 | d:name [ s:put ] [ s:length @PadTo swap - &sp times ] bi sp sp ; 15 | :wrap? @Columns n:zero? dup [ #4 !Columns ] if &Columns v:dec ; 16 | ---reveal--- 17 | :d:words-4 18 | determine-padding [ print-name wrap? &nl if ] d:for-each ; 19 | }} 20 | ~~~ 21 | 22 | Test it. 23 | 24 | ``` 25 | d:words-4 26 | ``` 27 | 28 | -------------------------------------------------------------------------------- /example/wordwrap.retro: -------------------------------------------------------------------------------- 1 | This implements a variation of `s:put` which wraps text based 2 | on a maximum width set by the user. 3 | 4 | ~~~ 5 | #80 'WrapAt var-n 6 | 7 | {{ 8 | 'Displayed var 9 | :wrap? dup @Displayed + @WrapAt gt? ; 10 | :display [ nl !Displayed ] [ &Displayed v:inc-by ] choose s:put sp ; 11 | ---reveal--- 12 | :s:put-wrapped (s-) 13 | #0 !WrapAt 14 | &Heap [ ASCII:SPACE s:tokenize [ dup s:length wrap? display ] a:for-each ] v:preserve ; 15 | }} 16 | ~~~ 17 | -------------------------------------------------------------------------------- /future/utf8.retro: -------------------------------------------------------------------------------- 1 | # UTF-8 Characters 2 | 3 | UTF-8 allows for characters to be one to four bytes long. Since Retro 4 | is 32-bits internally, all characters can fit into a sincle entry on 5 | the stack. These words will be used to pack and unpack the character 6 | values. 7 | 8 | ~~~ 9 | :uc:pack (????n-c) ; 10 | :uc:unpack (c-????n) ; 11 | ~~~ 12 | 13 | # UTF-8 Strings 14 | 15 | Strings in Retro have been C-style null terminated sequences of ASCII 16 | characters. I'm seeking to change this as I'd like to support Unicode 17 | (UTF-8) and to merge much of the string and array handling code. 18 | 19 | This will be an ongoing process. 20 | 21 | Temporary sigil. 22 | 23 | ~~~ 24 | :sigil:" (-a) a:from-string class:data ; immediate 25 | ~~~ 26 | 27 | Return the length (in utf8 characters or bytes) of a string. 28 | 29 | ~~~ 30 | :us:length (a-n) #0 swap [ #192 and #128 -eq? + ] a:for-each n:abs ; 31 | :us:length/bytes (a-n) a:length ; 32 | ~~~ 33 | 34 | ~~~ 35 | ~~~ 36 | 37 | 38 | Fetch a character from a string. 39 | 40 | ~~~ 41 | :us:fetch (an-c) ; 42 | ~~~ 43 | 44 | Store a character into a string. 45 | 46 | ~~~ 47 | :us:store (can-) ; 48 | ~~~ 49 | 50 | Tests. 51 | 52 | ``` 53 | "((V⍳V)=⍳⍴V)/V←,V us:length n:put nl 54 | "((V⍳V)=⍳⍴V)/V←,V us:length/bytes n:put nl 55 | ``` 56 | 57 | -------------------------------------------------------------------------------- /image/build.retro: -------------------------------------------------------------------------------- 1 | ~~~ 2 | #1 'BUILD const 3 | ~~~ 4 | -------------------------------------------------------------------------------- /interface/block.retro: -------------------------------------------------------------------------------- 1 | Blocks allow for a simple storage subsystem. In the smaller ilo 2 | and napia based systems, they are mandatory and are the primary 3 | means of data and code storage 4 | 5 | Under RetroForth/nga, this is optional, but is enabled by 6 | default. 7 | 8 | The exposed word set is compact: 9 | 10 | block:set-file (s-) 11 | block:read (na-) 12 | block:write (na-) 13 | 14 | ~~~ 15 | {{ 16 | 'Skip var 17 | :block:invoke DEVICE:BLOCKS io:scan-for io:invoke ; 18 | ---reveal--- 19 | :block:read (:na-) [ @Skip + ] dip #0 block:invoke ; 20 | :block:write (:na-) [ @Skip + ] dip #1 block:invoke ; 21 | :block:set-file (:s-) #2 block:invoke ; 22 | :block:set-reserved (n-) !Skip ; 23 | }} 24 | ~~~ 25 | 26 | # Source Data 27 | 28 | ~~~ 29 | 'interface/blocks.retro s:dedup 30 | dup 'block:read d:lookup d:source store 31 | dup 'block:write d:lookup d:source store 32 | dup 'block:set-file d:lookup d:source store 33 | dup 'block:set-reserved d:lookup d:source store 34 | drop 35 | ~~~ 36 | -------------------------------------------------------------------------------- /interface/clock.retro: -------------------------------------------------------------------------------- 1 | # Time and Date 2 | 3 | The `clock:` namespace contains words for interacting with the 4 | system clock. 5 | 6 | ~~~ 7 | :clock:operation (:n-) 8 | DEVICE:CLOCK io:scan-for 9 | dup n:negative? [ drop 'Error:_clock_device_not_found s:put nl ] if; 10 | io:invoke ; 11 | 12 | :clock:timestamp (:-n) #0 clock:operation ; 13 | :clock:day (:-n) #1 clock:operation ; 14 | :clock:month (:-n) #2 clock:operation ; 15 | :clock:year (:-n) #3 clock:operation ; 16 | :clock:hour (:-n) #4 clock:operation ; 17 | :clock:minute (:-n) #5 clock:operation ; 18 | :clock:second (:-n) #6 clock:operation ; 19 | :clock:utc:day (:-n) #7 clock:operation ; 20 | :clock:utc:month (:-n) #8 clock:operation ; 21 | :clock:utc:year (:-n) #9 clock:operation ; 22 | :clock:utc:hour (:-n) #10 clock:operation ; 23 | :clock:utc:minute (:-n) #11 clock:operation ; 24 | :clock:utc:second (:-n) #12 clock:operation ; 25 | ~~~ 26 | 27 | ## d:source 28 | 29 | ~~~ 30 | 'interface/clock.retro s:dedup 31 | dup 'clock:utc:second d:lookup d:source store 32 | dup 'clock:utc:minute d:lookup d:source store 33 | dup 'clock:utc:hour d:lookup d:source store 34 | dup 'clock:utc:year d:lookup d:source store 35 | dup 'clock:utc:month d:lookup d:source store 36 | dup 'clock:utc:day d:lookup d:source store 37 | dup 'clock:second d:lookup d:source store 38 | dup 'clock:minute d:lookup d:source store 39 | dup 'clock:hour d:lookup d:source store 40 | dup 'clock:year d:lookup d:source store 41 | dup 'clock:month d:lookup d:source store 42 | dup 'clock:day d:lookup d:source store 43 | dup 'clock:timestamp d:lookup d:source store 44 | dup 'clock:operation d:lookup d:source store 45 | drop 46 | ~~~ 47 | -------------------------------------------------------------------------------- /interface/dedup.retro: -------------------------------------------------------------------------------- 1 | # s:dedup 2 | 3 | String deduplication for RetroForth. 4 | 5 | (c) Arland Childers 6 | 7 | ~~~ 8 | 'init s:keep fll:create 's:dedup.data var-n 9 | 10 | {{ 11 | 't1 var 12 | 't2 var 13 | ---reveal--- 14 | :s:dedup.register (s-) 15 | s:keep @s:dedup.data swap &fll:append/value sip ; 16 | :s:dedup.defined? (s-f) 17 | !t1 #0 !t2 18 | @s:dedup.data [ @t1 s:eq? @t2 or !t2 ] fll:for-each @t2 ; 19 | :s:dedup.find (s-s) 20 | !t1 #0 !t2 21 | @s:dedup.data [ dup @t1 s:eq? [ !t2 ] &drop choose ] 22 | fll:for-each @t2 ; 23 | :s:dedup (s-s) 24 | s:temp dup s:dedup.defined? &s:dedup.find &s:dedup.register 25 | choose ; 26 | :s:unique? (s-f) s:dedup.defined? ; 27 | }} 28 | ~~~ 29 | 30 | ~~~ 31 | 'interface/dedup.retro s:dedup 32 | dup 's:unique? d:lookup d:source store 33 | dup 's:dedup d:lookup d:source store 34 | dup 's:dedup.find d:lookup d:source store 35 | dup 's:dedup.defined? d:lookup d:source store 36 | dup 's:dedup.register d:lookup d:source store 37 | dup 's:dedup.data d:lookup d:source store 38 | drop 39 | ~~~ 40 | -------------------------------------------------------------------------------- /interface/deprecated.retro: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/crcx/retroforth/9a940927934389760261b0d9ebff16765443b3c0/interface/deprecated.retro -------------------------------------------------------------------------------- /interface/error.retro: -------------------------------------------------------------------------------- 1 | ~~~ 2 | :err:set-handler (:nn-) 3 | DEVICE:ERROR io:scan-for 4 | dup n:negative? [ drop 'Error:_error_handling_device_not_found s:put nl ] if; 5 | #0 swap io:invoke ; 6 | 7 | :err:dsu (:-) 8 | reset nl 'ERROR:_DSU:_DATA_STACK_UNDERFLOW s:put nl bye ; 9 | 10 | :err:dso (:-) 11 | reset nl 'ERROR:_DSO:_DATA_STACK_OVERFLOW s:put nl bye ; 12 | 13 | :err:set-defaults (:-) 14 | &err:dsu #1 err:set-handler 15 | &err:dso #2 err:set-handler ; 16 | 17 | 'interface/error.retro s:keep 18 | dup 'err:set-handler d:lookup d:source store 19 | dup 'err:set-defaults d:lookup d:source store 20 | dup 'err:dso d:lookup d:source store 21 | dup 'err:dsu d:lookup d:source store 22 | drop 23 | ~~~ 24 | -------------------------------------------------------------------------------- /interface/ffi.retro: -------------------------------------------------------------------------------- 1 | # FFI 2 | 3 | 326 void io_ffi(NgaState *vm) { 4 | 327 switch (stack_pop(vm)) { 5 | 328 case 0: open_library(vm); break; 6 | 329 case 1: map_symbol(vm); break; 7 | 330 case 2: invoke(vm); break; 8 | 331 } 9 | 332 } 10 | 333 11 | 334 void query_ffi(NgaState *vm) { 12 | 335 stack_push(vm, 0); 13 | 336 stack_push(vm, 8100); /* device type 8100 */ 14 | 337 } 15 | 338 #endif 16 | 17 | ~~~ 18 | :ffi:operation (:n-?) 19 | DEVICE:FFI io:scan-for 20 | dup n:negative? [ drop 'Error:_FFI_device_not_found s:put nl ] if; 21 | io:invoke ; 22 | 23 | :ffi:open (:s-n) 24 | #0 ffi:operation ; 25 | 26 | :ffi:map-sym (:sn-n) 27 | #1 ffi:operation ; 28 | 29 | :ffi:invoke (:n-) 30 | #2 ffi:operation ; 31 | 32 | 'interface/ffi.retro 33 | dup 'ffi:operation d:set-source 34 | dup 'ffi:open d:set-source 35 | dup 'ffi:map-sym d:set-source 36 | dup 'ffi:invoke d:set-source 37 | drop 38 | ~~~ 39 | -------------------------------------------------------------------------------- /interface/final.retro: -------------------------------------------------------------------------------- 1 | ~~~ 2 | [ &d:add-header #2 + call 3 | d:last d:name @d:Hash-Function call d:last d:hash store 4 | ] &d:add-header set-hook 5 | 6 | d:rehash d:use-hashes 7 | ~~~ 8 | -------------------------------------------------------------------------------- /interface/future.retro: -------------------------------------------------------------------------------- 1 | # New Words 2 | 3 | This contains a variety of words from my more recent systems 4 | and things that will be standard in the future. 5 | 6 | ~~~ 7 | :d:use-hashes (:-) 8 | &eq? &d:lookup #5 - store 9 | [ d:hash fetch ] &d:lookup #8 - store 10 | #2049 &d:lookup store 11 | &s:hash &d:lookup n:inc store ; 12 | 13 | :d:use-strings (:-) 14 | &s:eq? &d:lookup #5 - store 15 | &d:name &d:lookup #8 - store 16 | #0 &d:lookup store 17 | #0 &d:lookup n:inc store ; 18 | 19 | 'interface/future.retro 'd:use-hashes d:set-source 20 | 'interface/future.retro 'd:use-strings d:set-source 21 | ~~~ 22 | -------------------------------------------------------------------------------- /interface/gopher.retro: -------------------------------------------------------------------------------- 1 | # Gopher 2 | 3 | RETRO has Gopher support via `gopher:get`. 4 | 5 | Takes: 6 | 7 | destination 8 | server name 9 | port 10 | selector 11 | 12 | Returns: 13 | 14 | number of characters read 15 | 16 | ~~~ 17 | {{ 18 | 'Gopher var 19 | :identify 20 | @Gopher n:zero? 0; drop 21 | #5 io:scan-for dup n:negative? 22 | [ drop 'IO_DEVICE_TYPE_0005_NOT_FOUND s:put nl ] 23 | [ !Gopher ] choose ; 24 | ---reveal--- 25 | :gopher:get identify #0 @Gopher io:invoke ; 26 | }} 27 | ~~~ 28 | -------------------------------------------------------------------------------- /interface/ioctl.retro: -------------------------------------------------------------------------------- 1 | ~~~ 2 | :ioctl:operation (:n-) 3 | DEVICE:IOCTL io:scan-for 4 | dup n:negative? [ drop 'Error:_ioctl_device_not_found s:put nl ] if; 5 | io:invoke ; 6 | 7 | :ioctl:term-size (:-nn) #0 ioctl:operation ; 8 | :ioctl:set-cbreak (:-) #1 ioctl:operation ; 9 | :ioctl:set-lbreak (:-) #2 ioctl:operation ; 10 | :ioctl:save-state (:-) #3 ioctl:operation ; 11 | :ioctl:restore-state (:-) #4 ioctl:operation ; 12 | ~~~ 13 | -------------------------------------------------------------------------------- /interface/library.retro: -------------------------------------------------------------------------------- 1 | ~~~ 2 | :HOME (:-s) here #4096 + ; 3 | 4 | '%s/.config/retroforth/library/%s.retro 'library:.CONFIG s:const (:-s) 5 | './library/%s.retro 'library:CWD s:const (:-s) 6 | 7 | :library:cwd (:s-s) library:CWD s:format ; 8 | 9 | :library:.config (:-s) 10 | 'HOME HOME unix:getenv 11 | HOME library:.CONFIG s:format ; 12 | 13 | :library:filename (:s-s) 14 | dup library:cwd 15 | dup file:exists? &nip if; drop 16 | library:.config dup file:exists? [ ] if; drop s:empty ; 17 | 18 | :library:contains? (:s-f) 19 | &library:cwd &library:.config bi &file:exists? bi@ or ; 20 | 21 | :library:load (:s-) 22 | dup library:contains? [ library:filename include ] 23 | [ 'ERROR:_Library_`%s`_was_not_found s:format s:put nl ] choose ; 24 | 25 | 'interface/library.retro s:dedup 26 | dup 'library:load d:set-source 27 | dup 'library:contains? d:set-source 28 | dup 'library:filename d:set-source 29 | dup 'library:.config d:set-source 30 | dup 'library:cwd d:set-source 31 | dup 'library:CWD d:set-source 32 | dup 'library:.CONFIG d:set-source 33 | dup 'HOME d:set-source 34 | drop 35 | ~~~ 36 | -------------------------------------------------------------------------------- /interface/multicore.retro: -------------------------------------------------------------------------------- 1 | ~~~ 2 | :io:core (:n-) DEVICE:MULTICORE io:scan-for io:invoke ; 3 | 4 | :core:init (:n-) #0 io:core ; 5 | :core:start (:an-) #1 io:core ; 6 | :core:pause (:n-) #2 io:core ; 7 | :core:pause-current (:-) #3 io:core ; 8 | :core:resume (:n-) #4 io:core ; 9 | :core:read/reg (:n-v) #5 io:core ; 10 | :core:write/reg (:vn-) #6 io:core ; 11 | ~~~ 12 | 13 | ~~~ 14 | 'interface/multicore.retro s:dedup 15 | dup 'io:core d:lookup d:source store 16 | dup 'core:init d:lookup d:source store 17 | dup 'core:start d:lookup d:source store 18 | dup 'core:pause d:lookup d:source store 19 | dup 'core:pause-current d:lookup d:source store 20 | dup 'core:resume d:lookup d:source store 21 | dup 'core:read/reg d:lookup d:source store 22 | dup 'core:write/reg d:lookup d:source store 23 | drop 24 | ~~~ 25 | -------------------------------------------------------------------------------- /interface/rng.retro: -------------------------------------------------------------------------------- 1 | # Random Number Generator 2 | 3 | I/O device type 10 is a random number generator. I do this as 4 | part of the VM I/O extensions to allow implementors to use the 5 | best approach on their host system. 6 | 7 | ~~~ 8 | :n:random (:-n) 9 | DEVICE:RNG io:scan-for 10 | dup n:negative? [ drop 'Error:_RNG_device_not_found s:put nl ] if; 11 | io:invoke ; 12 | 13 | 'interface/rng.retro 'n:random d:set-source 14 | ~~~ 15 | 16 | -------------------------------------------------------------------------------- /interface/unsigned.retro: -------------------------------------------------------------------------------- 1 | # Unsigned Numbers 2 | 3 | ~~~ 4 | :unsigned:+ (:nn-n) #0 #8101 io:scan-for io:invoke \ad...... ; 5 | :unsigned:- (:nn-n) #0 #8101 io:scan-for io:invoke \su...... ; 6 | :unsigned:* (:nn-n) #0 #8101 io:scan-for io:invoke \mu...... ; 7 | :unsigned:/mod (:nn-nn) #0 #8101 io:scan-for io:invoke \di...... ; 8 | :unsigned:eq? (:nn-f) #0 #8101 io:scan-for io:invoke \eq...... ; 9 | :unsigned:-eq? (:nn-f) #0 #8101 io:scan-for io:invoke \ne...... ; 10 | :unsigned:lt? (:nn-f) #0 #8101 io:scan-for io:invoke \lt...... ; 11 | :unsigned:gt? (:nn-f) #0 #8101 io:scan-for io:invoke \gt...... ; 12 | :unsigned:shift (:nn-n) #0 #8101 io:scan-for io:invoke \sh...... ; 13 | :unsigned:*/mod (:nnn-nn) #1 #0 #8101 io:scan-for dup io:invoke io:invoke ; 14 | :*/mod (:nnn-nn) #1 #8101 io:scan-for io:invoke ; 15 | ~~~ 16 | 17 | ~~~ 18 | 'interface/unsigned.retro s:dedup 19 | dup 'unsigned:+ d:lookup d:source store 20 | dup 'unsigned:- d:lookup d:source store 21 | dup 'unsigned:* d:lookup d:source store 22 | dup 'unsigned:/mod d:lookup d:source store 23 | dup 'unsigned:eq? d:lookup d:source store 24 | dup 'unsigned:-eq? d:lookup d:source store 25 | dup 'unsigned:lt? d:lookup d:source store 26 | dup 'unsigned:gt? d:lookup d:source store 27 | dup 'unsigned:shift d:lookup d:source store 28 | dup 'unsigned:*/mod d:lookup d:source store 29 | dup '*/mod d:lookup d:source store 30 | drop 31 | ~~~ 32 | 33 | -------------------------------------------------------------------------------- /library/c-get-ext.retro: -------------------------------------------------------------------------------- 1 | ~~~ 2 | :keys:UP (:-n) #-300 ; 3 | :keys:DOWN (:-n) #-301 ; 4 | :keys:RIGHT (:-n) #-302 ; 5 | :keys:LEFT (:-n) #-303 ; 6 | 7 | :c:get/ext (:-c) 8 | c:get dup #27 eq? 9 | [ drop c:get drop c:get #235 + n:negate ] if ; 10 | ~~~ 11 | -------------------------------------------------------------------------------- /library/konilo.retro: -------------------------------------------------------------------------------- 1 | 2 | ,dPYb, ,dPYb, 3 | IP'`Yb IP'`Yb 4 | I8 8I gg I8 8I 5 | I8 8bgg, "" I8 8' 6 | I8 dP" "8 ,ggggg, ,ggg,,ggg, gg I8 dP ,ggggg, 7 | I8d8bggP" dP" "Y8 ,8" "8P" "8, 88 I8dP dP" "Y8 8 | I8P' "Yb, i8' ,8I d8 8I 8I 88 I8P i8' ,8I 9 | ,d8 `Yb,,d8, ,d8P8P 8I Yb,_,88,_,d8b,_ ,d8, ,d8' 10 | 88P Y8P"Y8888P" 8I `Y88P""Y88P'"Y88P"Y8888P" 11 | 12 | This adds support for some words from Konilo. It's intended 13 | to aid in portability between the systems. 14 | 15 | The basic math operations are given non-symbolic names and 16 | placed in the `n:` namespace. (In Konilo, these are the standard 17 | names for these). 18 | 19 | ~~~ 20 | :n:add (:nn-n) + ; 21 | :n:sub (:nn-n) - ; 22 | :n:mul (:nn-n) * ; 23 | :n:div (:nn-nn) / ; 24 | :n:mod (:nn-n) mod ; 25 | :n:divmod (:nn-n) /mod ; 26 | 27 | :comma (:n-) , ; 28 | ~~~ 29 | -------------------------------------------------------------------------------- /library/openbsd.retro: -------------------------------------------------------------------------------- 1 | Extensions relating to OpenBSD-specific functionality 2 | 3 | ~~~ 4 | :io:openbsd (:...n-) 5 | ; 6 | 'For_use_on_OpenBSD_only:_invoke_host_specific_functionality. 7 | add-description 8 | 9 | :openbsd:pledge (:s-) ; 10 | 'For_use_on_OpenBSD_only:_invoke_pledge()_with_the_provided_string. 11 | add-description 12 | 13 | :openbsd:unveil (:s-) ; 14 | 'For_use_on_OpenBSD_only:_invoke_unveil()_with_the_provided_string._A_pointer_to_0_can_also_be_passed. 15 | add-description 16 | ~~~ 17 | -------------------------------------------------------------------------------- /library/pythonista-ui.retro: -------------------------------------------------------------------------------- 1 | ~~~ 2 | #941687072 'forth.works::pythonista/ui const 3 | :ui:operation forth.works::pythonista/ui io:scan-for io:invoke ; 4 | 5 | :ui:create-view (name,type) #0 ui:operation ; 6 | :ui:add-view (name) #1 ui:operation ; 7 | :ui:remove-view (name) #2 ui:operation ; 8 | :ui:present (name) #3 ui:operation ; 9 | 10 | :ui:set-size (h,w,name) #4 ui:operation ; 11 | :ui:set-position (x,y,name) #5 ui:operation ; 12 | :ui:get-size (name-h,w) #6 ui:operation ; 13 | :ui:get-position (name-x,y) #7 ui:operation ; 14 | 15 | :ui:set-title (title,name) #8 ui:operation ; 16 | :ui:set-text (text,name) #9 ui:operation ; 17 | :ui:get-title (name-title) #10 ui:operation ; 18 | :ui:get-text (name-text) #11 ui:operation ; 19 | 20 | :ui:set-action (action,name) #12 ui:operation ; 21 | :ui:get-action (name-action) #13 ui:operation ; 22 | ~~~ 23 | -------------------------------------------------------------------------------- /man/retro-compiler.1: -------------------------------------------------------------------------------- 1 | .Dd November 2023 2 | .Dt RETRO-COMPILER 1 3 | .Os 4 | .Sh RETRO-COMPILER 5 | .Nm retro-compiler 6 | .Nd "a modern, pragmatic forth development system" 7 | .Sh SYNOPSIS 8 | .Nm 9 | filename 10 | entry 11 | .Sh DESCRIPTION 12 | RETRO is a modern, pragmatic Forth drawing influences from many 13 | sources. It's clean, elegant, tiny, and easy to grasp and adapt 14 | to various uses. 15 | 16 | .Nm 17 | takes a source file you provide and compiles it into a new 18 | image. The new image is then bundled with a RetroForth runtime 19 | and saved as a new executable named `a.out`. 20 | .Sh AUTHORS 21 | .An Charles Childers Aq Mt crc@forthworks.com 22 | -------------------------------------------------------------------------------- /man/retro-describe.1: -------------------------------------------------------------------------------- 1 | .Dd May 2019 2 | .Dt RETRO-DESCRIBE 1 3 | .Os 4 | .Sh RETRO-DESCRIBE 5 | .Nm retro-describe 6 | .Nd "a modern, pragmatic forth development system" 7 | .Sh SYNOPSIS 8 | .Nm 9 | wordname 10 | .Op additional wordnames 11 | .Sh DESCRIPTION 12 | RETRO is a modern, pragmatic Forth drawing influences from many 13 | sources. It's clean, elegant, tiny, and easy to grasp and adapt 14 | to various uses. 15 | 16 | .Nm 17 | is a tool for looking up the description and stack comments for 18 | words in the core language and extensions. It will write output 19 | to stdout. 20 | .Sh AUTHORS 21 | .An Charles Childers Aq Mt crc@forthworks.com 22 | -------------------------------------------------------------------------------- /man/retro-document.1: -------------------------------------------------------------------------------- 1 | .Dd May 2019 2 | .Dt RETRO-DOCUMENT 1 3 | .Os 4 | .Sh RETRO-DOCUMENT 5 | .Nm retro-document 6 | .Nd "a modern, pragmatic forth development system" 7 | .Sh SYNOPSIS 8 | .Nm 9 | filename 10 | .Sh DESCRIPTION 11 | RETRO is a modern, pragmatic Forth drawing influences from many 12 | sources. It's clean, elegant, tiny, and easy to grasp and adapt 13 | to various uses. 14 | 15 | .Nm 16 | is a tool for generating a listing of the descriptions and stack 17 | comments for all standard word used in a source file. It will 18 | write output to stdout. 19 | .Sh AUTHORS 20 | .An Charles Childers Aq Mt crc@forthworks.com 21 | -------------------------------------------------------------------------------- /man/retro-embedimage.1: -------------------------------------------------------------------------------- 1 | .Dd February 2019 2 | .Dt RETRO-EMBEDIMAGE 1 3 | .Os 4 | .Sh RETRO-EMBEDIMAGE 5 | .Nm retro-embedimage 6 | .Nd "a modern, pragmatic forth development system" 7 | .Sh SYNOPSIS 8 | .Nm 9 | .Op filename 10 | .Sh DESCRIPTION 11 | RETRO is a modern, pragmatic Forth drawing influences from many 12 | sources. It's clean, elegant, tiny, and easy to grasp and adapt 13 | to various uses. 14 | 15 | .Nm 16 | loads the specified image (or `ngaImage` from the current 17 | directory if none is specified). It converts this into C 18 | code that can be compiled for inclusion in a RETRO executable. 19 | It will write the output to stdout. 20 | .Sh AUTHORS 21 | .An Charles Childers Aq Mt crc@forthworks.com 22 | -------------------------------------------------------------------------------- /man/retro-extend.1: -------------------------------------------------------------------------------- 1 | .Dd January 2021 2 | .Dt RETRO-EXTEND 1 3 | .Os 4 | .Sh RETRO-EXTEND 5 | .Nm retro-extend 6 | .Nd "a modern, pragmatic forth development system" 7 | .Sh SYNOPSIS 8 | .Nm 9 | image filename 10 | .Op filenames 11 | .Sh DESCRIPTION 12 | RETRO is a modern, pragmatic Forth drawing influences from many 13 | sources. It's clean, elegant, tiny, and easy to grasp and adapt 14 | to various uses. 15 | 16 | .Nm 17 | is a tool to load additional code into an image file. It takes 18 | the name of an image file and one or more source files to load 19 | into the image. After completion the image file will be updated 20 | with the changes. 21 | 22 | .Sh CAVEATS 23 | .Nm 24 | only emulates the minimal console output device. If the source 25 | files require additional I/O to be present, the extend process 26 | will likely fail to work correctly. 27 | 28 | .Sh AUTHORS 29 | .An Charles Childers Aq Mt crc@forthworks.com 30 | -------------------------------------------------------------------------------- /man/retro-locate.1: -------------------------------------------------------------------------------- 1 | .Dd January 2020 2 | .Dt RETRO-LOCATE 1 3 | .Os 4 | .Sh RETRO-LOCATE 5 | .Nm retro-locate 6 | .Nd "a modern, pragmatic forth development system" 7 | .Sh SYNOPSIS 8 | .Nm 9 | wordname 10 | .Sh DESCRIPTION 11 | RETRO is a modern, pragmatic Forth drawing influences from many 12 | sources. It's clean, elegant, tiny, and easy to grasp and adapt 13 | to various uses. 14 | 15 | .Nm 16 | searches the tags file generated by retro-tags for the desired 17 | word name. Any matches are displayed, along with the line number. 18 | .Sh AUTHORS 19 | .An Charles Childers Aq Mt crc@forthworks.com 20 | -------------------------------------------------------------------------------- /man/retro-muri.1: -------------------------------------------------------------------------------- 1 | .Dd February 2019 2 | .Dt RETRO-MURI 1 3 | .Os 4 | .Sh RETRO-MURI 5 | .Nm retro-muri 6 | .Nd "a modern, pragmatic forth development system" 7 | .Sh SYNOPSIS 8 | .Nm 9 | filename 10 | .Sh DESCRIPTION 11 | RETRO is a modern, pragmatic Forth drawing influences from many 12 | sources. It's clean, elegant, tiny, and easy to grasp and adapt 13 | to various uses. 14 | 15 | .Nm 16 | is an assembler for Nga, the virtual machine at the heart of 17 | Retro. It is used to build the image file containing the actual 18 | Retro language. 19 | 20 | This will extract the code blocks in the specified file and 21 | generate an image file named `ngaImage`. 22 | .Sh AUTHORS 23 | .An Charles Childers Aq Mt crc@forthworks.com 24 | -------------------------------------------------------------------------------- /man/retro-tags.1: -------------------------------------------------------------------------------- 1 | .Dd August 2019 2 | .Dt RETRO-TAGS 1 3 | .Os 4 | .Sh RETRO-TAGS 5 | .Nm retro-tags 6 | .Nd "a modern, pragmatic forth development system" 7 | .Sh SYNOPSIS 8 | .Nm 9 | .Sh DESCRIPTION 10 | RETRO is a modern, pragmatic Forth drawing influences from many 11 | sources. It's clean, elegant, tiny, and easy to grasp and adapt 12 | to various uses. 13 | 14 | .Nm 15 | is a tool for extracting code from fenced blocks in literate 16 | sources and generating a tags file compatible with ctags. 17 | .Sh AUTHORS 18 | .An Charles Childers Aq Mt crc@forthworks.com 19 | -------------------------------------------------------------------------------- /man/retro-unu.1: -------------------------------------------------------------------------------- 1 | .Dd June 2020 2 | .Dt RETRO-UNU 1 3 | .Os 4 | .Sh RETRO-UNU 5 | .Nm retro-unu 6 | .Nd "literate programming tool for use with retro" 7 | .Sh SYNOPSIS 8 | .Nm 9 | .Op Fl t 10 | filename 11 | .Sh DESCRIPTION 12 | RETRO is a modern, pragmatic Forth drawing influences from many 13 | sources. It's clean, elegant, tiny, and easy to grasp and adapt 14 | to various uses. 15 | 16 | .Nm 17 | is a tool for extracting code from literate sources. It will 18 | write output to stdout. 19 | 20 | A code block starts with ~~~ on a line by itself and ends with 21 | a second ~~~. Test blocks start and end with ```. 22 | 23 | .Nm 24 | does not support "out of order" structuring of the code, 25 | commentary, and test blocks. 26 | 27 | .Sh OPTIONS 28 | .Bl -tag -width -indent 29 | .It Fl t 30 | Include any test blocks in the file. 31 | .It filename 32 | Extract code blocks from the specified file. 33 | .El 34 | .Sh AUTHORS 35 | .An Charles Childers Aq Mt crc@forthworks.com 36 | 37 | -------------------------------------------------------------------------------- /man/retro.1: -------------------------------------------------------------------------------- 1 | .Dd October 2023 2 | .Dt RETRO 1 3 | .Os 4 | .Sh RETRO 5 | .Nm retro 6 | .Nd "a modern, pragmatic forth development system" 7 | .Sh SYNOPSIS 8 | .Nm 9 | .Op Fl h 10 | .Op Fl i 11 | .Op Fl v 12 | .Op Fl t Ar filename 13 | .Op Fl f Ar filename 14 | .Op Fl p Ar filename 15 | .Op Fl u Ar filename 16 | .Op Fl r Ar filename 17 | .Op Ar filename Ar script-args 18 | .Sh DESCRIPTION 19 | RETRO is a modern, pragmatic Forth drawing influences from many sources. 20 | It's clean, elegant, tiny, and easy to grasp and adapt to various uses. 21 | 22 | .Nm 23 | is the main interface for interacting with Retro. It provides both 24 | an interactive and a scripting model. 25 | .Sh OPTIONS 26 | .Bl -tag -width -indent 27 | .It Fl h 28 | Display a help screen. 29 | .It Fl i 30 | Start Retro in interactive mode. 31 | .It Fl s 32 | Start Retro in interactive mode and suppress the startup message. 33 | .It Fl v 34 | Run in verbose mode, showing debugging information. Verbose output is written to /dev/stderr. 35 | .It Fl t Ar filename 36 | Run any code and test blocks in the specified file. 37 | .It Fl f Ar filename 38 | Run any code blocks in the specified file. 39 | .It Fl p Ar filename 40 | Run the code in the specified file. 41 | .It Fl u Ar filename 42 | Load and use the specified image file rather than the integral one. 43 | .It Fl r Ar filename 44 | Load and run the code in the specified image file rather than the integral one. 45 | .It filename script-args 46 | Run code blocks in a single file. Pass script-args to the code being run. 47 | .El 48 | 49 | If invoked with no arguments, 50 | .Nm 51 | will run in interactive mode. 52 | .Sh AUTHORS 53 | .An Charles Childers Aq Mt crc@forthworks.com 54 | -------------------------------------------------------------------------------- /ngaImage: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/crcx/retroforth/9a940927934389760261b0d9ebff16765443b3c0/ngaImage -------------------------------------------------------------------------------- /old/Makefile.python: -------------------------------------------------------------------------------- 1 | PYTHON ?= python3 2 | EDITOR ?= nano 3 | 4 | default: baseimage 5 | cp ngaImage pythonImage 6 | $(PYTHON) tools/retro-extend.py pythonImage interface/clock.retro interface/filesystem.retro interface/floatingpoint.retro interface/rng.retro package/dict-words-listing.forth 7 | $(PYTHON) tools/retro-embedimage.py pythonImage >vm/nga-python/InitialImage.py 8 | rm -f pythonImage 9 | 10 | baseimage: 11 | $(PYTHON) tools/retro-muri.py image/retro.muri 12 | $(PYTHON) tools/retro-extend.py ngaImage image/retro.forth 13 | 14 | release: 15 | retro tools/amalgamate-python.retro >rel/python/retroforth/retroforth.py 16 | $(EDITOR) rel/python/setup.py 17 | cd rel/python && python3 setup.py sdist bdist_wheel 18 | 19 | upload: 20 | cd rel/python && python3 -m twine upload dist/* 21 | -------------------------------------------------------------------------------- /old/rel/python/retroforth/__init__.py: -------------------------------------------------------------------------------- 1 | __version__ = "0.1.0" 2 | -------------------------------------------------------------------------------- /old/rel/python/setup.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | # encoding: utf-8 3 | 4 | import setuptools 5 | 6 | with open("README", "r", encoding="utf-8") as fh: 7 | long_description = fh.read() 8 | 9 | setuptools.setup( 10 | name="retroforth", 11 | version="2021.1", 12 | author="Charles Childers", 13 | author_email="crc@forthworks.com", 14 | description="RetroForth is a modern, pragmatic Forth", 15 | long_description=long_description, 16 | long_description_content_type="text/markdown", 17 | url="http://forthworks.com/retro", 18 | packages=setuptools.find_packages(), 19 | classifiers=[ 20 | "Programming Language :: Python :: 3", 21 | "License :: OSI Approved :: ISC License (ISCL)", 22 | "Operating System :: OS Independent", 23 | ], 24 | python_requires=">=3.6", 25 | ) 26 | -------------------------------------------------------------------------------- /package/extensions/README.retro: -------------------------------------------------------------------------------- 1 | Put extensions into this directory and run: 2 | 3 | make update-extensions 4 | make 5 | 6 | Any extensions here will be placed in a file named 7 | `package/load-extensions.retro` for compilation into the 8 | embedded image. 9 | 10 | I am including a fence here to silence a compile time warning. 11 | 12 | ~~~ 13 | ~~~ 14 | -------------------------------------------------------------------------------- /package/extensions/double.retro: -------------------------------------------------------------------------------- 1 | ~~~ 2 | :double:var (:nns-) 3 | d:create swap , , ; 4 | 5 | :double:fetch (:a-nn) 6 | fetch-next swap fetch ; 7 | 8 | :double:store (:nna-) 9 | &swap dip store-next store ; 10 | 11 | :double:const (:nns-) 12 | double:var &double:fetch does ; 13 | 14 | :double:swap (:nnmm-mmnn) 15 | rot push rot pop ; 16 | 17 | :double:dip (:mnq-mn) rot rot push push call pop pop ; 18 | :double:sip (:mnq-mn) &dup-pair dip double:dip ; 19 | ~~~ 20 | -------------------------------------------------------------------------------- /package/extensions/malloc.retro: -------------------------------------------------------------------------------- 1 | # Malloc 2 | 3 | ~~~ 4 | {{ 5 | :mem:invoke #15 io:scan-for io:invoke ; 6 | 7 | #0 'ALLOC const 8 | #1 'FREE const 9 | #2 'STORE const 10 | #3 'FETCH const 11 | #4 'RESIZE const 12 | 13 | ---reveal--- 14 | 15 | :mem:alloc (:n--a) ALLOC mem:invoke ; 16 | :mem:store (:an--) STORE mem:invoke ; 17 | :mem:fetch (:a--n) FETCH mem:invoke ; 18 | :mem:free (:a--) FREE mem:invoke ; 19 | :mem:resize (:an--) RESIZE mem:invoke ; 20 | }} 21 | 22 | :mem:cell+ (:nn-n) #8 * + ; 23 | :mem:fetch-double (:n-nn) 24 | dup #1 mem:cell+ fetch push mem:fetch pop ; 25 | :mem:store-double (:ann-nn) 26 | push push dup-pair #1 mem:cell+ pop mem:store pop mem:store ; 27 | ~~~ 28 | -------------------------------------------------------------------------------- /package/load-extensions.retro: -------------------------------------------------------------------------------- 1 | ~~~ 2 | 'extensions/README.retro include 3 | 'extensions/double.retro include 4 | 'extensions/malloc.retro include 5 | ~~~ 6 | -------------------------------------------------------------------------------- /package/unsupported/allow-underscores-in-names.forth: -------------------------------------------------------------------------------- 1 | ## Fix Annoyances 2 | 3 | Underscores in names (especially variables and constants) are a 4 | problem as the string processor (`prefix:'`) replaces them with 5 | a space. The other prefixes do not do this, which leads to bugs. 6 | 7 | Consider: 8 | 9 | 'test_data var 10 | #10 !test_data 11 | 12 | `test_data` is not found as the real name is `test data`, so it 13 | silently maps the address to 0. 14 | 15 | As a solution, this replaces `d:add-header` with an new version 16 | that implementation that remaps any spaces back to underscores 17 | prior to creating the header. 18 | 19 | ~~~ 20 | {{ 21 | :fields @Dictionary , (link) , (xt) , (class) ; 22 | :invalid-name? dup ASCII:SPACE s:contains-char? ; 23 | :rewrite [ ASCII:SPACE [ $_ ] case ] s:map ; 24 | :entry here &call dip !Dictionary ; 25 | [ [ fields invalid-name? &rewrite if s, (name) ] entry ] 26 | }} 27 | 28 | #1793 &d:add-header store 29 | &d:add-header n:inc store 30 | ~~~ 31 | -------------------------------------------------------------------------------- /package/unsupported/compat-2020.10.retro: -------------------------------------------------------------------------------- 1 | # Deprecated Names 2 | 3 | To be removed in 2021.1: 4 | 5 | ~~~ 6 | :sys:argc script:arguments ; 7 | :sys:argv script:get-argument ; 8 | :sys:name script:name ; 9 | ~~~ 10 | 11 | -------------------------------------------------------------------------------- /package/unsupported/compat.forth: -------------------------------------------------------------------------------- 1 | ~~~ 2 | :times indexed-times ; 3 | :var var-n ; 4 | :d:last d:last.name ; 5 | :d:last d:last.class ; 6 | :d:last d:last.xt ; 7 | ~~~ 8 | 9 | -------------------------------------------------------------------------------- /security/2024-01.pub: -------------------------------------------------------------------------------- 1 | untrusted comment: key for 2024.01 release public key 2 | RWQVDxfHLFVRGzZU7oTx0kbPJmMtttOO0PM7yCpcPlg+OcO1eNp4xMfH 3 | -------------------------------------------------------------------------------- /security/2024-02.pub: -------------------------------------------------------------------------------- 1 | untrusted comment: key for 2024.02 release public key 2 | RWRlWE+CcDIOBI/8GE4eX9jH2gZOyB9E33RRdG6eyCCeYMD+wyo/3Rqc 3 | -------------------------------------------------------------------------------- /security/2024-03.pub: -------------------------------------------------------------------------------- 1 | untrusted comment: key for 2024.03 release public key 2 | RWRn5U+Hgp/DTa2Ms1MNWfFRINidnbKuQzzJv1YJ27AaZ8MiaQ85pQNA 3 | -------------------------------------------------------------------------------- /security/2024-04.pub: -------------------------------------------------------------------------------- 1 | untrusted comment: key for 2024.04 release public key 2 | RWTVVxPQJL3VnUyCEUdcEdUyJUGQEUrH8hZi8hAd2Yv2Je5SwyK8+8D7 3 | -------------------------------------------------------------------------------- /security/2024-05.pub: -------------------------------------------------------------------------------- 1 | untrusted comment: key for 2024.05 release public key 2 | RWSkF6sGrE4y77Vvvzu9Uyl23Q3tTMsyYRTEiMc4oha+3HCED7eqPLY/ 3 | -------------------------------------------------------------------------------- /security/2024-06.pub: -------------------------------------------------------------------------------- 1 | untrusted comment: key for 2024.06 release public key 2 | RWQPCHecCDM8s7jNbtS4CP/8BZfZFVfPHeEzq83n9KqbTU0gUImv2sZx 3 | -------------------------------------------------------------------------------- /security/2024-07.pub: -------------------------------------------------------------------------------- 1 | untrusted comment: key for 2024.07 release public key 2 | RWRcDDtMgnjV9jPfsnYLZQ7GAhbk4p1U18Z+uWtZBo3noMreDIpsUhaj 3 | -------------------------------------------------------------------------------- /security/2024-08.pub: -------------------------------------------------------------------------------- 1 | untrusted comment: key for 2024.08 release public key 2 | RWSWe9eskYmNVHVN5JpkXRfZlr2nJPaiKMT8cmulbmtIh0tffsvhQtPu 3 | -------------------------------------------------------------------------------- /security/2024-09.pub: -------------------------------------------------------------------------------- 1 | untrusted comment: key for 2024.09 release public key 2 | RWQ/PL4mMBoBcHBfdrYs6cKpHRvlO9usy1xn+g2yeqgXEyBLc71v53K7 3 | -------------------------------------------------------------------------------- /security/2024-10.pub: -------------------------------------------------------------------------------- 1 | untrusted comment: key for 2024.10 release public key 2 | RWRrTQ7c209z+TgA0a72vr12XGZQFT3+FJgLr/C4wuWoiRltQN+DIrsV 3 | -------------------------------------------------------------------------------- /security/2024-11.pub: -------------------------------------------------------------------------------- 1 | untrusted comment: key for 2024.11 release public key 2 | RWQlK1uvDxao/S0tTuutULRd9WZrJrLIGEA1n8Vnr0uJxxLcYWlYkaxt 3 | -------------------------------------------------------------------------------- /security/2024-12.pub: -------------------------------------------------------------------------------- 1 | untrusted comment: key for 2024.12 release public key 2 | RWTe475Lmem9WPOoCyYvYxrOJbhIJZnFSRdUJ/TLueojD4xPLuH3tXFB 3 | -------------------------------------------------------------------------------- /security/README: -------------------------------------------------------------------------------- 1 | This directory contains the signing keys for the current and 2 | next release of RETRO. The signature files for releases will 3 | be generated using the OpenBSD signify tool. 4 | 5 | Releases are generally planned to be quarterly; so the first 6 | release would be 2021.01, and the second would be 2021.04. 7 | 8 | Additional keys are also included, but will only be used if 9 | there are unplanned releases to fix significant issues that 10 | arise outside of the standard release schedule. 11 | 12 | For 2021, the planned releases are: 13 | 14 | January: 2021.01 15 | April: 2021.04 16 | July: 2021.07 17 | October: 2021.10 18 | -------------------------------------------------------------------------------- /tests/Instructions.md: -------------------------------------------------------------------------------- 1 | # Testing Instructions 2 | 3 | Build & install Retro. 4 | 5 | Run: 6 | 7 | sh instructions.sh 8 | 9 | Compare resulting stacks to the table below. 10 | 11 | | Opcode | Expected | 12 | | ------ | ------------------------ | 13 | | 0 | | 14 | | 1 | 1 -1 99 -99 | 15 | | 2 | 100 100 200 200 | 16 | | 3 | 100 200 | 17 | | 4 | 200 300 100 | 18 | | 5 | 100 300 200 | 19 | | 6 | 100 300 200 | 20 | | 7 | 10 | 21 | | 8 | 10 | 22 | | 9 | 100 | 23 | | 10 | 10 | 24 | | 11 | 0 -1 | 25 | | 12 | -1 0 | 26 | | 13 | -1 0 0 | 27 | | 14 | 0 0 -1 | 28 | | 15 | 97 98 99 | 29 | | 16 | 97 98 48 | 30 | | 17 | 300 1 | 31 | | 18 | -100 199 | 32 | | 19 | 20000 -9900 | 33 | | 20 | 100 0 1 -1 89 2 | 34 | | 21 | -1 0 0 | 35 | | 22 | -1 -1 0 | 36 | | 23 | 0 -1 0 | 37 | | 24 | 3640 455 | 38 | | 25 | 2 | 39 | | 26 | | 40 | 41 | -------------------------------------------------------------------------------- /tests/ad.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | : main 3 | i liliadli 4 | d 100 5 | d 200 6 | d 100 7 | i liadha.. 8 | d -99 9 | ~~~ 10 | 11 | -------------------------------------------------------------------------------- /tests/an.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | : main 3 | i lilian.. 4 | d -1 5 | d -1 6 | i lilian.. 7 | d 0 8 | d -1 9 | i lilian.. 10 | d 0 11 | d 0 12 | i ha...... 13 | ~~~ 14 | 15 | -------------------------------------------------------------------------------- /tests/ca.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | i liju.... 3 | r main 4 | : subr 5 | i lire.... 6 | d 10 7 | : main 8 | i lica.... 9 | r subr 10 | i ha...... 11 | ~~~ 12 | 13 | -------------------------------------------------------------------------------- /tests/cc.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | : c1 3 | i lire.... 4 | d 100 5 | 6 | : c2 7 | i lire.... 8 | d 200 9 | 10 | : main 11 | i lilieqli 12 | d 100 13 | d 100 14 | r c1 15 | i cc...... 16 | i lilieqli 17 | d 100 18 | d 200 19 | r c2 20 | i cc...... 21 | i ha...... 22 | ~~~ 23 | 24 | -------------------------------------------------------------------------------- /tests/di.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | : main 3 | i lilidi.. 4 | d 100 5 | d 200 6 | i lilidi.. 7 | d 100 8 | d -99 9 | i lilidi.. 10 | d 355 11 | d 133 12 | i ha...... 13 | ~~~ 14 | 15 | -------------------------------------------------------------------------------- /tests/dr.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | i lililidr 3 | d 100 4 | d 200 5 | d 300 6 | i ha...... 7 | ~~~ 8 | -------------------------------------------------------------------------------- /tests/du.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | i lidulidu 3 | d 100 4 | d 200 5 | i ha...... 6 | ~~~ 7 | -------------------------------------------------------------------------------- /tests/eq.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | i lilieq.. 3 | d 100 4 | d 200 5 | i lilieq.. 6 | d 100 7 | d 100 8 | i ha...... 9 | ~~~ 10 | 11 | -------------------------------------------------------------------------------- /tests/fe.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | i liju.... 3 | r main 4 | 5 | : abc 6 | s abc 7 | 8 | : main 9 | i lifelili 10 | r abc 11 | r abc 12 | d 1 13 | i adfelili 14 | r abc 15 | d 2 16 | i adfe.... 17 | i ha...... 18 | ~~~ 19 | 20 | -------------------------------------------------------------------------------- /tests/gt.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | i liligt.. 3 | d 100 4 | d 200 5 | i liligt.. 6 | d 100 7 | d 100 8 | i liligt.. 9 | d 200 10 | d 100 11 | i ha...... 12 | ~~~ 13 | -------------------------------------------------------------------------------- /tests/ha.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | i ha...... 3 | ~~~ 4 | -------------------------------------------------------------------------------- /tests/ju.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | i liju.... 3 | r subr 4 | i liha.... 5 | d 89 6 | 7 | : subr 8 | i liha.... 9 | d 10 10 | ~~~ 11 | -------------------------------------------------------------------------------- /tests/li.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | i lililili 3 | d 1 4 | d -1 5 | d 99 6 | d -99 7 | i ha...... 8 | ~~~ 9 | -------------------------------------------------------------------------------- /tests/lt.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | i lililt.. 3 | d 100 4 | d 200 5 | i lililt.. 6 | d 100 7 | d 100 8 | i lililt.. 9 | d 200 10 | d 100 11 | i ha...... 12 | ~~~ 13 | -------------------------------------------------------------------------------- /tests/mu.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | i lilimu.. 3 | d 100 4 | d 200 5 | i lilimu.. 6 | d 100 7 | d -99 8 | i ha...... 9 | ~~~ 10 | -------------------------------------------------------------------------------- /tests/ne.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | i liline.. 3 | d 100 4 | d 200 5 | i liline.. 6 | d 100 7 | d 100 8 | i ha...... 9 | ~~~ 10 | -------------------------------------------------------------------------------- /tests/no.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | i ........ 3 | i ha...... 4 | ~~~ 5 | -------------------------------------------------------------------------------- /tests/or.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | i lilior.. 3 | d -1 4 | d -1 5 | i lilior.. 6 | d 0 7 | d -1 8 | i lilior.. 9 | d 0 10 | d 0 11 | i ha...... 12 | ~~~ 13 | -------------------------------------------------------------------------------- /tests/po.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | i lilipuli 3 | d 100 4 | d 200 5 | d 300 6 | i po...... 7 | i ha...... 8 | ~~~ 9 | -------------------------------------------------------------------------------- /tests/pu.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | i lilipuli 3 | d 100 4 | d 200 5 | d 300 6 | i po...... 7 | i ha...... 8 | ~~~ 9 | -------------------------------------------------------------------------------- /tests/re.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | i lica.... 3 | r subr 4 | i ha...... 5 | 6 | : subr 7 | i lire.... 8 | d 10 9 | ~~~ 10 | -------------------------------------------------------------------------------- /tests/sh.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | i lilish.. 3 | d 455 4 | d -3 5 | i lilish.. 6 | d 3640 7 | d 3 8 | i ha...... 9 | ~~~ 10 | -------------------------------------------------------------------------------- /tests/st.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | i liju.... 3 | r main 4 | 5 | : abc 6 | s abc 7 | 8 | : main 9 | i lifelili 10 | r abc 11 | r abc 12 | d 1 13 | i adfelili 14 | d 48 15 | r abc 16 | i stlife.. 17 | r abc 18 | i ha...... 19 | ~~~ 20 | 21 | -------------------------------------------------------------------------------- /tests/su.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | : main 3 | i lilisuli 4 | d 100 5 | d 200 6 | d 100 7 | i lisuha.. 8 | d -99 9 | ~~~ 10 | 11 | -------------------------------------------------------------------------------- /tests/sw.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | : main 3 | i liliswli 4 | d 100 5 | d 200 6 | d 300 7 | i swha.... 8 | ~~~ 9 | 10 | -------------------------------------------------------------------------------- /tests/xo.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | : main 3 | i lilixo.. 4 | d -1 5 | d -1 6 | i lilixo.. 7 | d 0 8 | d -1 9 | i lilixo.. 10 | d 0 11 | d 0 12 | i ha...... 13 | ~~~ 14 | 15 | -------------------------------------------------------------------------------- /tests/zr.muri: -------------------------------------------------------------------------------- 1 | ~~~ 2 | i liju.... 3 | r main 4 | 5 | : c1 6 | i zr...... 7 | i drlire.. 8 | d 2 9 | 10 | : main 11 | i lilica.. 12 | d 100 13 | r c1 14 | i lilica.. 15 | d 0 16 | r c1 17 | i ha...... 18 | ~~~ 19 | -------------------------------------------------------------------------------- /tools/amalgamate-python.retro: -------------------------------------------------------------------------------- 1 | # Amalgamate 2 | 3 | The standard RETRO system is built using the Nga VM[1] and an 4 | image file. The Python implementation consists of several files, 5 | but it's nice to have a single file copy for easier deployment. 6 | This tool combines the pieces into a single source file. 7 | 8 | Output will be written to stdout. 9 | 10 | ## Code 11 | 12 | Extract and generate the single file source. 13 | 14 | ~~~ 15 | {{ 16 | :include-file 17 | ASCII:SPACE s:tokenize #1 a:fetch 18 | 'vm/nga-python/ s:prepend '.py s:append here swap file:slurp here s:put ; 19 | 20 | :source:line 21 | dup 'from_ s:begins-with? 22 | [ include-file ] [ s:put nl ] choose ; 23 | 24 | ---reveal--- 25 | 26 | :amalgamate 27 | 'vm/nga-python/retro.py [ source:line ] file:for-each-line ; 28 | }} 29 | 30 | amalgamate 31 | ~~~ 32 | -------------------------------------------------------------------------------- /tools/amalgamate.retro: -------------------------------------------------------------------------------- 1 | # Amalgamate 2 | 3 | The standard RETRO system is built using the Nga VM[1] and a 4 | copy of the image exported as a C source file[2]. I sometimes 5 | prefer to have these as a single file for easier sharing. This 6 | is a quick little tool to combine them. 7 | 8 | Output will be written to stdout. 9 | 10 | ## References 11 | 12 | [1] vm/nga-c/retro.c 13 | [2] vm/nga-c/image.c 14 | 15 | ## Code 16 | 17 | Include compilation instructions and enable i/o devices. 18 | 19 | ~~~ 20 | '/*_Build_with_`cc_-lm_-O2_retro-unix.c_-o_retro`_*/ s:put nl nl 21 | 22 | { 'FLOATS 23 | 'FILES 24 | 'UNIX 25 | 'RNG 26 | 'CLOCK 27 | 'SCRIPTING 28 | } [ '#define_ENABLE\_%s s:format s:put nl ] a:for-each nl 29 | 30 | '#define_BIT64 s:put nl 31 | ~~~ 32 | 33 | Then extract and generate the single file source. 34 | 35 | ~~~ 36 | {{ 37 | :include-file 38 | #10 + s:chop 'vm/nga-c/ s:prepend here swap file:slurp here s:put ; 39 | 40 | :source:line 41 | dup '#include_" s:begins-with? 42 | [ include-file ] [ s:put nl ] choose ; 43 | 44 | ---reveal--- 45 | 46 | :amalgamate 47 | 'vm/nga-c/retro.c [ source:line ] file:for-each-line ; 48 | }} 49 | 50 | amalgamate 51 | ~~~ 52 | -------------------------------------------------------------------------------- /tools/book-check-spelling.retro: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env retro 2 | 3 | This is used to assemble the Markdown copy of the RETRO Handbook. 4 | 5 | The individual chapters are in the `book/` directory. This is set 6 | using the `BOOK-BASE` constant. 7 | 8 | ~~~ 9 | 'doc/book/ 'BOOK-BASE s:const 10 | ~~~ 11 | 12 | The chapters are specified it the `TOC`, a named array. These are 13 | the file names, they will be included in order. I am structuring 14 | it using separate file to make the actual editing process easier 15 | for me. 16 | 17 | ~~~ 18 | 'tools/book-chapters.retro include 19 | ~~~ 20 | 21 | ~~~ 22 | TOC 23 | [ nl #1 a:fetch dup s:put nl BOOK-BASE 'spell_%s%s s:format unix:system ] 24 | a:for-each 25 | ~~~ 26 | 27 | -------------------------------------------------------------------------------- /tools/epub/chapters-to-xhtml.retro: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env retro 2 | 3 | This is used to assemble the Markdown copy of the RETRO Handbook. 4 | 5 | The individual chapters are in the `book/` directory. This is set 6 | using the `BOOK-BASE` constant. 7 | 8 | ~~~ 9 | 'doc/book/ 'BOOK-BASE s:const 10 | 'chapters/ 'OUT-BASE s:const 11 | ~~~ 12 | 13 | The chapters are specified it the `TOC`, a named array. These are 14 | the file names, they will be included in order. I am structuring 15 | it using separate file to make the actual editing process easier 16 | for me. 17 | 18 | ~~~ 19 | 'tools/book-chapters.retro include 20 | ~~~ 21 | 22 | 23 | ~~~ 24 | 'Out var 25 | 26 | :import BOOK-BASE over OUT-BASE '>%s%s.html_retro_example/markdown-to-xhtml.retro_%s%s s:format unix:system ; 27 | :assemble [ #1 a:fetch import $. c:put ] a:for-each nl ; 28 | ~~~ 29 | 30 | ~~~ 31 | TOC assemble 32 | ~~~ 33 | -------------------------------------------------------------------------------- /tools/find-deprecated.retro: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env retro 2 | 3 | This is a small tool to find use of deprecated words in the 4 | Retro source tree. 5 | 6 | It's pretty much just a wrapper over a Unix shell pipeline, 7 | but pulls the word names from an array of strings defined in 8 | Retro, so it's easy for me to add new entries as the language 9 | evolves. 10 | 11 | First, files/patterns to exclude. 12 | 13 | ~~~ 14 | { 'Glossary-Concise.txt 15 | 'Glossary-Names-and-Stack.txt 16 | 'Glossary.html 17 | 'Glossary.txt 18 | 'words.tsv 19 | 'glossary/glossary 20 | 'bin/retro-describe 21 | 'compat.retro 22 | 'compat.forth 23 | 'README 24 | 'RELEASE-NOTES 25 | } s:empty swap [ swap '%s_|_grep_-v_%s s:format ] a:for-each 26 | 'EXCLUSIONS s:const 27 | ~~~ 28 | 29 | Then the deprecated words. 30 | 31 | ~~~ 32 | { (2020.7) 33 | 'd:last 34 | 'd:last 35 | 'd:last 36 | 'file:open 37 | 'file:open 38 | 'file:open 39 | 'times 40 | 'var 41 | 42 | (2020.10) 43 | 'sys:name 44 | 'sys:argc 45 | 'sys:argv 46 | } s:empty swap [ swap '%s_"%s" s:format ] a:for-each 47 | 'DEPRECATED s:const 48 | ~~~ 49 | 50 | Construct the actual shell pipeline and run it. 51 | 52 | ~~~ 53 | EXCLUSIONS DEPRECATED 'for_name_in_%s;_do_find_._|_xargs_grep_-s_$name_|_grep_-v_find-deprecated.retro_%s_;_done 54 | s:format unix:system 55 | ~~~ 56 | 57 | -------------------------------------------------------------------------------- /tools/generate-devices.retro: -------------------------------------------------------------------------------- 1 | ~~~ 2 | '~~~ s:put nl 3 | :process (s-) 4 | dup s:length n:zero? [ drop ] if; 5 | #32 s:tokenize dup #1 a:fetch [ dup $_ eq? [ drop $: ] if ] s:map 6 | swap a:last s:to-number 7 | '#%n_'%s_const\n s:format s:put ; 8 | 9 | 'vm/nga-c/devices.h [ process ] file:for-each-line 10 | '~~~ s:put nl 11 | ~~~ 12 | -------------------------------------------------------------------------------- /tools/generate-extensions-list.retro: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env retro 2 | 3 | ~~~ 4 | '~~~ s:put nl 5 | [ ''extensions/%s_include\n s:format s:put ] unix:for-each-file 6 | '~~~ s:put nl 7 | ~~~ 8 | -------------------------------------------------------------------------------- /tools/make-book.retro: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env retro 2 | 3 | This is used to assemble the Markdown copy of the RETRO Handbook. 4 | 5 | The individual chapters are in the `book/` directory. This is set 6 | using the `BOOK-BASE` constant. 7 | 8 | ~~~ 9 | 'doc/book/ 'BOOK-BASE s:const 10 | ~~~ 11 | 12 | The chapters are specified it the `TOC`, a named array. These are 13 | the file names, they will be included in order. I am structuring 14 | it using separate file to make the actual editing process easier 15 | for me. 16 | 17 | ~~~ 18 | 'tools/book-chapters.retro include 19 | ~~~ 20 | 21 | 22 | ~~~ 23 | 'Out var 24 | 25 | :import here swap BOOK-BASE s:prepend file:slurp ; 26 | :/n ASCII:LF @Out file:write ; 27 | :add-to-book here [ @Out file:write ] s:for-each /n ; 28 | :process-files [ #1 a:fetch import add-to-book $. c:put ] a:for-each nl ; 29 | :open 'doc/RETRO-Book.md file:open-for-writing !Out ; 30 | :close @Out file:close ; 31 | :assemble open process-files close ; 32 | ~~~ 33 | 34 | ~~~ 35 | TOC assemble 36 | ~~~ 37 | -------------------------------------------------------------------------------- /tools/missing-dsource.retro: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env retro 2 | 3 | This is a quick program to display the word names and header info 4 | for words with an empty `d:source` field. 5 | 6 | ~~~ 7 | :,name dup d:name s:put ; 8 | :,dt dup n:put ; 9 | :-source? (d-df) dup d:source fetch n:zero? ; 10 | [ -source? [ ,dt tab ,name nl ] if drop ] d:for-each 11 | ~~~ 12 | -------------------------------------------------------------------------------- /tools/rename-forth-to-retro.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | for f in *.forth; do mv -- "$f" "${f%.forth}.retro" ; done 3 | for f in *.retro; do fossil rename -- "${f%.retro}.forth" "$f" ; done 4 | -------------------------------------------------------------------------------- /tools/retro-describe.retro: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env retro 2 | 3 | ~~~ 4 | script:arguments [ I script:get-argument d:describe ] indexed-times 5 | ~~~ 6 | -------------------------------------------------------------------------------- /tools/retro-document.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # This is a quick and dirty shell script to extract the words 4 | # in a source file and return the descriptions of them. 5 | # 6 | # Requirements: 7 | # 8 | # In your $PATH: 9 | # 10 | # - retro 11 | # - retro-describe 12 | # - retro-unu 13 | # 14 | # Usage: 15 | # 16 | # ./describe sourcefile 17 | 18 | retro-unu $1 | tr " " "\n" | sed '/^[[:space:]]*$/d' | grep -Ev "^[\\\^\.\"\@\!\$\`:&'#$.\(\|]" | sort | uniq | tr "\n" "\0" | xargs -0 retro-describe | cat -s 19 | retro-unu $1 | tr " " "\n" | sed '/^[[:space:]]*$/d' | cut -c1-1 | sort | uniq | grep "[\\\^\.\"\@\!\$\`:&'#$.\(\|]" | sed 's/^/sigil:/' | tr "\n" "\0" | xargs -0 retro-describe | cat -s 20 | -------------------------------------------------------------------------------- /tools/retro-embedimage.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | 3 | # retro-embedimage 4 | # 5 | # This takes an ngaImage and generates a version that provides the 6 | # image as a Python list. Output is written to stdout. 7 | # 8 | # Copyright (c) 2020, Charles Childers 9 | # Copyright (c) 2021, Arland Childers 10 | # 11 | # Usage: 12 | # 13 | # retro-embedimage.py [image] 14 | 15 | 16 | import os, sys, struct 17 | from struct import pack, unpack 18 | 19 | 20 | def prints(length, priv, end=", "): 21 | if priv != None: 22 | if length == 1: 23 | print(priv, end=end) 24 | else: 25 | print("[{},{}]".format(length, priv), end=end) 26 | 27 | 28 | if __name__ == "__main__": 29 | cells = int(os.path.getsize(sys.argv[1]) / 4) 30 | f = open(sys.argv[1], "rb") 31 | memory = list(struct.unpack(cells * "i", f.read())) 32 | f.close() 33 | count = -1 # This is counts for the extra loop at the beginning 34 | print("InitialImage = [", end="\n ") 35 | length = 1 36 | priv = None 37 | 38 | for cell in memory: 39 | if cell == priv: 40 | length += 1 41 | else: 42 | prints(length, priv) 43 | priv = cell 44 | length = 1 45 | count += 1 46 | if count >= 10: 47 | print(end="\n ") 48 | count = 0 49 | prints(length, priv, end="") 50 | print("\n]") 51 | -------------------------------------------------------------------------------- /tools/retro-unu.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | 3 | # retro-unu is a tool for extracting code from literate sources. It 4 | # will write output to stdout. 5 | # 6 | # A code block starts with ~~~ on a line by itself and ends with a 7 | # second ~~~. 8 | # 9 | # Copyright (c)2020, Charles Childers 10 | # 11 | # Usage: 12 | # 13 | # retro-unu.py filename 14 | 15 | import sys 16 | 17 | if __name__ == "__main__": 18 | f = sys.argv[1] 19 | in_block = False 20 | with open(f, "r") as source: 21 | for line in source.readlines(): 22 | if line.rstrip() == "~~~": 23 | in_block = not in_block 24 | elif in_block: 25 | print(line.rstrip()) 26 | -------------------------------------------------------------------------------- /tools/update-build.retro: -------------------------------------------------------------------------------- 1 | ~~~ 2 | BUILD n:inc '~~~\n#%n_'BUILD_const\n~~~\n s:format s:put bye 3 | ~~~ 4 | -------------------------------------------------------------------------------- /vm/libnga-zig/LICENSE: -------------------------------------------------------------------------------- 1 | awawawawawa 2 | 3 | Permission to use, copy, modify, and/or distribute this software 4 | for any purpose with or without fee is hereby granted, provided 5 | that the copyright notice and this permission notice appear in 6 | all copies. 7 | 8 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS 9 | ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL 10 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO 11 | EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 12 | INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER 13 | RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN 14 | AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, 15 | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE 16 | OF THIS SOFTWARE. 17 | 18 | src/image.c is copied from vm/nga-c/image.c from the official retro repository (https://git.sr.ht/~crc_/retroforth) 19 | -------------------------------------------------------------------------------- /vm/libnga-zig/readme.md: -------------------------------------------------------------------------------- 1 | nga VM for retroforth, in Zig. 2 | 3 | It's faster than the official C VM somehow. 4 | 5 | ## Building 6 | 7 | This project is developed with Zig 0.11.0. 8 | 9 | ``` 10 | # Build and run 11 | zig build run 12 | 13 | # Install to ~/.local/bin/retro-zig 14 | zig build -Doptimize=ReleaseFast -p ~/.local 15 | ``` 16 | -------------------------------------------------------------------------------- /vm/nga-816/LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021 Piotr Meyer 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /vm/nga-816/README.md: -------------------------------------------------------------------------------- 1 | # retro/816 2 | 3 | Port of [RETRO Forth](http://retroforth.org/) created 4 | by [Charles Childers](https://www.patreon.com/_crc) to 5 | [C256 Foenix](https://c256foenix.com/), a retro-computer 6 | based on 65c816 CPU. 7 | 8 | This port is in infancy and there are dark and spooky things inside, 9 | but at this moment is able to run simple code in 1:1 pair to one of 10 | original interpreters (`vm/nga-c/barebones`). 11 | 12 | It runs in [Foenix IDE](https://github.com/Trinity-11/FoenixIDE), 13 | it is also possible to run current, unmodified version of this 14 | port on [go65c816 emulator](https://github.com/aniou/go65c816) 15 | (use `retro.ini` parameters file here). 16 | 17 | ## obligatory screenshot 18 | 19 | ![sample run](barebones-2021-02-28.png) 20 | 21 | ## building 22 | 23 | You will need a [64tass](http://tass64.sourceforge.net/) assembler. 24 | 25 | ## rough edges 26 | 27 | * inst_di is somewhat borken - it is very crude and doesn't works 28 | with signed values 29 | 30 | * currently there are only two devices available: keyboard and 31 | standard output 32 | 33 | ## latest changes 34 | 35 | ### 2021-02-28 36 | 37 | * rename nga.asm to barebones.asm to better reflect which part 38 | of RETRO it corresponds to 39 | 40 | -------------------------------------------------------------------------------- /vm/nga-816/barebones-2021-02-28.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/crcx/retroforth/9a940927934389760261b0d9ebff16765443b3c0/vm/nga-816/barebones-2021-02-28.png -------------------------------------------------------------------------------- /vm/nga-816/barebones.image: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/crcx/retroforth/9a940927934389760261b0d9ebff16765443b3c0/vm/nga-816/barebones.image -------------------------------------------------------------------------------- /vm/nga-816/build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | NAME=barebones 3 | 4 | 64tass -Wall -Wmacro-prefix -Wshadow --verbose-list -o ${NAME}.hex -L ${NAME}.lst --intel-hex --m65816 ${NAME}.asm 5 | -------------------------------------------------------------------------------- /vm/nga-816/macros_inc.asm: -------------------------------------------------------------------------------- 1 | ; Set 8-bit accumulator 2 | setaxs .macro 3 | SEP #$30 ; set A&X short 4 | .as 5 | .xs 6 | .endm 7 | 8 | ; Set 16-bit accumulator 9 | setaxl .macro 10 | REP #$30 ; set A&X long 11 | .al 12 | .xl 13 | .endm 14 | 15 | ; Set 8-bit accumulator 16 | setas .macro 17 | SEP #$20 ; set A short 18 | .as 19 | .endm 20 | 21 | ; Set 16-bit accumulator 22 | setal .macro 23 | REP #$20 ; set A long 24 | .al 25 | .endm 26 | 27 | ; Set 8 bit index registers 28 | setxs .macro 29 | SEP #$10 ; set X short 30 | .xs 31 | .endm 32 | 33 | ; Set 16-bit index registers 34 | setxl .macro 35 | REP #$10 ; set X long 36 | .xl 37 | .endm 38 | 39 | sdb .macro ; Set the B (Data bank) register 40 | pha ; begin setdbr macro 41 | php 42 | .setas 43 | lda #\1 44 | pha 45 | plb 46 | .databank \1 47 | plp 48 | pla ; end setdbr macro 49 | .endm 50 | 51 | -------------------------------------------------------------------------------- /vm/nga-c-native-x86/386.ld: -------------------------------------------------------------------------------- 1 | ENTRY(_start) 2 | 3 | SECTIONS { 4 | . = 1M; 5 | 6 | .boot : 7 | { 8 | /* ensure that the multiboot header is at the beginning */ 9 | *(.multiboot_header) 10 | } 11 | 12 | .text : 13 | { 14 | *(.text) 15 | } 16 | 17 | .bss : 18 | { 19 | *(.bss) 20 | } 21 | } 22 | -------------------------------------------------------------------------------- /vm/nga-c-native-x86/386flat.ld: -------------------------------------------------------------------------------- 1 | OUTPUT_FORMAT("binary") 2 | ENTRY(start) 3 | SECTIONS 4 | { 5 | .text 0x100000 : { 6 | code = .; _code = .; __code = .; 7 | *(.text) 8 | . = ALIGN(4096); 9 | } 10 | .data : { 11 | data = .; _data = .; __data = .; 12 | *(.data) 13 | . = ALIGN(4096); 14 | } 15 | .bss : 16 | { 17 | bss = .; _bss = .; __bss = .; 18 | *(.bss) 19 | . = ALIGN(4096); 20 | } 21 | end = .; _end = .; __end = .; 22 | } 23 | -------------------------------------------------------------------------------- /vm/nga-c-native-x86/Makefile: -------------------------------------------------------------------------------- 1 | all: native386 clean 2 | 3 | native386: 4 | cp ../../ngaImage nativeImage 5 | ../../bin/retro-extend nativeImage x86/common.retro x86/cmos-rtc.retro x86/serial.retro x86/display.retro x86/ata.retro x86/listener.retro 6 | # x86/Block-Editor.retro 7 | # ../../bin/retro-embedimage nativeImage >image.c 8 | cc -fno-pie -Wall -m32 -DTARGET_X86 -c retro.c -o retro_qwerty.o 9 | cc -fno-pie -Wall -m32 -DTARGET_X86 -DUSE_DVORAK -c retro.c -o retro_dvorak.o 10 | nasm -f elf 386.s 11 | ld -z notext -nostdlib -m elf_i386 -T 386.ld 386.o retro_qwerty.o -o bin/rnf_qwerty.386 12 | ld -z notext -nostdlib -m elf_i386 -T 386.ld 386.o retro_dvorak.o -o bin/rnf_dvorak.386 13 | 14 | clean: 15 | rm -f *.o 16 | # rm bin/rf.* 17 | -------------------------------------------------------------------------------- /vm/nga-c-native-x86/README.md: -------------------------------------------------------------------------------- 1 | RETRO/NATIVE 2 | --------------------------------------------------------------- 3 | This directory contains some experiments in building a RETRO 4 | system to run directly on hardware. As a stepping stone, it 5 | also includes some builds which require a host kernel, but no 6 | standard C library. 7 | 8 | Initial Objectives: 9 | 10 | - Reuse as much of the existing VM implementation (in C) as 11 | possible. 12 | - Don't require a full blown kernel & userland to run 13 | - Work with a completely standard RETRO image 14 | - Minimally viable system: the basic listener (REPL) 15 | - Work on 32-bit x86 systems 16 | 17 | Future Goals: 18 | 19 | - Support for more processors 20 | 21 | - x86-64 22 | - ARM (32-bit) 23 | - ARM (64-bit) 24 | - RISC-V 25 | - MIPS M4K (PIC32) 26 | 27 | Current Status: 28 | 29 | - Working builds w/minimal host dependencies: 30 | 31 | - FreeBSD (32-bit, x86) 32 | - FreeBSD (64-bit, x86) 33 | - Linux (32-bit, x86) 34 | - Native (32-bit, x86, multiboot) 35 | -------------------------------------------------------------------------------- /vm/nga-c-native-x86/bin/.keep: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/crcx/retroforth/9a940927934389760261b0d9ebff16765443b3c0/vm/nga-c-native-x86/bin/.keep -------------------------------------------------------------------------------- /vm/nga-c-native-x86/x86/cmos-rtc.retro: -------------------------------------------------------------------------------- 1 | # CMOS RTC 2 | 3 | ~~~ 4 | #112 'CMOS:ADDRESS const 5 | #113 'CMOS:DATA const 6 | 7 | :rtc:query CMOS:ADDRESS pio:out-byte CMOS:DATA pio:in-byte ; 8 | :rtc:second #0 rtc:query ; 9 | :rtc:minute #2 rtc:query ; 10 | :rtc:hour #4 rtc:query ; 11 | :rtc:day #7 rtc:query ; 12 | :rtc:month #8 rtc:query ; 13 | :rtc:year #9 rtc:query ; 14 | 15 | :time rtc:hour n:put $: c:put rtc:minute n:put nl ; 16 | ~~~ 17 | -------------------------------------------------------------------------------- /vm/nga-c-native-x86/x86/common.retro: -------------------------------------------------------------------------------- 1 | # x86 Device Drivers 2 | 3 | This exposes the low level port I/O device to RETRO. These 4 | will be used in the implementation of the device drivers. 5 | 6 | ~~~ 7 | {{ 8 | 'io:X86 var 9 | :identify 10 | @io:X86 n:zero? [ 11 | #2000 io:scan-for dup n:negative? 12 | [ drop 'IO_DEVICE_TYPE_2000_NOT_FOUND s:put nl ] 13 | [ !io:X86 ] choose ] if ; 14 | ---reveal--- 15 | :io:x86 identify @io:X86 io:invoke ; 16 | }} 17 | ~~~ 18 | 19 | # I/O Ports 20 | 21 | ~~~ 22 | :pio:in-byte (p-n) #0 io:x86 ; 23 | :pio:out-byte (vp-) #1 io:x86 ; 24 | :pio:in-word (p-n) #6 io:x86 ; 25 | :pio:out-word (vp-) #7 io:x86 ; 26 | ~~~ 27 | 28 | # Access to Physical RAM 29 | 30 | ~~~ 31 | :ram:store (va-) #2 io:x86 ; 32 | :ram:fetch (a-v) #3 io:x86 ; 33 | :ram:store-byte (va-) #4 io:x86 ; 34 | :ram:fetch-byte (a-v) #5 io:x86 ; 35 | ~~~ 36 | 37 | # Hexadecimal 38 | 39 | Since most resources list the values and ports in hex, I 40 | am defining a prefix to be used. This will allow for hex 41 | values to be specified like `0xC3`. They must be caps, and 42 | negative values are not supported. 43 | 44 | ~~~ 45 | {{ 46 | :hex (s-n) 47 | dup fetch $- eq? [ n:inc #-1 ] [ #0 ] choose swap 48 | #0 swap [ '0123456789ABCDEF swap s:index/char + #16 * ] s:for-each 49 | #16 / swap 0; * ; 50 | ---reveal--- 51 | :sigil:0 (s-...) 52 | dup n:dec d:lookup n:-zero? 53 | [ n:dec d:lookup [ d:xt fetch ] [ d:class fetch ] bi call ] if; 54 | n:inc hex class:data ; immediate 55 | }} 56 | ~~~ 57 | -------------------------------------------------------------------------------- /vm/nga-c-native-x86/x86/keyboard.retro: -------------------------------------------------------------------------------- 1 | ~~~ 2 | 0x60 'keyboard:DATA const 3 | 0x64 'keyboard:STATUS const 4 | 5 | :keyboard:wait 6 | [ keyboard:STATUS pio:in-byte #1 and n:-zero? ] until ; 7 | 8 | :keyboard:read 9 | keyboard:DATA pio:in-byte ; 10 | 11 | :uuu 12 | keyboard:wait 13 | #0 [ drop keyboard:read 0x7F and dup 0x39 gt? [ drop keyboard:wait #0 ] if dup #0 -eq? ] until ; 14 | 15 | 'keyboard:Dvorak d:create 16 | #0 , #27 , $1 , $2 , $3 , $4 , $5 , $6 , $7 , $8 , $9 , $0 , $[ , $] , #8 , 17 | #9 , $' , $, , $. , $p , $y , $f , $g , $c , $r , $l , $/ , $= , #10 , 18 | #-1 , $a , $o , $e , $u , $i , $d , $h , $t , $n , $s , $- , $` , 19 | #-1 , $\ , $; , $q , $j , $k , $x , $b , $m , $w , $v , $z , 20 | #-1 , $* , #0 , #32 , #32 , 21 | 22 | 'keyboard:Dvorak:Shifted d:create 23 | #0 , #27 , $! , $@ , $# , $$ , $% , $^ , $& , $* , $( , $) , ${ , $} , #8 , 24 | #9 , $" , $< , $> , $P , $Y , $F , $G , $C , $R , $L , $? , $+ , #10 , 25 | #-1 , $A , $O , $E , $U , $I , $D , $H , $T , $N , $S , $_ , $~ , 26 | #-1 , $| , $: , $Q , $J , $K , $X , $B , $M , $W , $V , $Z , 27 | #-1 , $* , #0 , #32 , #32 , 28 | 29 | {{ 30 | :n &keyboard:Dvorak + fetch ; 31 | :N &keyboard:Dvorak:Shifted + fetch ; 32 | ---reveal--- 33 | :getc uuu drop uuu n dup #-1 eq? [ drop uuu drop uuu N ] if dup c:put ; 34 | }} 35 | ~~~ 36 | 37 | -------------------------------------------------------------------------------- /vm/nga-c-native-x86/x86/listener.retro: -------------------------------------------------------------------------------- 1 | ~~~ 2 | {{ 3 | :eol? (c-f) 4 | [ ASCII:CR eq? ] [ ASCII:LF eq? ] [ ASCII:SPACE eq? ] tri or or ; 5 | 6 | :valid? (s-sf) 7 | dup s:length n:-zero? ; 8 | 9 | :check-bs (c-c) 10 | dup [ #8 eq? ] [ #127 eq? ] bi or [ buffer:get buffer:get drop-pair ] if ; 11 | ---reveal--- 12 | :c:get (-c) hook \liii.... `1 dup c:put ; 13 | 14 | :s:get-word (-s) [ #1025 buffer:set 15 | [ c:get dup buffer:add check-bs eol? ] until 16 | buffer:start s:chop ] buffer:preserve ; 17 | 18 | :s:get (-s) [ #1025 buffer:set 19 | [ c:get dup buffer:add check-bs [ ASCII:CR eq? ] [ ASCII:LF eq? ] bi or ] until 20 | buffer:start s:chop ] buffer:preserve ; 21 | 22 | :listen (-) 23 | vga:initialize 24 | clear 'RETRO/Native s:put sp @Version #100 /mod n:put $. c:put n:put nl 25 | repeat s:get-word valid? &interpret &drop choose again ; 26 | 27 | &listen #1 store 28 | [ $? c:put sp 'word_not_found s:put nl ] &err:notfound set-hook 29 | }} 30 | ~~~ 31 | -------------------------------------------------------------------------------- /vm/nga-c-native-x86/x86/serial.retro: -------------------------------------------------------------------------------- 1 | # Serial Port 2 | 3 | This was adapted from the RETRO9 serial driver. To use it, 4 | set the `serial:Port` variable to the port you want to use. 5 | Then do `serial:init` and read/write as necessary. 6 | 7 | ~~~ 8 | #1016 'serial:COM1 const 9 | #760 'serial:COM2 const 10 | #1000 'serial:COM3 const 11 | #744 'serial:COM4 const 12 | serial:COM1 'serial:Port var-n 13 | 14 | :serial:received? @serial:Port #5 + pio:in-byte #1 and n:-zero? ; 15 | :serial:empty? @serial:Port #5 + pio:in-byte #32 and n:-zero? ; 16 | :serial:read serial:received? [ @serial:Port pio:in-byte ] if; serial:read ; 17 | :serial:write serial:empty? [ @serial:Port pio:out-byte ] if; serial:write ; 18 | :serial:send [ serial:write ] s:for-each ; 19 | :serial:init #0 @serial:Port #1 + pio:out-byte #128 @serial:Port #3 + pio:out-byte 20 | #3 @serial:Port pio:out-byte #0 @serial:Port #1 + pio:out-byte 21 | #3 @serial:Port #3 + pio:out-byte #199 @serial:Port #2 + pio:out-byte 22 | #11 @serial:Port #4 + pio:out-byte ; 23 | ~~~ 24 | -------------------------------------------------------------------------------- /vm/nga-c-no-libc/Makefile: -------------------------------------------------------------------------------- 1 | default: 2 | @echo specify the target: 3 | @echo - freebsd-i386 4 | @echo - freebsd-amd64 5 | @echo - linux-i386 6 | @echo - macos-amd64 7 | @echo - openbsd-amd64 8 | 9 | common: 10 | mkdir -p bin 11 | cp ../../ngaImage nativeImage 12 | ../../bin/retro-embedimage nativeImage >image.c 13 | rm nativeImage 14 | 15 | clean: 16 | rm *.o 17 | 18 | bsd-i386: 19 | nasm -f elf bsd-i386.s 20 | 21 | bsd-amd64.o: bsd-amd64.s 22 | cc -c bsd-amd64.s -o bsd-amd64.o 23 | 24 | freebsd-i386: common bsd-i386 25 | cc -m32 -c retro.c 26 | ld -nostdlib -m elf_i386_fbsd bsd-i386.o retro.o -o bin/retro 27 | 28 | freebsd-amd64: common bsd-amd64.o 29 | cc -m64 -c retro.c 30 | ld -nostdlib -no-pie -m elf_x86_64_fbsd bsd-amd64.o retro.o -o bin/retro 31 | 32 | openbsd-amd64: common bsd-amd64.o 33 | cc -m64 -c retro.c 34 | ld -nostdlib -no-pie -m elf_x86_64 bsd-amd64.o retro.o -o bin/retro 35 | 36 | macos-amd64: common 37 | cc -m64 -fno-pie -c retro.c 38 | nasm -f macho64 macos.s 39 | ld macos.o retro.o -o bin/retro 40 | 41 | linux-i386: common 42 | cc -m32 -c retro.c 43 | nasm -f elf linux.s 44 | ld -nostdlib linux.o retro.o -o bin/retro 45 | -------------------------------------------------------------------------------- /vm/nga-c-no-libc/README: -------------------------------------------------------------------------------- 1 | RETRO/Minimal (No LIBC) 2 | --------------------------------------------------------------- 3 | This is a collection of minimal RETRO interfaces for various 4 | systems. Though using a VM written in C, they do not require 5 | linking against LIBC, instead using system calls to interact 6 | with the host. 7 | 8 | Current Implementations: 9 | 10 | - FreeBSD (32-bit, x86) 11 | - FreeBSD (64-bit, x86) 12 | - Linux (32-bit, x86) 13 | - macOS (64-bit, x86) 14 | --------------------------------------------------------------- 15 | -------------------------------------------------------------------------------- /vm/nga-c-no-libc/bsd-amd64.s: -------------------------------------------------------------------------------- 1 | .section ".note.openbsd.ident", "a" 2 | .p2align 2 3 | .long 0x8 4 | .long 0x4 5 | .long 0x1 6 | .ascii "OpenBSD\0" 7 | .long 0x0 8 | .p2align 2 9 | 10 | .section .text 11 | .global putchar 12 | .global getchar 13 | .global _start 14 | .extern main 15 | 16 | .p2align 8 17 | _start: 18 | call main 19 | movl $0x0,%edi 20 | movq $0x1,%rax 21 | syscall 22 | 23 | putchar: 24 | mov %rdi,%rax 25 | mov %eax,buf 26 | mov $0x4,%rax 27 | mov $0x1,%rdi 28 | mov $buf,%rsi 29 | mov $0x1,%rdx 30 | syscall 31 | retq 32 | 33 | getchar: 34 | mov $0x3,%rax 35 | mov $0x0,%rdi 36 | mov $buf,%rsi 37 | mov $0x1,%rdx 38 | syscall 39 | mov $0x0,%rax 40 | mov buf,%eax 41 | retq 42 | 43 | .section .data 44 | buf: 45 | .long 0 46 | -------------------------------------------------------------------------------- /vm/nga-c-no-libc/bsd-i386.s: -------------------------------------------------------------------------------- 1 | ; ___ ___ _____ ___ ___ __ ___ ___ ___ ___ 2 | ; | _ \ __|_ _| _ \/ _ \ / / | __| _ ___ ___| _ ) __| \ 3 | ; | / _| | | | / (_) | / / | _| '_/ -_) -_) _ \__ \ |) | 4 | ; |_|_\___| |_| |_|_\\___/ /_/ |_||_| \___\___|___/___/___/ 5 | ; 6 | ; This is the minimal startup + I/O functionality needed to run 7 | ; RETRO on a FreeBSD x86 system. 8 | ; ============================================================= 9 | 10 | bits 32 11 | section .text 12 | global putchar 13 | global getchar 14 | global _start 15 | extern main 16 | 17 | align 4 18 | _start: 19 | call main 20 | jmp $ 21 | 22 | align 4 23 | putchar: 24 | mov eax, [esp+4] 25 | mov [buf], eax 26 | push dword 1 27 | push dword buf 28 | push dword 1 29 | mov eax, 4 30 | call kernel 31 | add esp, 12 32 | ret 33 | 34 | align 4 35 | getchar: 36 | push dword 1 37 | push dword buf 38 | push dword 0 39 | mov eax, 3 40 | call kernel 41 | add esp, 12 42 | mov eax, 0 43 | mov eax, [buf] 44 | ret 45 | 46 | align 4 47 | kernel: 48 | int 80h 49 | ret 50 | 51 | section .data 52 | buf: 53 | dd 0 54 | dd 0 55 | dd 0 56 | dd 0 57 | -------------------------------------------------------------------------------- /vm/nga-c-no-libc/linux.s: -------------------------------------------------------------------------------- 1 | ; ___ ___ _____ ___ ___ __ _ _ 2 | ; | _ \ __|_ _| _ \/ _ \ / / | | (_)_ _ _ ___ __ 3 | ; | / _| | | | / (_) | / / | |__| | ' \ || \ \ / 4 | ; |_|_\___| |_| |_|_\\___/ /_/ |____|_|_||_\_,_/_\_\ 5 | ; 6 | ; This is the minimal startup + I/O functionality needed to run 7 | ; RETRO on a Linux x86 system. 8 | ; ============================================================= 9 | 10 | bits 32 11 | 12 | section .text 13 | global putchar 14 | global getchar 15 | global _start 16 | extern main 17 | 18 | align 4 19 | 20 | _start: 21 | call main 22 | jmp $ 23 | 24 | align 4 25 | putchar: 26 | mov eax, [esp+4] 27 | mov [buf], eax 28 | mov edx, 1 29 | mov ecx, buf 30 | mov ebx, 1 31 | mov eax, 4 32 | int 0x80 33 | ret 34 | 35 | align 4 36 | getchar: 37 | mov edx, 1 38 | mov ecx, buf 39 | mov ebx, 0 40 | mov eax, 3 41 | int 0x80 42 | mov eax, 0 43 | mov eax, [buf] 44 | ret 45 | 46 | section .data 47 | buf: 48 | dd 0 49 | dd 0 50 | dd 0 51 | dd 0 52 | -------------------------------------------------------------------------------- /vm/nga-c-no-libc/macos.s: -------------------------------------------------------------------------------- 1 | ; ___ ___ _____ ___ ___ __ ___ ___ ___ ___ 2 | ; | _ \ __|_ _| _ \/ _ \ / / | __| _ ___ ___| _ ) __| \ 3 | ; | / _| | | | / (_) | / / | _| '_/ -_) -_) _ \__ \ |) | 4 | ; |_|_\___| |_| |_|_\\___/ /_/ |_||_| \___\___|___/___/___/ 5 | ; 6 | ; This is the minimal startup + I/O functionality needed to run 7 | ; RETRO on a FreeBSD x86-64 system. 8 | ; ============================================================= 9 | 10 | bits 64 11 | section .text 12 | global _putchar 13 | global _getchar 14 | global _start 15 | extern _main 16 | global start 17 | 18 | align 8 19 | start: 20 | _start: 21 | call _main 22 | jmp $ 23 | 24 | align 8 25 | _putchar: 26 | mov rax, rdi 27 | mov [rel buf], eax 28 | mov rax, 0x2000004; sys_write 29 | mov rdi, 1 ; stdout 30 | mov rsi, buf ; address 31 | mov rdx, 1 ; 1 byte 32 | syscall 33 | ret 34 | 35 | align 8 36 | _getchar: 37 | mov rax, 0x2000003; sys_read 38 | mov rdi, 0 ; stdin 39 | mov rsi, buf ; address 40 | mov rdx, 1 ; 1 byte 41 | syscall 42 | mov rax, 0 43 | mov eax, [rel buf] 44 | ret 45 | 46 | section .data 47 | buf: 48 | dd 0 49 | dd 0 50 | dd 0 51 | dd 0 52 | -------------------------------------------------------------------------------- /vm/nga-c/dev-ffi.c: -------------------------------------------------------------------------------- 1 | /************************************************************** 2 | _ __ _ _ 3 | _ __ ___| |_ _ __ ___ / _| ___ _ __| |_| |__ 4 | | '__/ _ \ __| '__/ _ \| |_ / _ \| '__| __| '_ \ 5 | | | | __/ |_| | | (_) | _| (_) | | | |_| | | | 6 | |_| \___|\__|_| \___/|_| \___/|_| \__|_| |_| 7 | for nga 8 | 9 | (c) Charles Childers, Luke Parrish, Marc Simpsonn, 10 | Jay Skeer, Kenneth Keating 11 | 12 | **************************************************************/ 13 | 14 | 15 | #ifdef ENABLE_FFI 16 | #include 17 | 18 | typedef void (*External)(void *); 19 | 20 | V *handles[32]; 21 | External funcs[32000]; 22 | int nlibs, nffi; 23 | 24 | V open_library(NgaState *vm) { 25 | handles[nlibs] = dlopen(string_extract(vm, stack_pop(vm)), RTLD_LAZY); 26 | stack_push(vm, nlibs); 27 | nlibs++; 28 | } 29 | 30 | V map_symbol(NgaState *vm) { 31 | int h; 32 | h = stack_pop(vm); 33 | char *s = string_extract(vm, stack_pop(vm)); 34 | funcs[nffi] = dlsym(handles[h], s); 35 | stack_push(vm, nffi); 36 | nffi++; 37 | } 38 | 39 | V invoke(NgaState *vm) { 40 | funcs[stack_pop(vm)](vm); 41 | } 42 | 43 | V io_ffi(NgaState *vm) { 44 | switch (stack_pop(vm)) { 45 | case 0: open_library(vm); break; 46 | case 1: map_symbol(vm); break; 47 | case 2: invoke(vm); break; 48 | } 49 | } 50 | 51 | V query_ffi(NgaState *vm) { 52 | stack_push(vm, 0); 53 | stack_push(vm, DEVICE_FFI); 54 | } 55 | #endif 56 | -------------------------------------------------------------------------------- /vm/nga-c/dev-rng.c: -------------------------------------------------------------------------------- 1 | /************************************************************** 2 | _ __ _ _ 3 | _ __ ___| |_ _ __ ___ / _| ___ _ __| |_| |__ 4 | | '__/ _ \ __| '__/ _ \| |_ / _ \| '__| __| '_ \ 5 | | | | __/ |_| | | (_) | _| (_) | | | |_| | | | 6 | |_| \___|\__|_| \___/|_| \___/|_| \__|_| |_| 7 | for nga 8 | 9 | (c) Charles Childers, Luke Parrish, Marc Simpsonn, 10 | Jay Skeer, Kenneth Keating 11 | 12 | **************************************************************/ 13 | 14 | #ifdef ENABLE_RNG 15 | V io_rng(NgaState *vm) { 16 | int64_t r = 0; 17 | char buffer[8]; 18 | int i; 19 | ssize_t ignore; 20 | int fd = open("/dev/urandom", O_RDONLY); 21 | ignore = read(fd, buffer, 8); 22 | close(fd); 23 | for(i = 0; i < 8; ++i) { 24 | r = r << 8; 25 | r += ((int64_t)buffer[i] & 0xFF); 26 | } 27 | #ifndef BIT64 28 | stack_push(vm, (CELL)abs((CELL)r)); 29 | #else 30 | stack_push(vm, (CELL)llabs((CELL)r)); 31 | #endif 32 | } 33 | 34 | V query_rng(NgaState *vm) { 35 | stack_push(vm, 0); 36 | stack_push(vm, DEVICE_RNG); 37 | } 38 | #endif 39 | -------------------------------------------------------------------------------- /vm/nga-c/devices.h: -------------------------------------------------------------------------------- 1 | #define DEVICE_OUTPUT 0 2 | #define DEVICE_KEYBOARD 1 3 | #define DEVICE_FLOATS 2 4 | #define DEVICE_FILES 4 5 | #define DEVICE_BLOCKS 3 6 | #define DEVICE_CLOCK 5 7 | #define DEVICE_RESERVED6 6 8 | #define DEVICE_SOCKETS 7 9 | #define DEVICE_UNIX 8 10 | #define DEVICE_SCRIPTING 9 11 | #define DEVICE_RNG 10 12 | #define DEVICE_RESERVED11 11 13 | #define DEVICE_RESERVED12 12 14 | #define DEVICE_RESERVED13 13 15 | #define DEVICE_IOCTL 14 16 | #define DEVICE_MALLOC 15 17 | 18 | #define DEVICE_IMAGE 1000 19 | #define DEVICE_ERROR 1234 20 | #define DEVICE_MULTICORE 8000 21 | #define DEVICE_FFI 8100 22 | #define DEVICE_UNSIGNED 8101 23 | -------------------------------------------------------------------------------- /vm/nga-c/retro.fnt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/crcx/retroforth/9a940927934389760261b0d9ebff16765443b3c0/vm/nga-c/retro.fnt -------------------------------------------------------------------------------- /vm/nga-c/utf32.c: -------------------------------------------------------------------------------- 1 | size_t utf32_strlen(const int32_t *utf32_str) { 2 | size_t length = 0; 3 | while (utf32_str[length] != 0) { 4 | length++; 5 | } 6 | return length; 7 | } 8 | 9 | void utf32_strcpy(int32_t *dest, const int32_t *src) { 10 | while ((*dest++ = *src++) != 0); 11 | } 12 | 13 | int utf32_strcmp(const int32_t *str1, const int32_t *str2) { 14 | while (*str1 && (*str1 == *str2)) { 15 | str1++; 16 | str2++; 17 | } 18 | return *str1 - *str2; 19 | } 20 | 21 | void c_to_utf32(const char *source, int32_t *dest, int max) { 22 | int i = 0; 23 | while (source[i] != '\0' && i < max - 1) { 24 | dest[i] = (int32_t)source[i]; 25 | i++; 26 | } 27 | dest[i] = 0; 28 | } 29 | 30 | void utf32_to_c(const int32_t *source, char *dest, int max) { 31 | int i = 0; 32 | while (source[i] != 0 && i < max - 1) { 33 | if (source[i] <= 0x7F) { 34 | dest[i] = (char)source[i]; 35 | } else { 36 | dest[i] = '?'; 37 | } 38 | i++; 39 | } 40 | dest[i] = '\0'; 41 | } 42 | -------------------------------------------------------------------------------- /vm/nga-js/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | RETRO FORTH 6 | 7 | 8 | 9 | 10 | 11 | 12 |
13 | 15 | 16 |
17 |
18 |
19 | 20 | 21 |
22 | 23 | 24 |
25 | 26 | 27 | 28 | -------------------------------------------------------------------------------- /vm/nga-pascal/nga.inc: -------------------------------------------------------------------------------- 1 | // ******************************************************** 2 | // Copyright (c) 2016 Rob Judd 3 | // Copyright (c) 2018 Charles Childers 4 | // Based on C version by Charles Childers et al 5 | // ISC License - see included file LICENSE 6 | // ******************************************************** 7 | 8 | type 9 | Cell = Longint; 10 | 11 | const 12 | STACK_DEPTH = 32; 13 | ADDRESSES = 128; 14 | IMAGE_SIZE = 524288; 15 | NUM_OPS = 30; 16 | 17 | {$define TOS := data[sp]} 18 | {$define NOS := data[sp-1]} 19 | {$define TOA := address[ap]} 20 | 21 | -------------------------------------------------------------------------------- /vm/nga-python/BenchmarkDevice.py: -------------------------------------------------------------------------------- 1 | # Benchmark Support 2 | # 3 | # This is intended to help support benchmarking by 4 | # providing high resolution timing and instruction 5 | # usage data. 6 | # 7 | 8 | import time 9 | 10 | 11 | class BenchmarkDevice: 12 | def __init__(self): 13 | pass 14 | 15 | def execute(self, retro_instance, pointer): 16 | return 0 17 | 18 | def timer_resolution(self): 19 | try: 20 | time.time_ns() 21 | return 1 22 | except: 23 | return 0 24 | -------------------------------------------------------------------------------- /vm/nga-python/ClockDevice.py: -------------------------------------------------------------------------------- 1 | class Clock: 2 | def __getitem__(self, id): 3 | import datetime 4 | import time 5 | 6 | now = datetime.datetime.now() 7 | ids = { 8 | "time": time.time, 9 | "year": now.year, 10 | "month": now.month, 11 | "day": now.day, 12 | "hour": now.hour, 13 | "minute": now.minute, 14 | "second": now.second, 15 | # No time_utc? 16 | "year_utc": now.utcnow().year, 17 | "month_utc": now.utcnow().month, 18 | "day_utc": now.utcnow().day, 19 | "hour_utc": now.utcnow().hour, 20 | "minute_utc": now.utcnow().minute, 21 | "second_utc": now.utcnow().second, 22 | } 23 | return ids[id] 24 | -------------------------------------------------------------------------------- /vm/nga-python/IntegerStack.py: -------------------------------------------------------------------------------- 1 | class IntegerStack(list): 2 | def __init__(self): 3 | stack = [] * 128 4 | self.extend(stack) 5 | 6 | def depth(self): 7 | return len(self) 8 | 9 | def tos(self): 10 | return self[-1] 11 | 12 | def push(self, v): 13 | self.append(v) 14 | 15 | def dup(self): 16 | self.append(self[-1]) 17 | 18 | def drop(self): 19 | self.pop() 20 | 21 | def swap(self): 22 | a = self[-2] 23 | self[-2] = self[-1] 24 | self[-1] = a 25 | -------------------------------------------------------------------------------- /vm/nga-python/Memory.py: -------------------------------------------------------------------------------- 1 | import os 2 | import struct 3 | 4 | 5 | class Memory(list): 6 | def __init__(self, source, initial, size): 7 | m = [0] * size 8 | self.extend(m) 9 | if len(initial) == 0: 10 | cells = int(os.path.getsize(source) / 4) 11 | f = open(source, "rb") 12 | i = 0 13 | for cell in list(struct.unpack(cells * "i", f.read())): 14 | self[i] = cell 15 | i = i + 1 16 | f.close() 17 | else: 18 | i = 0 19 | for cell in initial: 20 | if type(cell) == list: 21 | for v in range(0, cell[0]): 22 | self[i] = cell[1] 23 | i = i + 1 24 | else: 25 | self[i] = cell 26 | i = i + 1 27 | 28 | def load_image(self, name): 29 | cells = int(os.path.getsize(name) / 4) 30 | f = open(name, "rb") 31 | i = 0 32 | for cell in list(struct.unpack(cells * "i", f.read())): 33 | self[i] = cell 34 | i = i + 1 35 | f.close() 36 | 37 | def size(self): 38 | return len(self) 39 | -------------------------------------------------------------------------------- /vm/nga-python/RNGDevice.py: -------------------------------------------------------------------------------- 1 | import random 2 | 3 | 4 | class RNG: 5 | def __call__(self): 6 | return random.randint(-2147483647, 2147483646) 7 | --------------------------------------------------------------------------------