├── .gitignore ├── LICENSE.txt ├── README.md ├── es.js ├── examples ├── fact-explicated.hf ├── fact.f ├── fact.hf ├── fibo.f └── fibo.hf ├── f2e.js ├── gloss.js ├── lib ├── e2f.js ├── emojistack.js └── jsforth.js └── package.json /.gitignore: -------------------------------------------------------------------------------- 1 | .vagrant 2 | node_modules 3 | .idea 4 | .cache 5 | bower_components 6 | 7 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013 Neil Kandalgaonkar 2 | 3 | MIT License 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining 6 | a copy of this software and associated documentation files (the 7 | "Software"), to deal in the Software without restriction, including 8 | without limitation the rights to use, copy, modify, merge, publish, 9 | distribute, sublicense, and/or sell copies of the Software, and to 10 | permit persons to whom the Software is furnished to do so, subject 11 | to the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be 14 | included in all copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 19 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR 20 | ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF 21 | CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 22 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 23 | 24 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | # HeartForth 3 | ❤ 💞 💕 💘 💕 💘 ❤ 💞 4 | 5 | An Emoji stack language 6 | 7 | ## Synopsis 8 | 9 | *Instead of standard Forth...* 10 | 11 | ``` 12 | : factorial 0 swap begin dup 1 - dup 1 = until begin * over 0 = until swap drop ; 13 | 14 | 5 factorial . 15 | 16 | >> 120 17 | ``` 18 | 19 | *In HeartForth, factorial would be...* 20 | 21 | > 😀💥0💞👉💕1➖💕1🙏👍👉✖💑0🙏👍💞💔😉 22 | > 23 | > 5💥😘 24 | > 25 | > `>> 120` 26 | 27 | *And Fibonacci...* 28 | 29 | > 😀🌿0 1💘0✋💑➕💞💕😘👌💔😉 30 | > 31 | > 10🌿 32 | > 33 | > `>> 0 1 1 2 3 5 8 13 21 34` 34 | 35 | 36 | ## Discussion 37 | 38 | HeartForth is a dialect of 39 | [Forth](https://en.wikipedia.org/wiki/Forth_%28programming_language%29), a 40 | [stack-oriented](https://en.wikipedia.org/wiki/Stack-oriented_programming_language) 41 | language. Where other programming languages use many data structures, 42 | Forth has a wealth of operators to manipulate the stack. Emoji 43 | has a large number of symbols which incorporate hearts. So.... 44 | 45 | | HeartForth | Standard Forth | meaning | 46 | | --- | --- | --- | 47 | | 💕 | dup | ( a -> a a ) | 48 | | 💔 | drop | ( a -> ) | 49 | | 💑 | over | ( a b -> a b a ) | 50 | | 💘 | rot | ( a b c -> b c a ) | 51 | | 💞 | swap | ( a b -> b a ) | 52 | | 😘 | . | *show last item on stack* | 53 | | ❤ | dump | *show entire stack* | 54 | 55 | ## Advantages 56 | 57 | * Extremely compact. 58 | * Clean visual separation between program and data. 59 | * Whitespace agnostic. 60 | * Fully internationalized; no bias for English speakers. 61 | 62 | ## Disadvantages 63 | 64 | * None. 65 | 66 | ## Motivation 67 | 68 | My friend Ian Baker [wondered](https://twitter.com/raindrift/status/547536961171226625) whether 69 | anyone had yet made an all-Emoji programming language. My [first 70 | thought](https://twitter.com/flipzagging/status/547815119473086465) was 71 | to do a Lisp, but I was disappointed in how much the parentheses 🌘 🌒 72 | dominated the visual look. What we needed was a language which 73 | was more stream-of-consciousness, like the way people use Emoji 74 | already. 75 | 76 | A long time ago I had used another stack-based language, 77 | [PostScript](https://en.wikipedia.org/wiki/PostScript). They have 78 | this curious property of being streams of keywords with some data 79 | mixed in. Just like a block of Emoji. Once I realized I could match 80 | hearts to stack operators I knew I was onto something. The "revolving hearts" 💞 symbol 81 | almost begs to be `swap`, and hearts have something to do with 82 | holding something close or remembering it. 83 | 84 | I originally tried implementing a new stack language in pure JavaScript, which was 85 | surprisingly easy to get started but surprisingly hard to do things like 86 | recursion well. So I decided to simply source-translate to an existing 87 | Forth implementation instead. 88 | 89 | ## Complete glossary (so far) 90 | 91 | | HeartForth | Standard Forth | meaning | 92 | | --- | --- | --- | 93 | | 💕 | dup | ( a -> a a ) | 94 | | 💔 | drop | ( a -> ) | 95 | | 💑 | over | ( a b -> a b a ) | 96 | | 💘 | rot | ( a b c -> b c a ) | 97 | | 💞 | swap | ( a b -> b a ) | 98 | | 😘 | . | *show last item on stack* | 99 | | ❤ | dump | *show entire stack* | 100 | | ➕ | + | *add* | 101 | | ➖ | - | *subtract* | 102 | | ✖ | * | *multiply* | 103 | | ➗ | / | *divide* | 104 | | 🙏 | = | *equals* | 105 | | 📢 | > | *greater than* | 106 | | 📡 | < | *less than* | 107 | | 😀 | : | *begin function definition*| 108 | | 😉 | ; | *end function definition*| 109 | | ✋ | ?do | *do block if > 0* | 110 | | 👌 | loop | *loop* | 111 | | 👉 | begin | *start block* | 112 | | 👍 | until | *end loop condition* | 113 | | 👐 | if | *if* | 114 | | 👏 | then | *then* | 115 | 116 | 117 | ## Thanks to 118 | 119 | Aadit M. Shah posted [this answer](https://stackoverflow.com/questions/13466600/how-would-i-go-about-implementing-a-simple-stack-based-programming-language) 120 | on Stack Exchange, which helped me get started. 121 | 122 | The [repl.it](https://github.com/replit) project and [ForthFreak](http://forthfreak.net/jsforth80x25.html) for bringing Forth to JavaScript. 123 | 124 | ## Mirrored 125 | 126 | On my blog at [neilk.net](http://neilk.net/blog/2015/02/14/heartforth/). 127 | 128 | ## Dedication 129 | 130 | *For my lovely girlfriend Melanie. I heart you 100 factorial .* 131 | 132 | -------------------------------------------------------------------------------- /es.js: -------------------------------------------------------------------------------- 1 | var readline = require('readline'); 2 | var forth = require('./lib/jsforth'); 3 | var e2f = require('./lib/e2f'); 4 | 5 | forth.init(); 6 | forth.setPrint(console.log); 7 | 8 | process.stdin.setEncoding('utf8'); 9 | process.stdout.setEncoding('utf8'); 10 | 11 | function getSymbols(string) { 12 | var length = string.length; 13 | var index = -1; 14 | var output = []; 15 | var character; 16 | var charCode; 17 | while (++index < length) { 18 | character = string.charAt(index); 19 | charCode = character.charCodeAt(0); 20 | if (charCode >= 0xD800 && charCode <= 0xDBFF) { 21 | // Note: this doesn't account for lone high surrogates; 22 | // you'd need even more code for that! 23 | output.push(character + string.charAt(++index)); 24 | } else { 25 | output.push(character); 26 | } 27 | } 28 | return output; 29 | } 30 | 31 | var rl = readline.createInterface(process.stdin, process.stdout); 32 | 33 | 34 | rl.setPrompt('> '); 35 | rl.prompt(); 36 | 37 | rl.on('line', function(line) { 38 | line = line.trim(); 39 | var symbols = getSymbols(line); 40 | console.log('>> ' + symbols.join(' ').replace(/\s+/g, ' ')); 41 | var forthLines = e2f.emojiToForth(line); 42 | forthLines.forEach(function(line) { 43 | // console.log('forth>> ' + line); 44 | forth.run(line); 45 | }); 46 | //var stack = forth.stacktop(10); 47 | //console.log(stack.slice(5,5)); 48 | rl.prompt(); 49 | }).on('close', function() { 50 | console.log('Have a great day!'); 51 | process.exit(0); 52 | }); 53 | 54 | /* 55 | var prompt = require('prompt'); 56 | 57 | // 58 | // Start the prompt 59 | // 60 | prompt.start(); 61 | 62 | // 63 | // Get two properties from the user: username and email 64 | // 65 | prompt.get(['username', 'email'], function (err, result) { 66 | // 67 | // Log the results. 68 | // 69 | console.log('Command-line input received:'); 70 | console.log(' username: ' + result.username); 71 | console.log(' email: ' + result.email); 72 | }); 73 | */ 74 | -------------------------------------------------------------------------------- /examples/fact-explicated.hf: -------------------------------------------------------------------------------- 1 | 😀 💥 # define factorial: 2 | # to explicate, let's imagine the number 5 is already on the stack. 3 | # 4 | # This zero helps us know when to stop multiplying, later 5 | 0 💞 # (5) -> (5 0) -> (0 5) 6 | # 7 | # first, push all numbers from 1-5 onto the stack 8 | # 9 | 👉 # while 10 | 💕 # duplicate last (0 5 5) 11 | 1➖ # subtract one from last (0 5 4) 12 | 💕 1 🙏 👍 # exit if last number = 1. otherwise, continue 13 | # looping... 14 | # 15 | # eventually we have (0 5 4 3 2 1) 16 | # 17 | # now, multiply them all together 18 | # 19 | 👉 # while 20 | ✖ # multiply last two, 2*1 (0 5 4 3 2) 21 | 💑 0 🙏 👍 # exit if 2nd to last number is 0. otherwise, continue 22 | # looping... 23 | # 24 | # eventually we have (0 120) 25 | # 26 | 💞 💔 # swap -> (120 0), drop (120) 27 | 😉 # end 28 | -------------------------------------------------------------------------------- /examples/fact.f: -------------------------------------------------------------------------------- 1 | : fact 0 swap begin dup 1 - dup 1 = until begin * over 0 = until swap drop ; 2 | -------------------------------------------------------------------------------- /examples/fact.hf: -------------------------------------------------------------------------------- 1 | 😀💥0💞👉💕1➖💕1🙏👍👉✖💑0🙏👍💞💔😉 2 | -------------------------------------------------------------------------------- /examples/fibo.f: -------------------------------------------------------------------------------- 1 | : fib-iter 0 1 rot 0 ?do over + swap dup . loop drop ; 2 | 3 | -------------------------------------------------------------------------------- /examples/fibo.hf: -------------------------------------------------------------------------------- 1 | 😀🌿0 1💘0✋💑➕💞💕😘👌💔😉 2 | -------------------------------------------------------------------------------- /f2e.js: -------------------------------------------------------------------------------- 1 | var e2f = require('./lib/e2f'); 2 | 3 | var lazy = require("lazy"); 4 | 5 | new lazy(process.stdin) 6 | .lines 7 | .forEach(function(line) { 8 | var str = line.toString(); 9 | console.log(e2f.forthToEmoji(str)); 10 | }); 11 | process.stdin.resume(); 12 | 13 | -------------------------------------------------------------------------------- /gloss.js: -------------------------------------------------------------------------------- 1 | var e2f = require('./lib/e2f'); 2 | 3 | for (var k in e2f.keywordToEmoji) { 4 | console.log(k + ' | ' + e2f.keywordToEmoji[k]); 5 | } 6 | -------------------------------------------------------------------------------- /lib/e2f.js: -------------------------------------------------------------------------------- 1 | var emoji = require('emoji'); 2 | var wrap = require('word-wrap'); 3 | 4 | // plants and animals are reserved for variables 5 | // heart related emoji are all about the stack 6 | var emojiNameToKeyword = { 7 | // math 8 | 'heavy plus sign': '+', 9 | 'heavy minus sign': '-', 10 | 'heavy multiplication x': '*', 11 | 'heavy division sign': '/', 12 | 'person with folded hands': '=', 13 | 'public address loudspeaker': '>', 14 | 'satellite antenna': '<', 15 | 16 | // function definition 17 | 'grinning face': ':', 18 | 'winking face': ';', 19 | 20 | // flow control 21 | 'raised hand': '?do', 22 | 'ok hand sign': 'loop', 23 | 'white right pointing backhand index': 'begin', 24 | 'thumbs up sign': 'until', 25 | 'open hands sign': 'if', 26 | 'clapping hands sign': 'then', 27 | 28 | // stack operators 29 | 'broken heart': 'drop', 30 | 'heart with arrow': 'rot', 31 | 'couple with heart': 'over', 32 | 'revolving hearts': 'swap', 33 | 'two hearts': 'dup', 34 | 'face throwing a kiss': '.', 35 | 'heavy black heart': 'dump', // tempting to use 'pile of poo', but all stacky things have to have hearts 36 | //'kiss': '', 37 | 38 | /* 39 | "❤": ["U+2764", "heavy black heart", "2764", ["", "U+E6EC"], ["", "U+E595"], ["", "U+E022"], ["󾬌", "U+FEB0C"]], 40 | "💓": ["U+1F493", "beating heart", "1f493", ["", "U+E6ED"], ["", "U+EB75"], ["", "U+E327"], ["󾬍", "U+FEB0D"]], 41 | "💗": ["U+1F497", "growing heart", "1f497", ["", "U+E6ED"], ["", "U+EB75"], ["", "U+E328"], ["󾬑", "U+FEB11"]], 42 | "💘": ["U+1F498", "heart with arrow", "1f498", ["", "U+E6EC"], ["", "U+E4EA"], ["", "U+E329"], ["󾬒", "U+FEB12"]], 43 | "💙": ["U+1F499", "blue heart", "1f499", ["", "U+E6EC"], ["", "U+EAA7"], ["", "U+E32A"], ["󾬓", "U+FEB13"]], 44 | "💚": ["U+1F49A", "green heart", "1f49a", ["", "U+E6EC"], ["", "U+EAA8"], ["", "U+E32B"], ["󾬔", "U+FEB14"]], 45 | "💛": ["U+1F49B", "yellow heart", "1f49b", ["", "U+E6EC"], ["", "U+EAA9"], ["", "U+E32C"], ["󾬕", "U+FEB15"]], 46 | "💜": ["U+1F49C", "purple heart", "1f49c", ["", "U+E6EC"], ["", "U+EAAA"], ["", "U+E32D"], ["󾬖", "U+FEB16"]], 47 | "💝": ["U+1F49D", "heart with ribbon", "1f49d", ["", "U+E6EC"], ["", "U+EB54"], ["", "U+E437"], ["󾬗", "U+FEB17"]], 48 | "💟": ["U+1F49F", "heart decoration", "1f49f", ["", "U+E6F8"], ["", "U+E595"], ["", "U+E204"], ["󾬙", "U+FEB19"]], 49 | "😍": ["U+1F60D", "smiling face with heart-shaped eyes", "1f60d", ["", "U+E726"], ["", "U+E5C4"], ["", "U+E106"], ["󾌧", "U+FE327"]], 50 | "😻": ["U+1F63B", "smiling cat face with heart-shaped eyes", "1f63b", ["", "U+E726"], ["", "U+EB65"], ["", "U+E106"], ["󾍌", "U+FE34C"]], 51 | 52 | 'wedding' 53 | 'couple with heart' 54 | 'kiss' 55 | */ 56 | 57 | }; 58 | 59 | var keywordToEmoji = {}; 60 | 61 | function invert(obj) { 62 | var new_obj = {}; 63 | for (var prop in obj) { 64 | if(obj.hasOwnProperty(prop)) { 65 | new_obj[obj[prop]] = prop; 66 | } 67 | } 68 | return new_obj; 69 | } 70 | 71 | var keywordToEmojiName = invert(emojiNameToKeyword); 72 | 73 | var emojiNameToEmoji = {}; 74 | for (var e in emoji.EMOJI_MAP) { 75 | if(emoji.EMOJI_MAP.hasOwnProperty(e)) { 76 | var name = emoji.EMOJI_MAP[e][1]; 77 | emojiNameToEmoji[name] = e; 78 | } 79 | } 80 | 81 | for (var k in keywordToEmojiName) { 82 | var emojiName = keywordToEmojiName[k]; 83 | keywordToEmoji[k] = emojiNameToEmoji[emojiName]; 84 | } 85 | 86 | /** 87 | * @param {String} 88 | * @return {Array} of Forth lines. Amazingly parser barfs on > 80 char lines 89 | */ 90 | function emojiToForth(str) { 91 | var emojified = str.replace(emoji.EMOJI_RE(), function (_, m) { 92 | var em = emoji.EMOJI_MAP[m]; 93 | var name = em[1]; 94 | var ret = ''; 95 | if (name in emojiNameToKeyword) { 96 | //console.log(name + 'in!'); 97 | ret = emojiNameToKeyword[name]; 98 | } else { 99 | ret = 'emoji-' + name.replace(/\s+/g, '-'); 100 | } 101 | return ' ' + ret + ' '; 102 | }); 103 | emojified = emojified.replace(/\s+/g, ' '); 104 | var wrapped = wrap(emojified, {trim: true, width: 70}); 105 | var forthLines = wrapped.split(/\n+/); 106 | return forthLines; 107 | } 108 | 109 | function forthToEmoji(str) { 110 | var words = str.split(/\s+/); 111 | var lastWordWasNonEmoji = false; 112 | var emojified = []; 113 | words.forEach(function (w) { 114 | if (w in keywordToEmoji) { 115 | var e = keywordToEmoji[w]; 116 | emojified.push(e); 117 | lastWordWasNonEmoji = false; 118 | } else { 119 | if (lastWordWasNonEmoji) { 120 | emojified.push(" "); 121 | } 122 | emojified.push(w); 123 | lastWordWasNonEmoji = true; 124 | } 125 | }); 126 | return emojified.join(''); 127 | } 128 | 129 | module.exports = { 130 | emojiToForth: emojiToForth, 131 | forthToEmoji: forthToEmoji, 132 | keywordToEmoji: keywordToEmoji 133 | }; 134 | 135 | 136 | -------------------------------------------------------------------------------- /lib/emojistack.js: -------------------------------------------------------------------------------- 1 | 2 | 3 | var lexer = new Lexer(); 4 | 5 | lexer.addRule(/\s+/, function () { 6 | // matched whitespace - discard it 7 | }); 8 | 9 | lexer.addRule(/\[.*\]/, function () { 10 | // matched a comment - discard it 11 | }); 12 | 13 | lexer.addRule(/\d+/, function (lexeme) { 14 | this.yytext = parseInt(lexeme); 15 | return "NUMBER"; 16 | }); 17 | 18 | lexer.addRule(/push/, function () { 19 | return "PUSH"; 20 | }); 21 | 22 | lexer.addRule(/add/, function () { 23 | return "ADD"; 24 | }); 25 | 26 | lexer.addRule(/print/, function () { 27 | return "PRINT"; 28 | }); 29 | 30 | lexer.addRule(/rot/, function () { 31 | return "ROT"; 32 | }); 33 | 34 | lexer.addRule(/swap/, function () { 35 | return "SWAP"; 36 | }); 37 | 38 | lexer.addRule(/loop/, function () { 39 | return "LOOP"; 40 | }); 41 | 42 | lexer.addRule(/drop/, function () { 43 | return "DROP"; 44 | }); 45 | 46 | lexer.addRule(/countdo/, function () { 47 | return "COUNTDO"; 48 | }); 49 | 50 | lexer.addRule(/over/, function () { 51 | return "OVER"; 52 | }); 53 | 54 | 55 | 56 | 57 | function run(program) { 58 | lexer.setInput(program); 59 | 60 | var token; 61 | var stack = []; 62 | var push = false; 63 | 64 | while (token = lexer.lex()) { 65 | switch (token) { 66 | case "NUMBER": 67 | if (push) { 68 | stack.push(lexer.yytext); 69 | } else { 70 | alert("Unexpected number."); 71 | } 72 | break; 73 | case "ADD": 74 | if (push) { 75 | alert("Expected number."); 76 | } else { 77 | stack.push(stack.pop() + stack.pop()); 78 | } 79 | break; 80 | case "PRINT": 81 | if (push) { 82 | alert("Expected number."); 83 | } else { 84 | printLn(stack.pop()); 85 | } 86 | break; 87 | case "ROT": 88 | // ( x1 x2 x3 -- x2 x3 x1 ) 89 | stack.push(stack.shift()); 90 | break; 91 | case "COUNTDO": 92 | break; 93 | case "LOOP": 94 | break; 95 | case "OVER": 96 | // (a b -- a b a ) 97 | var a = stack.pop(); 98 | var b = stack.pop(); 99 | stack.push(a); 100 | stack.push(b); 101 | stack.push(a); 102 | break; 103 | case "SWAP": 104 | // (a b -- b a) 105 | var a = stack.pop(); 106 | var b = stack.pop(); 107 | stack.push(b); 108 | stack.push(a); 109 | break; 110 | case "DROP": 111 | stack.pop(); 112 | break; 113 | } 114 | 115 | push = token === "PUSH"; 116 | } 117 | } 118 | 119 | function printLn(s) { 120 | var output = $('#output').val(); 121 | $('#output').val(output + "\n" + s); 122 | } 123 | 124 | $('#run').click(function(event) { 125 | event.preventDefault(); 126 | var src = $('#src').val(); 127 | run(src); 128 | }); 129 | 130 | 131 | -------------------------------------------------------------------------------- /lib/jsforth.js: -------------------------------------------------------------------------------- 1 | /** 2 | @preserve 3 | 4 | JS-Forth 5 | http://www.forthfreak.net/index.cgi?jsforth 6 | Licensed under th GNU GPL. 7 | 8 | Disclaimer: JS-Forth is delivered as-is. No warranties, 9 | implicit or explicit, towards its function, usability, fitness 10 | for any purpose are given. It is distributed for educative 11 | purposes, you may study it to your hearts delight. Should 12 | you plan to execute JS-Forth on any computer, you declare 13 | to not hold the programmer liable in any way for any damage 14 | JS-Forth may cause, be it to that computer, peripherals, or any 15 | other object in the range of several thousand kilometers, or 16 | more. The person initiating execution of JS-Forth is the one 17 | carrying sole responsibility for all and any damage resulting 18 | from this action. Also, you do not hold the programmer liable 19 | for any damage resulting from the study of JS-Forth. Please 20 | do not stick your tongue into the power supply of the computer 21 | which is running JS-Forth. 22 | 23 | By opening JS-Forth for reading or execution, you make a full 24 | statement that you have read and understood all of the above 25 | disclaimer, and proceed willingly, volunteerily, and of your 26 | own choice on your own risk and responsability. 27 | 28 | Having said that, I can assure you that JS-Forth has not been 29 | written to perform any malicious action on your computer or 30 | anyone elses. I run Js-Forth frequently, and no damage has 31 | occured from doing so, though no extensive testing has been 32 | done on it as a whole yet. Those parts which work do so in a 33 | pretty stable manner. A major version jump to v0.01 may be imminent. 34 | */ 35 | 36 | var version = "0" ; 37 | var subversion = "5200804171342" ; 38 | var title = "## JS-Forth " + version + "." + subversion + " ##" ; 39 | 40 | // --------------------------------------------- vars you may wish to customize --------------------------------------------------- 41 | 42 | var memend = 0x100000 ; // memory allocated to jsforth (1 megacells is more than plenty) 43 | var maxcookies = 25; // number of disk sectors. >4 may be unsafe. 44 | var cookiebasename = "jsrepl-jsforth" ; // cookie name for saved blocks (blk number gets appended) 45 | var cookieexpirationdate = Date(Date.now() + 5 * 365 * 24 * 60 * 60 * 1000) ; // the date your hard disk will get erased. 46 | var infolines = 1000 ; // backscroll buffer size of info screen 47 | var paddistance = 512 ; // space between here and pad. 48 | var padsize = 512 ; // remaining space above pad until dictionary overflow error 49 | var maxbufs = 2 ; // number of buffers. works with any between 1 ... maxmem 50 | // default=2, more may be useful if working with many remote blocks 51 | var blocktimeout = 5000 ; // file i/o error if request not completed with this time (ms) 52 | 53 | // -------------------------------------------------------------------------------------------------------------------------------- 54 | 55 | 56 | // --- character codes 57 | var backspace = 8 ; 58 | var tab = 9 ; 59 | var carriagereturn = 13 ; 60 | var esc = 27 ; 61 | var bl = 32 ; 62 | 63 | 64 | var suspended = -1 ; // reason for suspending interpreter (event type) 65 | // -1: never started (helps source locator in see) 66 | var dp = 0 ; // dictionary pointer 67 | var catchframe = 0 ; // for catch/throw 68 | var wc = 0 ; // header count 69 | var inbuf = [] ; // accumulated input characters 70 | 71 | 72 | var linelen = 80 ; // main screen 73 | var lines = 30 ; 74 | 75 | var linelen2 = 55 ; // info screen 76 | var lines2 = lines ; 77 | 78 | 79 | var screensize = lines * linelen ; 80 | var tibsize = linelen + 1 ; 81 | var dictionaryfull = memend - (paddistance + padsize) ; 82 | 83 | // heap memory tracking 84 | var usedchunk = new Array() ; 85 | var freechunk = new Array() ; 86 | var heapend = memend ; 87 | 88 | // word header bit masks 89 | var immediate = 1 ; 90 | var smudgebit = 2 ; 91 | var precedencebit = immediate ; 92 | 93 | 94 | var s = new Array(); // data stack 95 | var r = new Array(); // return stack 96 | var m = new Array(); // main memory 97 | var h = new Array(); // headers 98 | var hf = new Array(); // header flags (precendence bit, hide/reveal) 99 | var x = new Array(); // execution tokens 100 | var t = new Array(); // word type - accelerated execution because no 101 | var sourceid = new Array(); // nested loads/evaluate stack previous source id here 102 | // conditional branching to the corresponding 103 | // code for next per wordtype. this array contains 104 | // the proper next to use. this should also 105 | // simplify does> 106 | h[0] = "" ; // in case header 0 gets accidently requested 107 | var f = new Array(); // float stack 108 | var ip; // forth vm instruction pointer 109 | var w; // forth vm word register 110 | var sp = 0; // forth vm parameter stack pointer 111 | var rp = 0; // forth vm return stack pointer 112 | var tos; // stack cache 113 | var ftos; // float stack cache 114 | 115 | 116 | 117 | 118 | 119 | // constants for standard compliance bit masks 120 | // a combination of those are written to the description of each word 121 | // through variable COMPLIANCE, subsets of provided words are masked 122 | var standard = new Array() ; 123 | 124 | // standard selection and vocabularies share the same mechanism. therefore, 125 | // using both concepts is a bit of a mix here now. 126 | // standards and vocabularies use bit masks 127 | 128 | var nextvocabulary = 1 ; var uncertain = nextvocabulary ; standard[uncertain] = " possibly other, need to look that up first" ; 129 | nextvocabulary <<= 1 ; var fig = nextvocabulary ; standard[fig] = "fig" ; 130 | nextvocabulary <<= 1 ; var f79 = nextvocabulary ; standard[f79] = "f79" ; 131 | nextvocabulary <<= 1 ; var f83 = nextvocabulary ; standard[f83] = "f83" ; 132 | nextvocabulary <<= 1 ; var ans = nextvocabulary ; standard[ans] = "dpans94" ; 133 | nextvocabulary <<= 1 ; var foerthchen= nextvocabulary ; standard[foerthchen]= "FOeRTHchen" ; 134 | nextvocabulary <<= 1 ; var jsf = nextvocabulary ; standard[jsf] = "JS-Forth" ; 135 | var higheststandard = nextvocabulary ; 136 | var any = ans | f83 | f79 | fig | jsf ; // but not foerthchen 137 | 138 | 139 | // --- no more standards, vocabularies follow --- 140 | nextvocabulary <<= 1 ; var only = nextvocabulary ; 141 | nextvocabulary <<= 1 ; var forth = nextvocabulary ; 142 | nextvocabulary <<= 1 ; var hidden = nextvocabulary ; 143 | nextvocabulary <<= 1 ; var teststuff = nextvocabulary ; 144 | var lastsystemvocabulary = nextvocabulary ; 145 | 146 | 147 | var vocstack = new Array() ; // top element is in m[context] 148 | var vocname = new Array() ; // contains xt of all vocs 149 | 150 | 151 | function printvocname(n) { 152 | var temp = 0 ; 153 | for (var i=only ; i != 0x40000000 ; i <<=1 ) { 154 | if (i == n) { 155 | type(h[vocname[temp]] + " ") ; 156 | break ; 157 | } 158 | temp++ ; 159 | } 160 | } 161 | 162 | 163 | 164 | function jscomma(n) { m[dp++] = n ; return (dp-1) ;} 165 | 166 | function jshiallot0(n) { // heap (buffers, allocate) 167 | for (var i=n ; i ; i--) m[heapend++] = 0 ; 168 | return (heapend-n) ; 169 | } 170 | 171 | // variables, shared between javascript and forth: 172 | // addressed by m[varname] from javascript, define a constant 173 | // with value of address for access from forth. 174 | var casesensitive = jscomma(0) ; // switch case sensitive/insensitive dictionary search 175 | var debugging = jscomma(0) ; // get spilled with output on info display 176 | var warnings = jscomma(-1) ; // meant to disable javascript warnings, but hides only error messages 177 | var compliance = jscomma(jsf) ; // cause find, words to scope only those words complying with the selected standard 178 | var fittype = jscomma(0) ; // ALLOCATE chunk matching: 0: first, other: best fit 179 | var outfile = jscomma(-1) ; // switch between output routines: 180 | // -1 : fast terminal 181 | // -2 : slow terminal 182 | // >=0 : output to consecutive blocks ( not implemented ) 183 | var blk = jscomma(-1) ; // currently accessed block, as set by load 184 | var scr = jscomma(0) ; // last block accessed through list or user tools 185 | var context = jscomma(forth) ; // first searched vocabulary on vocabulary stack 186 | var current = jscomma(forth) ; // the vocabulary compiled to 187 | var lastxt = jscomma(0) ; // contains execution token of most recently compiled word 188 | var base = jscomma(10) ; // radix for i/o number conversion 189 | var state = jscomma(0) ; // switch interpret/compile 190 | var innerloop = jscomma(0) ; // compile time helper variable for loops 191 | var innercase = jscomma(0) ; // of counter for inner case 192 | var span = jscomma(0) ; // obsolete -- expect stores string len in here 193 | var toin = jscomma(0) ; // input buffer handling 194 | var hashtib = jscomma(0) ; // obsolescent - contains # chars in tib 195 | var tib = jshiallot0(tibsize) // input buffer 196 | 197 | var parsebuf ; // usually address of tib, but can be block address 198 | var parsebuflen ; // number of chars in parse buffer 199 | 200 | 201 | 202 | 203 | // ----------------------------------------------- mass memory buffers --------------------------------------------- 204 | 205 | 206 | var nextbuf = 0 ; // index of next buffer to use 207 | var buf = new Array() ; // buffer addresses 208 | var bufdirty = new Array() ; // buffer dirty flag 209 | var bufblk = new Array() ; // block in this buf, or -1 210 | 211 | var blockstat = new Array() // -1: indexed by blk, gives -1 for unbuffered, or, if buffered, buffer id 212 | 213 | 214 | 215 | 216 | 217 | 218 | 219 | // ----- data storage for descriptions, stack effects ----- 220 | // also trying to use these for vocabularies 221 | // "standard" is printed along with help. As this information is supplied 222 | // anyway, the compiler could use it, by making sure only words which belong 223 | // to a user specified standard are used, or printing warning otherwise. 224 | 225 | 226 | var ds = new Array(); // bitmask for compliancy and vocs 227 | var dse = new Array(); // stack effect, text 228 | 229 | 230 | 231 | var lineofspaces = "" ; 232 | for ( var i=0 ; i= 0) return m[blk]*1024+m[toin] ; 319 | return -1 ; 320 | } 321 | 322 | 323 | 324 | function newheader(name,flags) { // wc = word count 325 | h[++wc] = name ; // header name 326 | src[wc] = from() ; 327 | hf[wc] = flags ; // immediate/reveal 328 | x[wc] = dp ; // pointer to word body (was: xt) 329 | m[lastxt] = wc ; // last 330 | ds[wc] = any | foerthchen | m[current] ; // new words standard compliance 331 | dse[wc] = "" ; // new word stack effect 332 | debug("compiling: " + name); 333 | } 334 | 335 | 336 | function nextprimitive() { x[w]() ; } 337 | function nexthilevel() { w = x[w] ; x[m[w]]() ; } 338 | function nextconstant() { s[++sp]=tos ; tos=m[x[w]+1] ; } 339 | function nextvariable() { s[++sp]=tos ; tos=x[w]+1 ; } 340 | 341 | // function nexthilevel() { r[++rp] = ip ; ip = x[w]+1 ; } // slower ... 342 | // there's a dovocabulary further below, and a dodoes 343 | 344 | 345 | 346 | 347 | 348 | 349 | 350 | 351 | 352 | 353 | 354 | function primitive(name,code,flags) { 355 | newheader(name,flags|smudgebit) ; 356 | x[wc] = code ; 357 | t[wc] = nextprimitive ; 358 | return wc ; 359 | } 360 | 361 | 362 | function headerless() { h[wc] = "" ; } 363 | 364 | 365 | 366 | 367 | 368 | // ================================================================================================= 369 | // misc helper words 370 | // ================================================================================================= 371 | 372 | 373 | 374 | 375 | definitions(hidden) ; 376 | 377 | function pack(a,n) { 378 | w = "" ; 379 | for ( var i=n ; i; i--) w += String.fromCharCode(m[a++]) ; 380 | return w; 381 | } 382 | 383 | function forthpack() { tos=pack(s[sp--],tos) ; } 384 | var x_pack=primitive("pack",forthpack) ; 385 | describe("a n -- x",jsf) ; 386 | 387 | 388 | 389 | function unpackstring(string,address) { // returns len 390 | var stringlen = string.length ; 391 | var destaddr = address + stringlen ; 392 | for (var i=stringlen; i; m[--destaddr]=string.charCodeAt(--i) ) {} ; 393 | return stringlen ; 394 | } 395 | 396 | 397 | 398 | // unpack packed string x to address, return number of characters 399 | // can reuse the function above 400 | function unpack() { // ( x a -- n ) 401 | var string = s[sp--] ; // string 402 | w = string.length ; // string len 403 | tos += w ; // last dest address + 1 404 | for (var i=w; i; m[--tos]=string.charCodeAt(--i) ) {} ; 405 | tos = w ; 406 | } 407 | var x_unpack = primitive("unpack",unpack) ; 408 | describe("x a -- n",jsf) ; 409 | 410 | 411 | 412 | function definitions(vocabulary) { m[current] = vocabulary ; } 413 | definitions(forth) ; 414 | 415 | 416 | 417 | function forthstackeffect() { // ( xt -- a n ) 418 | s[++sp] = dp ; 419 | if (dse[tos]) { 420 | tos = unpackstring("( " + dse[tos] + " )",dp) ; 421 | } else { 422 | tos = 0 ; 423 | } 424 | } 425 | primitive("stackeffect",forthstackeffect) ; 426 | describe("xt -- a n",jsf) ; 427 | 428 | 429 | 430 | definitions(hidden) 431 | function forthstorestackeffect() { // ( a n -- ) 432 | forthpack() ; 433 | dse[m[lastxt]] = tos ; 434 | tos = s[sp--] 435 | } 436 | var x_storestackeffect = primitive("stackeffect!",forthstorestackeffect) ; 437 | describe("a n --",jsf) ; 438 | 439 | 440 | 441 | definitions(forth) 442 | function forthinfo() { // ( a n -- ) info 443 | info(pack(s[sp--],tos)) ; 444 | tos = m[sp--] ; 445 | } 446 | primitive("info",forthinfo) ; 447 | describe("a n --",jsf) ; 448 | 449 | 450 | 451 | var clock ; 452 | 453 | function forthstartclock() { 454 | clock = new Date().getTime(); 455 | } 456 | primitive("startclock",forthstartclock) ; 457 | describe("--",jsf) ; 458 | 459 | 460 | 461 | function forthelapsed() { 462 | w = new Date().getTime(); 463 | s[++sp] = tos ; 464 | tos = w - clock ; 465 | } 466 | primitive("elapsed",forthelapsed) ; 467 | describe("-- u",jsf) ; 468 | 469 | 470 | 471 | 472 | 473 | 474 | 475 | 476 | 477 | // ----- multi standard selection ----- 478 | 479 | definitions(forth) ; 480 | 481 | function forthfig() { m[compliance] = fig ; } 482 | primitive("fig",forthfig) ; 483 | describe("--",jsf) ; 484 | 485 | 486 | function forthfoerthchen() { m[compliance] = foerthchen ; } 487 | primitive("foerthchen",forthfoerthchen) ; 488 | describe("--",jsf) ; 489 | 490 | 491 | function forthf79() { m[compliance] = f79 ; } 492 | primitive("f79",forthf79) ; 493 | describe("--",jsf) ; 494 | 495 | 496 | function forthf83() { m[compliance] = f83 ; } 497 | primitive("f83",forthf83) ; 498 | describe("--",f83|jsf) ; 499 | 500 | 501 | function forthans() { m[compliance] = ans ; } 502 | primitive("ans",forthans) ; 503 | describe("--",jsf) ; 504 | 505 | function forthjsforth() { m[compliance] = jsf ; } 506 | primitive("jsf",forthjsforth) ; 507 | describe("--",any|foerthchen) ; 508 | 509 | 510 | 511 | 512 | 513 | 514 | 515 | 516 | // ================================================================================================= 517 | // virtual machine 518 | // ================================================================================================= 519 | 520 | definitions(hidden) ; 521 | function forthnest() { r[++rp] = ip ; ip = ++w ; } 522 | var x_nest=primitive("(nest)",forthnest) ; 523 | describe("--",jsf) ; 524 | 525 | 526 | 527 | definitions(forth) ; 528 | function forthunnest() { ip = r[rp--] ; } 529 | var x_unnest=primitive("exit",forthunnest) ; 530 | describe("--",any) ; 531 | 532 | 533 | 534 | 535 | 536 | 537 | 538 | 539 | // ================================================================================================= 540 | // catch, throw 541 | // ================================================================================================= 542 | var customerror = new Array() ; 543 | var systemerror = new Array() ; 544 | systemerror[1] = "aborted" ; 545 | systemerror[2] = "aborted" ; 546 | systemerror[3] = "stack overflow" ; 547 | systemerror[4] = "stack underflow" ; 548 | systemerror[5] = "return stack overflow" ; 549 | systemerror[6] = "return stack underflow" ; 550 | systemerror[7] = "do loops nested too deeply" ; 551 | systemerror[8] = "dictionary overflow" ; 552 | systemerror[9] = "invalid memory address" ; 553 | systemerror[10] = "division by zero" ; 554 | systemerror[11] = "result out of range" ; 555 | systemerror[12] = "argument type mismatch" ; 556 | systemerror[13] = "word not found" ; 557 | systemerror[14] = "use only during compilation" ; 558 | systemerror[15] = "invalid forget" ; 559 | systemerror[16] = "attempt to use zero-length string as name" ; 560 | systemerror[17] = "pictured numeric ouput string overflow" ; 561 | systemerror[18] = "pictured numeric ouput string overflow" ; 562 | systemerror[19] = "word name too long" ; 563 | systemerror[20] = "write to a read-only location" ; 564 | systemerror[21] = "unsupported operation" ; 565 | systemerror[22] = "unstructured" ; 566 | systemerror[23] = "address alignment exception" ; 567 | systemerror[24] = "invalid numeric argument" ; 568 | systemerror[25] = "return stack imbalance" ; 569 | systemerror[26] = "loop parameters unavailable" ; 570 | systemerror[27] = "invalid recursion" ; 571 | systemerror[28] = "user interrupt" ; 572 | systemerror[29] = "compiler nesting" ; 573 | systemerror[30] = "obsolescent feature" ; 574 | systemerror[31] = ">BODY used on non-CREATEd definition" ; 575 | systemerror[32] = "invalid name argument" ; 576 | systemerror[33] = "Block read exception" ; 577 | systemerror[34] = "Block write exception" ; 578 | systemerror[35] = "Invalid block number" ; 579 | systemerror[36] = "Invalid file position" ; 580 | systemerror[37] = "File I/O exception" ; 581 | systemerror[38] = "File not found" ; 582 | 583 | // additional jsforth error messages: 584 | systemerror[64] = "use only while interpreting" ; 585 | systemerror[65] = "executed BODY> on a non-body address" ; 586 | systemerror[66] = "unstructured" ; // message gets overwritten for more detail 587 | systemerror[67] = "TO must be used on a VALUE" ; 588 | systemerror[68] = "JavaScript boo, mostly the result of uninitialized memory access" ; 589 | systemerror[69] = "Too many vocabularies" ; 590 | systemerror[70] = "No cookie by that name found" ; 591 | systemerror[71] = "Can't write to read-only block" ; 592 | systemerror[72] = "Invalid memory region specifier, or heap corrupted" ; 593 | 594 | 595 | 596 | 597 | function errordialog(x) { 598 | if (x < 0) { 599 | if (systemerror[-x]) return ("error(" + x + "): " + systemerror[-x]) ; 600 | return ("error #" + x) ; 601 | } 602 | if (customerror[x]) return ("error: " + customerror[x]) ; 603 | return ("error #" + x) ; 604 | } 605 | 606 | 607 | 608 | // THIS SHOULD BE REPLACED BY THE DESIRED ERROR FUNCTION. 609 | function _error(str) { 610 | info(str); 611 | } 612 | 613 | // throw without catch frame - top level error handler 614 | function exception(x) { 615 | var word; 616 | if (m[blk]>=0) { 617 | var temp = m[toin] % 64 ; 618 | word = pack(parsebuf + m[toin] - temp,temp) ; 619 | } else { 620 | word = pack(parsebuf,m[toin]) ; 621 | } 622 | _error(word + ': ' + errordialog(x)); 623 | // just calling the virtual machine won't do, as that would require more and more javascript return stack. 624 | // stopping the interpreter, and have it restart with a one-time event at the warm start point solves this. 625 | debug("issuing timed event 'warmstart vm in 1 ms'") ; 626 | suspended = warm ; 627 | setTimeout(function() { virtualmachine(warm) ; }, 1) ; 628 | tos = s[sp--] ; 629 | } 630 | 631 | 632 | 633 | 634 | 635 | definitions(hidden) ; 636 | function forththrow0() { 637 | catchframe = r[rp] ; 638 | sp = r[--rp] ; 639 | ip = r[--rp] ; 640 | rp-- ; 641 | tos = 0 ; 642 | } 643 | var brthrow0 = dp 644 | m[dp++] = primitive("throw0",forththrow0) ; 645 | 646 | 647 | definitions(forth) ; 648 | function forthcatch() { 649 | r[++rp] = ip ; 650 | r[++rp] = sp ; 651 | r[++rp] = catchframe ; 652 | catchframe = rp ; 653 | r[++rp] = brthrow0 ; 654 | forthexecute() ; 655 | } 656 | var x_catch = primitive("catch",forthcatch) ; 657 | describe("xn ... x0 a -- xn ... x0 n",ans|jsf) ; 658 | 659 | 660 | function throwerror(x) { 661 | if (catchframe) { 662 | tos = x 663 | rp = catchframe ; 664 | catchframe = r[rp--] ; 665 | sp = r[rp--] ; 666 | ip = r[rp--] ; 667 | } else { 668 | exception(x) ; 669 | } 670 | } 671 | 672 | 673 | function forththrow() { 674 | if (tos != 0) { 675 | throwerror(tos) ; 676 | } else { 677 | tos = s[sp--] ; 678 | } 679 | } 680 | var x_throw = primitive("throw",forththrow) ; 681 | describe("n --",ans|jsf|f83) ; 682 | 683 | 684 | function forthnewerror() { 685 | if (tos<0) { 686 | systemerror[-tos] = pack(s[sp-1],s[sp]) ; 687 | } else { 688 | customerror[tos] = pack(s[sp-1],s[sp]) ; 689 | } 690 | sp -= 2 ; 691 | tos = s[sp--] ; 692 | } 693 | primitive("newerror",forthnewerror) ; 694 | describe("a n1 n2 --",jsf) ; 695 | 696 | 697 | 698 | 699 | 700 | 701 | 702 | // ================================================================================================= 703 | // run time words 704 | // ================================================================================================= 705 | 706 | 707 | definitions(hidden) ; 708 | function forthdolit() { s[++sp]=tos ; tos=m[ip++] ; } 709 | var x_lit=primitive("(lit)",forthdolit) ; 710 | 711 | 712 | function forthbrsquote() { s[++sp]=tos ; tos=m[ip++] ; s[++sp]=ip ; ip+=tos ; } 713 | var x_brsquote=primitive('(s")',forthbrsquote) ; 714 | 715 | 716 | function forthbrcquote() { s[++sp]=tos ; tos=ip++ ; ip += m[tos] } 717 | var x_brcquote=primitive('(c")',forthbrcquote) ; 718 | 719 | 720 | 721 | function forthbrdotquote() { 722 | forthbrsquote() ; 723 | forthpack() ; 724 | type(tos) ; 725 | tos=s[sp--] ; 726 | } 727 | var x_brdotquote=primitive('(.")',forthbrdotquote) ; 728 | 729 | 730 | 731 | function forthdovar() { s[++sp] = tos ; tos = ++w ; } 732 | var x_dovar=primitive("(var)",forthdovar) ; 733 | 734 | 735 | function forthdoconst() { s[++sp]=tos ; tos=m[++w] ; } 736 | var x_doconst = primitive("(const)",forthdoconst) ; 737 | var x_dovalue = primitive("(value)",forthdoconst) ; 738 | 739 | function forthdofconst() { f.push(ftos) ; ; ftos = m[++w] ; } 740 | var x_dofconst = primitive("(fconst)",forthdofconst) ; 741 | 742 | 743 | // function forthdodefer() { ip=++w ; } 744 | 745 | 746 | // branch 1 works as nop, branch -1 is infinite loop 747 | function forthbranch() { ip+=m[ip] ; } 748 | var x_branch=primitive("(branch)",forthbranch) ; 749 | 750 | 751 | function forth0branch() { 752 | if (tos) { 753 | ip++ ; 754 | } else { 755 | ip+=m[ip] ; 756 | } 757 | tos=s[sp--] ; 758 | } 759 | var x_0branch=primitive("(0branch)",forth0branch) ; 760 | 761 | 762 | function forthwarminit() { // not for interactive use 763 | tos = r[rp] ; rp = 0 ; r[rp+1] = 0 ; r[rp] = tos ; 764 | tos = 0 ; sp = 0 ; s[sp+1] = 0 ; s[sp] = tos ; 765 | ftos = 0 ; 766 | for ( ; f.length ; f.pop() ) ; 767 | catchframe = 0 ; 768 | m[state] = 0 ; 769 | m[innerloop] = 0 ; 770 | m[innercase] = 0 ; 771 | m[blk] = -1 ; 772 | m[outfile] = -1 ; 773 | for ( ; inbuf.length ; inbuf.pop() ) ; 774 | } 775 | var x_warminit = primitive("warminit",forthwarminit) ; 776 | 777 | 778 | 779 | 780 | function forthbrabortquote() { 781 | if (tos) { 782 | forthbrsquote() ; 783 | forthpack() ; 784 | systemerror[2] = tos ; 785 | throwerror(-2) ; 786 | } else { 787 | tos = s[sp--] ; 788 | ip += m[ip]+1 ; 789 | } 790 | } 791 | var x_brabortquote = primitive('(abort")',forthbrabortquote) ; 792 | 793 | 794 | function forthbrto() { 795 | m[m[ip++]] = tos ; 796 | tos = s[sp--] ; 797 | } 798 | var x_brto = primitive("(to)",forthbrto) ; 799 | 800 | 801 | 802 | // --- not portable: output packed string literal --- 803 | function jsdotquote() { type(m[ip++])} ; 804 | var dotquote = primitive("",jsdotquote) ; 805 | 806 | 807 | 808 | 809 | 810 | 811 | 812 | 813 | 814 | // ================================================================================================= 815 | // stack operators 816 | // ================================================================================================= 817 | 818 | definitions(forth) ; 819 | 820 | function forthdup() { s[++sp] = tos ; } // dup 821 | var x_dup=primitive("dup",forthdup) ; 822 | describe("x -- x x",any|foerthchen) ; 823 | 824 | 825 | function forthqdup() { if (tos) s[++sp]=tos ; } // ?dup 826 | var x_qdup=primitive("?dup",forthqdup) ; 827 | describe("x -- 0 | x x",any) ; 828 | 829 | 830 | function forthdrop() { tos = s[sp--] ; } // drop 831 | var x_drop=primitive("drop",forthdrop) ; 832 | describe("x --",any|foerthchen) ; 833 | 834 | 835 | function forthswap() { w = s[sp] ; s[sp] = tos ; tos = w ; } // swap 836 | var x_swap=primitive("swap",forthswap) ; 837 | describe("x1 x2 -- x2 x1",any|foerthchen) ; 838 | 839 | 840 | function forthover() { s[++sp]= tos ; tos=s[sp-1] ; } // over 841 | var x_over=primitive("over",forthover) ; 842 | describe("x1 x2 -- x1 x2 x1",any) ; 843 | 844 | 845 | function forthrot() { // rot 846 | w = s[sp] ; 847 | s[sp] = tos ; 848 | tos = s[sp-1] ; 849 | s[sp-1] = w ; 850 | } 851 | var x_rot = primitive("rot",forthrot) ; 852 | describe("x1 x2 x3 -- x2 x3 x1",any) ; 853 | 854 | 855 | function forthminrot() { // -rot 856 | w = s[sp-1] ; 857 | s[sp-1] = tos ; 858 | tos = s[sp] ; 859 | s[sp] = w ; 860 | } 861 | primitive("-rot",forthminrot) ; 862 | describe("x1 x2 x3 -- x3 x1 x2",jsf) ; 863 | 864 | 865 | function forthtuck() { w = s[sp] ; s[sp] = tos ; s[++sp] = w ; } 866 | var x_tuck = primitive("tuck",forthtuck) ; // tuck 867 | describe("x1 x2 -- x2 x1 x2",ans|jsf) ; 868 | 869 | 870 | function forthnip() { sp-- ; } // nip 871 | var x_nip=primitive("nip",forthnip) ; 872 | describe("x1 x2 -- x2",ans|jsf) ; 873 | 874 | 875 | function forth2dup() { s[++sp]=tos ; s[++sp]=s[sp-2] ; } // 2dup 876 | var x_2dup=primitive("2dup",forth2dup) ; 877 | describe("x1 x2 -- x1 x2 x1 x2",any) ; 878 | 879 | 880 | function forth2drop() { sp-- ; tos=s[sp--] ; } // 2drop 881 | var x_2drop=primitive("2drop",forth2drop) ; 882 | describe("x1 x2 --",any) ; 883 | 884 | 885 | function forth2swap() { // 2swap 886 | w = s[sp-1] ; 887 | s[sp-1] = tos ; 888 | tos = w ; 889 | w = s[sp-2] ; 890 | s[sp-2] = s[sp] ; 891 | s[sp] = w ; 892 | } 893 | primitive("2swap",forth2swap) ; 894 | describe("x1 x2 x3 x4 -- x3 x4 x1 x2",any) ; 895 | 896 | 897 | function forth2over() { // 2over 898 | s[++sp] = tos ; 899 | tos = s[sp-3] ; 900 | s[++sp] = tos ; 901 | tos = s[sp-3] ; 902 | } 903 | primitive("2over",forth2over) ; 904 | describe("x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2",any) ; 905 | 906 | 907 | function forthmin() { tos = Math.min(s[sp--],tos) } // min 908 | var x_min = primitive("min",forthmin) ; 909 | describe("n1 n2 -- n3",any) 910 | 911 | 912 | function forthmax() { tos = Math.max(s[sp--],tos) } // max 913 | primitive("max",forthmax) ; 914 | describe("n1 n2 -- n3",any) 915 | 916 | 917 | function forthtor() { r[++rp] = tos ; tos = s[sp--] ; } // >r 918 | var x_tor=primitive(">r",forthtor) ; 919 | describe("x --",any|foerthchen) 920 | 921 | 922 | function forthrfrom() { s[++sp] = tos ; tos = r[rp--] ; } // r> 923 | var x_rfrom=primitive("r>",forthrfrom) ; 924 | describe("-- x",any|foerthchen) 925 | 926 | 927 | function forthrfetch() { s[++sp] = tos ; tos = r[rp] ; } // r@ 928 | var x_rfetch=primitive("r@",forthrfetch) ; 929 | describe("-- x",any) 930 | 931 | 932 | function forthrdrop() { rp-- ; } // rdrop 933 | var x_rdrop=primitive("rdrop",forthrdrop) ; 934 | describe("-- x",jsf) 935 | 936 | 937 | 938 | function forth2tor() { // 2>r 939 | r[++rp] = s[sp--] ; 940 | r[++rp] = tos ; 941 | tos = s[sp--] ; 942 | } 943 | var x_2tor=primitive("2>r",forth2tor) ; 944 | describe("x1 x2 --",ans|jsf|uncertain) 945 | 946 | 947 | 948 | function forth2rfrom() { // 2r> 949 | s[++sp] = tos ; 950 | tos = r[rp--] ; 951 | s[++sp] = r[rp--] ; 952 | } 953 | var x_2rfrom=primitive("2r>",forth2rfrom) ; 954 | describe("-- x1 x2",ans|jsf|uncertain) 955 | 956 | 957 | 958 | function forth2rfetch() { // 2r@ 959 | s[++sp] = tos ; 960 | tos = r[rp] ; 961 | s[++sp] = r[rp-1] ; 962 | } 963 | var x_2rfetch=primitive("2r@",forth2rfetch) ; 964 | describe("-- x1 x2",ans|jsf|uncertain) 965 | 966 | 967 | 968 | function forthdepth() { s[++sp]=tos ; tos=sp-1 ; } // depth 969 | var x_depth=primitive("depth",forthdepth) ; 970 | describe("-- n",ans|f83|jsf|uncertain) ; 971 | 972 | 973 | 974 | function forthpick() { tos = s[sp-tos] ; } // pick 975 | primitive("pick",forthpick) ; 976 | describe("xu ... x1 x0 u -- xu ... x1 x0 xu",any) ; 977 | 978 | 979 | 980 | function forthroll() { // roll 981 | w = s[sp-tos] ; 982 | for ( ; tos ; --tos ) s[sp-tos] = s[sp-tos+1] ; 983 | sp-- ; 984 | tos = w 985 | } 986 | primitive("roll",forthroll) ; 987 | describe("xu xu-1 ... x0 u -- xu-1 ... x0 xu",any) ; 988 | 989 | 990 | 991 | 992 | 993 | 994 | 995 | 996 | 997 | // ================================================================================================= 998 | // memory operators 999 | // ================================================================================================= 1000 | 1001 | 1002 | function forthfetch() { tos = m[tos] ; } // @ 1003 | var x_fetch=primitive("@",forthfetch) ; 1004 | describe("a -- x",any|foerthchen) ; 1005 | 1006 | 1007 | function forthstore() { m[tos] = s[sp--] ; tos = s[sp--] ; } // ! 1008 | var x_store=primitive("!",forthstore) ; 1009 | describe("x a --",any|foerthchen) ; 1010 | 1011 | 1012 | function forth2fetch() { s[++sp] = m[tos+1] ; tos = m[tos] ; } // 2@ 1013 | var x_2fetch=primitive("2@",forth2fetch) ; 1014 | describe("a -- d",any) ; 1015 | 1016 | 1017 | function forth2store() { // 2! 1018 | m[tos++] = s[sp--] ; 1019 | m[tos] = s[sp--] ; 1020 | tos = s[sp--] ; 1021 | } 1022 | var x_2store=primitive("2!",forth2store) ; 1023 | describe("d a --",any) ; 1024 | 1025 | 1026 | function forthcfetch() { tos = m[tos]&255 ; } // c@ 1027 | var x_cfetch=primitive("c@",forthcfetch) ; 1028 | describe("a -- c",any) ; 1029 | 1030 | 1031 | function forthcstore() { m[tos] = s[sp--]&255 ; tos = s[sp--] ; } // c! 1032 | var x_cstore=primitive("c!",forthcstore) ; 1033 | describe("c a --",any) ; 1034 | 1035 | 1036 | function forthcount() { s[++sp]=tos+1 ; tos=m[tos]&255 ; } // count 1037 | var x_count=primitive("count",forthcount) ; 1038 | describe("a1 -- a2 c",any) ; 1039 | 1040 | 1041 | function forthskim() { s[++sp]=tos+1 ; tos=m[tos] ; } // skim 1042 | var x_skim=primitive("skim",forthskim) ; 1043 | describe("a1 -- a2 x",jsf) ; 1044 | 1045 | 1046 | function forthexchange() { w = m[tos] ; m[tos] = s[sp--] ; tos = w ; } // exchange 1047 | var x_exchange=primitive("exchange",forthexchange) ; 1048 | describe("x1 a -- x2",jsf) ; 1049 | 1050 | 1051 | function forthon() { m[tos] = -1 ; tos = s[sp--] ; } // on 1052 | primitive("on",forthon) ; 1053 | describe("a --",jsf) ; 1054 | 1055 | 1056 | function forthoff() { m[tos] = 0 ; tos = s[sp--] ; } // off 1057 | var x_off = primitive("off",forthoff) ; 1058 | describe("a --",jsf) ; 1059 | 1060 | 1061 | function forthfill() { // fill 1062 | i = s[sp--] ; 1063 | var dest=s[sp--]; 1064 | for ( ; i ; i-- ) m[dest++]=tos ; 1065 | tos = s[sp--] ; 1066 | } 1067 | var x_fill=primitive("fill",forthfill) ; 1068 | describe("a u c --",any) ; 1069 | 1070 | 1071 | function fortherase() { s[++sp] = tos ; tos = 0 ; forthfill() ; } 1072 | primitive("erase",fortherase) ; 1073 | describe("a u --",any) ; 1074 | 1075 | 1076 | function forthslashstring() { // /string 1077 | w = tos ; 1078 | tos = s[sp--] ; 1079 | if ( tos < w ) w = tos ; 1080 | s[sp] += w ; 1081 | tos -= w ; 1082 | } 1083 | var x_slashstring=primitive("/string",forthslashstring) ; 1084 | describe("a1 n1 u -- a2 n2",ans|jsf|uncertain) ; 1085 | 1086 | 1087 | 1088 | function noop() { } 1089 | 1090 | primitive("align",noop|immediate) ; // align 1091 | describe("--",ans|jsf) ; 1092 | 1093 | 1094 | primitive("aligned",noop|immediate) ; // aligned 1095 | describe("a1 -- a2",ans|jsf); 1096 | 1097 | 1098 | function forthpad() { s[++sp] = tos ; tos = dp + paddistance ; } 1099 | primitive("pad",forthpad) ; // pad 1100 | describe("-- a",any) ; 1101 | 1102 | 1103 | 1104 | 1105 | 1106 | 1107 | 1108 | // ================================================================================================= 1109 | // i/o 1110 | // ================================================================================================= 1111 | 1112 | 1113 | 1114 | 1115 | 1116 | 1117 | 1118 | var x_cr=primitive("cr",cr) ; // cr 1119 | describe("--",any) ; 1120 | 1121 | 1122 | 1123 | 1124 | definitions(forth) ; 1125 | 1126 | function forthspaces() { // spaces 1127 | for ( ; tos>linelen ; tos-=linelen ) type(lineofspaces) ; 1128 | type(lineofspaces.substring(0,tos)) ; 1129 | tos = s[sp--] ; 1130 | } 1131 | var x_spaces=primitive("spaces",forthspaces) ; 1132 | describe("n --",any) ; 1133 | 1134 | 1135 | 1136 | definitions(hidden) ; 1137 | 1138 | 1139 | 1140 | // --- messages written to dialog screen --- 1141 | 1142 | definitions(forth) ; 1143 | function forthspace() { type(" ") ; } // space 1144 | var x_space=primitive("space",forthspace) ; 1145 | describe("--",any) ; 1146 | 1147 | 1148 | 1149 | 1150 | 1151 | function forthemit() { emit(tos) ; tos = s[sp--] ; } // emit 1152 | var x_emit=primitive("emit",forthemit) ; 1153 | describe("c --",any|foerthchen) ; 1154 | 1155 | 1156 | 1157 | function forthtype() { // type 1158 | forthpack() ; 1159 | type(tos) ; 1160 | tos = s[sp--] ; 1161 | } 1162 | var x_type=primitive("type",forthtype) ; 1163 | describe("--",any) ; 1164 | 1165 | 1166 | 1167 | var x_page= primitive("page",cls) ; // page 1168 | describe("--",ans|f83|jsf) ; 1169 | 1170 | 1171 | 1172 | primitive("cls",cls) ; 1173 | describe("--",jsf) ; 1174 | 1175 | 1176 | // THIS SHOULD BE REPLACED BY THE DESIRED PROMPTING FUNCTION. 1177 | function _prompt() { 1178 | // Nothing. 1179 | } 1180 | 1181 | function forthprompt() { // prompt 1182 | _prompt(); 1183 | } 1184 | var x_prompt=primitive("prompt",forthprompt) ; 1185 | describe("--",any) ; 1186 | 1187 | 1188 | 1189 | function forthdots() { // .s 1190 | s[++sp] = tos; 1191 | for (var i=1 ; i < sp ; type(s[++i].toString(m[base]) + " ")) ; 1192 | sp-- ; 1193 | } 1194 | var x_dots = primitive(".s",forthdots) ; 1195 | describe("--",any) ; 1196 | 1197 | 1198 | 1199 | 1200 | 1201 | 1202 | 1203 | // read string, delimited by c. return address and len 1204 | // updates source 1205 | 1206 | function forthparse() { // parse 1207 | var delimiter = tos ; 1208 | w = m[toin] + parsebuf ; // parse address 1209 | var bufend = parsebuf + parsebuflen ; 1210 | var nxtchar = m[w] ; 1211 | if (delimiter == bl) { 1212 | for ( ; w < bufend ; ) { 1213 | if (nxtchar != delimiter) break ; 1214 | nxtchar = m[++w] ; 1215 | } 1216 | } 1217 | s[++sp] = w ; 1218 | for ( ; w < bufend; ) { 1219 | nxtchar = m[w] ; 1220 | if (nxtchar == delimiter) break ; 1221 | w++ ; 1222 | } 1223 | tos = w - s[sp] ; 1224 | if (nxtchar == delimiter) w++ ; 1225 | m[toin] = w - parsebuf ; 1226 | } 1227 | var x_parse = primitive("parse",forthparse) ; 1228 | describe("c -- a n",ans|jsf) ; 1229 | 1230 | 1231 | 1232 | 1233 | 1234 | 1235 | definitions(hidden) ; 1236 | 1237 | // key and key? come in two parts: 1238 | // part 1 signals to virtual machine to stop execution, 1239 | // part 2 will be executed after the input event occured 1240 | // the high level key and key? word call both parts, and, at the 1241 | // same time, provide the after-event reentry point. 1242 | 1243 | function forthkey1() { 1244 | if (!inbuf.length) { 1245 | suspended = w ; 1246 | _input(function() { virtualmachine(ip) ; }) ; 1247 | } 1248 | } 1249 | var x_key1 = primitive("key1",forthkey1) ; 1250 | describe("--",jsf); 1251 | 1252 | function forthkey2() { s[++sp] = tos ; tos = inbuf.shift() ; } 1253 | var x_key2 = primitive("key2",forthkey2) ; 1254 | describe("-- c",jsf); 1255 | 1256 | 1257 | 1258 | 1259 | function forthkey1query() { 1260 | if (!inbuf.length) { // key buffered - no need for event 1261 | suspended = w ; // stop interpreter shortly to allow possible key event 1262 | setTimeout(function() { virtualmachine(ip) ; }, 0) ; // restart short time later 1263 | } 1264 | } 1265 | var x_key1query = primitive("key1?",forthkey1query) ; 1266 | describe("--",jsf); 1267 | 1268 | 1269 | function forthkey2query() { 1270 | s[++sp] = tos ; 1271 | tos = 0 ; // assume "no key" 1272 | if (inbuf.length) tos-- ; // flag "key available" 1273 | } 1274 | var x_key2query = primitive("key2?",forthkey2query) ; 1275 | describe("-- f",jsf); 1276 | 1277 | 1278 | 1279 | 1280 | 1281 | 1282 | // ( bufaddr editaddr nkeys ascii -- bufaddr editaddr nkeys ) 1283 | function forthacceptprintable() { 1284 | w = tos ; 1285 | tos = s[sp--] ; // w:asc, tos:n keys to go, s[sp]:editing address, s[sp-1]: buffer start 1286 | if (tos>1) { 1287 | m[s[sp]] = w ; 1288 | s[sp]++ ; 1289 | tos-- ; 1290 | } 1291 | } 1292 | 1293 | 1294 | 1295 | 1296 | // ( bufaddr editaddr nkeys ascii -- bufaddr editaddr nkeys ) 1297 | function forthacceptescape() { 1298 | tos = s[sp--] ; // tos:n keys to go, s[sp]:editing address, s[sp-1]: buffer start 1299 | tos += (s[sp] - s[sp-1]) ; 1300 | backspaces(s[sp]-s[sp-1]) ; 1301 | s[sp] = s[sp-1] ; 1302 | } 1303 | 1304 | 1305 | 1306 | 1307 | // ( bufaddr editaddr nkeys ascii -- bufaddr editaddr nkeys ) 1308 | // attempt internet explorer workaround 1309 | function forthacceptbackspace() { 1310 | tos = s[sp--]; 1311 | if (s[sp] > s[sp-1]) { 1312 | tos++ ; 1313 | s[sp]-- ; 1314 | backspaces(1); 1315 | } 1316 | } 1317 | 1318 | 1319 | 1320 | 1321 | function forthacceptreturn() { sp-- ; tos = 0 } 1322 | function forthaccepttab() { tos=bl ; forthacceptprintable() ; } 1323 | 1324 | 1325 | 1326 | // ( bufaddr editaddr nkeys ascii -- bufaddr editaddr nkeys ) 1327 | function forthacceptcontrolchar(ctrlchar) { 1328 | if (ctrlchar == esc) { forthacceptescape() ; return ; } 1329 | if (ctrlchar == backspace) { forthacceptbackspace() ; return ; } 1330 | if (ctrlchar == 17) { forthacceptbackspace() ; return ; } // ctrl-q for IE 1331 | if (ctrlchar == carriagereturn) { forthacceptreturn() ; return ; } 1332 | if (ctrlchar == tab) { forthaccepttab() ; return ; } 1333 | tos = s[sp--] ; 1334 | } 1335 | 1336 | 1337 | 1338 | 1339 | 1340 | 1341 | function forthdecode() { // ( bufaddr editaddr nkeys ascii -- bufaddr editaddr nkeys ) 1342 | if (tos>= 1 ; } // 2/ 1546 | var x_2div=primitive("2/",forth2div) ; 1547 | describe("n1 -- n2",any) ; 1548 | 1549 | 1550 | function forthplus() { tos += s[sp--] ; } // + 1551 | 1552 | 1553 | var x_plus=primitive("+",forthplus) ; 1554 | describe("x1 x2 -- x1+x2",any|foerthchen) ; 1555 | 1556 | 1557 | function forthminus() { tos = s[sp--] - tos ; } // - 1558 | var x_minus=primitive("-",forthminus) ; 1559 | describe("x1 x2 -- x1-x2",any) ; 1560 | 1561 | 1562 | function forthmul() { tos = (tos*s[sp--]) & 0xffffffff ; } // * 1563 | var x_mul=primitive("*",forthmul) ; 1564 | describe("x1 x2 -- x1*x2",any|foerthchen) ; 1565 | 1566 | 1567 | var floorfix = 1 - 1e-16 ; 1568 | function forthdiv() { // / 1569 | if (tos) { 1570 | tos = s[sp--] / tos ; 1571 | if (tos<0) tos += floorfix ; 1572 | tos = Math.floor(tos) ; 1573 | return ; 1574 | } 1575 | throwerror(-10) ; 1576 | } 1577 | var x_div=primitive("/",forthdiv) 1578 | describe("x1 x2 -- x1/x2",any) ; 1579 | 1580 | 1581 | function forthstarslash() { // */ 1582 | if (tos) { 1583 | tos = (s[sp--] * s[sp--]) / tos; 1584 | if (tos<0) tos += floorfix ; 1585 | tos = Math.floor(tos) ; 1586 | return ; 1587 | } 1588 | throwerror(-10) ; 1589 | } 1590 | var x_starslash = primitive("*/",forthstarslash) ; 1591 | describe("x1 x2 x3 -- x1*x2/x3",any) ; 1592 | 1593 | 1594 | function forthmod() { // mod 1595 | if (tos) { 1596 | tos= (s[sp--] % tos) ; 1597 | return ; 1598 | } 1599 | throwerror(-10) ; 1600 | } 1601 | var x_mod=primitive("mod",forthmod) ; 1602 | describe("x1 x2 -- x3",any) ; 1603 | 1604 | 1605 | function forthslashmod() { // /mod 1606 | if (tos) { 1607 | w = s[sp] % tos ; 1608 | tos = s[sp] / tos ; 1609 | if (tos<0) tos += floorfix ; 1610 | tos = Math.floor(tos) ; 1611 | s[sp] = w ; 1612 | return ; 1613 | } 1614 | throwerror(-10) ; 1615 | } 1616 | var x_slashmod = primitive("/mod",forthslashmod) ; 1617 | describe("x1 x2 -- x3 x4",any|foerthchen) ; 1618 | 1619 | 1620 | function forthstarslashmod() { // */mod 1621 | if (tos) { 1622 | w = s[sp--] * s[sp] ; 1623 | s[sp] = w % tos ; 1624 | tos = w / tos ; 1625 | if (tos<0) tos += floorfix ; 1626 | tos = Math.floor(tos) ; 1627 | return ; 1628 | } 1629 | throwerror(-10) ; 1630 | } 1631 | var x_starslashmod = primitive("*/mod",forthstarslashmod) ; 1632 | describe("x1 x2 x3 -- x4 x5",any) ; 1633 | 1634 | 1635 | function forthnegate() { tos= -tos ; } // negate 1636 | var x_negate=primitive("negate",forthnegate) ; 1637 | describe("n -- -n",any) ; 1638 | 1639 | 1640 | function forthabs() { tos = Math.abs(tos) ; } // abs 1641 | var x_abs=primitive("abs",forthabs) ; 1642 | describe("n -- u",any) ; 1643 | 1644 | 1645 | function forthlshift() { 1646 | if (tos>31) { 1647 | tos=0; 1648 | sp--; 1649 | } else { 1650 | tos = s[sp--] << tos; // lshift 1651 | } 1652 | } 1653 | var x_lshift = primitive("lshift",forthlshift) ; 1654 | describe("x1 u --x2",ans|f83|jsf) ; 1655 | primitive("<<",forthlshift) ; 1656 | describe("x1 u -- x2",jsf) ; 1657 | 1658 | 1659 | function forthrshift() { 1660 | if (tos>31) { 1661 | tos=0; 1662 | sp--; 1663 | } else { 1664 | tos = s[sp--] >>> tos ; // rshift 1665 | } 1666 | } 1667 | var x_rshift = primitive("rshift",forthrshift) ; 1668 | describe("u1 u2 -- x3",ans|f83|jsf) ; 1669 | primitive(">>",forthrshift) ; 1670 | describe("u1 u2 -- u3",jsf) ; 1671 | 1672 | 1673 | function forthplusstore() { m[tos]+=s[sp--] ; tos=s[sp--] ; } // +! 1674 | var x_plusstore=primitive("+!",forthplusstore) ; 1675 | describe("x a --",any) ; 1676 | 1677 | 1678 | primitive("cells",noop,immediate) 1679 | describe("x1 -- x2",ans|f83|jsf) ; 1680 | 1681 | 1682 | primitive("chars",noop,immediate) // chars 1683 | describe("x1 -- x2",ans|jsf) ; 1684 | 1685 | 1686 | function forthrange() { 1687 | var temp = tos ; 1688 | tos = s[sp] ; 1689 | s[sp] += temp ; 1690 | } 1691 | var x_range = primitive("range",forthrange) ; 1692 | describe("x n -- x+n x",ans|jsf|f83) ; 1693 | 1694 | 1695 | 1696 | 1697 | // ----- double and mixed len math ----- 1698 | 1699 | 1700 | function forthstod() { // s>d 1701 | s[++sp] = tos ; 1702 | tos &= 0x80000000 ; 1703 | if (tos) tos = -1 ; 1704 | } 1705 | var x_stod = primitive("s>d",forthstod) ; 1706 | describe("x -- d",any) ; 1707 | 1708 | 1709 | 1710 | function forthdnegate() { // dnegate 1711 | tos = -tos 1712 | s[sp] = -(s[sp]) ; 1713 | if (s[sp]) tos-- ; 1714 | } 1715 | primitive("dnegate",forthdnegate) ; 1716 | describe("d1 -- -d1",any) ; 1717 | 1718 | 1719 | 1720 | function forthdabs() { // dabs 1721 | if (tos<0) { 1722 | tos = -tos 1723 | s[sp] = -(s[sp]) ; 1724 | if (s[sp]) tos--; 1725 | } 1726 | } 1727 | var x_dabs = primitive("dabs",forthdabs) 1728 | describe("d -- ud",any) ; 1729 | 1730 | 1731 | 1732 | function forthdplus() { // d+ 1733 | if (tos<0) tos += 0x100000000 ; 1734 | var low2 = s[sp--] ; if (low2<0) low2 += 0x100000000 ; 1735 | var high1 = s[sp--] ; if (high1<0) high1 += 0x100000000 ; 1736 | var low1 = s[sp] ; if (low1<0) low1 += 0x100000000 ; 1737 | tos += high1 ; 1738 | w = low1+low2 ; 1739 | if (w > 0x100000000) { // detect carry 1740 | w &= 0xffffffff ; 1741 | tos++ ; // apply carry 1742 | } 1743 | s[sp] = w ; 1744 | tos &= 0xffffffff ; 1745 | } 1746 | var x_dplus = primitive("d+",forthdplus) 1747 | describe("d1 d2 -- d1+d2",any) ; 1748 | 1749 | 1750 | 1751 | 1752 | function forthummul() { // ( u1 u2 -- ud ) // um* 1753 | var resultlo = 0 ; 1754 | var resulthi = 0 ; 1755 | var temp = s[sp] ; 1756 | for ( var i=32 ; i ; --i ) { 1757 | resulthi <<= 1 ; 1758 | if (resultlo & 0x80000000) resulthi++ ; 1759 | resultlo <<= 1 ; 1760 | if (tos & 0x80000000) { 1761 | if ((resultlo + temp) > 0xffffffff) resulthi++ ; 1762 | resultlo += temp ; 1763 | } 1764 | tos <<= 1 ; 1765 | } 1766 | s[sp] = resultlo ; 1767 | tos = resulthi ; 1768 | } 1769 | var x_ummul = primitive("um*",forthummul) 1770 | describe("n1 n2 -- ud",any) ; 1771 | 1772 | 1773 | 1774 | 1775 | function forthmmul() { // m* 1776 | var temp = ((tos<0) ^ (s[sp]<0)) ; 1777 | tos = Math.abs(tos) ; 1778 | s[sp] = Math.abs(s[sp]) ; 1779 | forthummul() ; 1780 | if (temp) forthdnegate() ; 1781 | } 1782 | var x_mmul = primitive("m*",forthmmul) 1783 | describe("n1 n2 -- d",any) ; 1784 | 1785 | 1786 | 1787 | 1788 | function forthdless() { // d< 1789 | w = tos ; 1790 | tos = 0 ; 1791 | if (s[sp-1] < w) { 1792 | tos = -1 ; 1793 | } else { 1794 | if (s[sp-1] == w) { 1795 | if (s[sp-2] < s[sp]) tos = -1 ; 1796 | } 1797 | } 1798 | sp -= 3 ; 1799 | } 1800 | primitive("d<",forthdless) ; 1801 | describe("d1 d2 -- f",any) ; 1802 | 1803 | 1804 | 1805 | function forthdequ() { // d= 1806 | tos = -((tos == s[sp-1]) & (s[sp] == s[sp-2])) 1807 | sp -= 3 ; 1808 | } 1809 | primitive("d=",forthdequ) ; 1810 | describe("d1 d2 -- f",any) ; 1811 | 1812 | 1813 | 1814 | 1815 | 1816 | 1817 | 1818 | function forthumslashmod() { // ( d u1 -- u2 u3 ) 1819 | // skip leading zeroes (not done) 1820 | // shift-and-subtract division 1821 | // tos = divisor 1822 | 1823 | var quotient = 0 ; 1824 | var remainder = 0 ; // portion of divident 1825 | var divbit = 0 ; 1826 | if (tos) { // hi part not 0 ? 1827 | divbit = 0x80000000 ; 1828 | for ( ; divbit ; divbit>>>=1 ) { // skip trailinz zeroes 1829 | if ((tos & divbit) == 0) break; // "late in" in contrast to "early out" 1830 | } 1831 | } 1832 | for (var j=2 ; j ; j--) { // crunch 2x 32 bit 1833 | var divident = s[sp--] ; // next divident portion 1834 | for ( ; divbit ; divbit>>>=1) { 1835 | remainder <<= 1 ; 1836 | if (divident & divbit) remainder++ ; 1837 | quotient<<=1 ; 1838 | if (remainder>=tos) { 1839 | remainder-=tos ; 1840 | quotient++ 1841 | } 1842 | } 1843 | divbit = 0x80000000 ; 1844 | } 1845 | tos = quotient ; 1846 | s[++sp] = remainder ; 1847 | } 1848 | primitive("um/mod",forthumslashmod) ; 1849 | describe("d u1 -- u2 u3",any) ; 1850 | 1851 | 1852 | 1853 | function forthudslashmod() { // ( d1 u1 -- u2 d2 ) 1854 | w = tos ; 1855 | s[++sp] = 0 ; 1856 | forthumslashmod() ; 1857 | s[++sp] = w ; 1858 | w = tos ; 1859 | tos = s[sp--] ; 1860 | forthumslashmod() ; 1861 | s[++sp] = tos ; 1862 | tos = w ; 1863 | } 1864 | var x_udslashmod = primitive("ud/mod",forthudslashmod) ; 1865 | describe("d1 u1 -- u2 d2",jsf) ; 1866 | 1867 | 1868 | 1869 | 1870 | 1871 | // ================================================================================================= 1872 | // bool 1873 | // ================================================================================================= 1874 | 1875 | 1876 | definitions(forth) ; 1877 | 1878 | function forthor() { tos |= s[sp--] ; } // or 1879 | var x_or = primitive("or",forthor) ; 1880 | describe("x1 x2 -- x3",any|foerthchen) ; 1881 | 1882 | 1883 | function forthand() { tos &= s[sp--] ; } // and 1884 | var x_and = primitive("and",forthand) ; 1885 | describe("x1 x2 -- x3",any|foerthchen) ; 1886 | 1887 | 1888 | function forthxor() { tos ^= s[sp--] ; } // xor 1889 | primitive("xor",forthxor) ; 1890 | describe("x1 x2 -- x3",any|foerthchen) ; 1891 | 1892 | 1893 | function forthinvert() { tos ^= -1 ; } // invert 1894 | primitive("invert",forthinvert) ; 1895 | describe("x1 -- x2",ans|jsf) ; 1896 | 1897 | 1898 | primitive("not",forthinvert) ; // not 1899 | describe("x1 -- x2",fig|f79) ; 1900 | 1901 | 1902 | 1903 | 1904 | 1905 | 1906 | 1907 | // ================================================================================================= 1908 | // logic 1909 | // ================================================================================================= 1910 | function forthequ() { tos = -(tos == s[sp--]) ; } // = 1911 | var x_equ = primitive("=",forthequ) ; 1912 | describe("x1 x2 -- f",any) ; 1913 | 1914 | 1915 | function forthnequ() { tos = -(tos != s[sp--]) ; } // <> 1916 | var x_nequ = primitive("<>",forthnequ) ; 1917 | describe("x1 x2 -- f",any) ; 1918 | 1919 | 1920 | function forthmore() { tos = -(tos < s[sp--]) ; } // > 1921 | var x_more = primitive(">",forthmore) ; 1922 | describe("n1 n2 -- f",any) ; 1923 | 1924 | 1925 | function forthless() { tos = -(tos > s[sp--]) ; } // < 1926 | var x_less = primitive("<",forthless) ; 1927 | describe("n1 n2 -- f",any) ; 1928 | 1929 | 1930 | function forth0equ() { tos = -(tos == 0) ; } // 0= 1931 | var x_0equ = primitive("0=",forth0equ) ; 1932 | describe("x -- f",any) ; 1933 | 1934 | 1935 | function forth0nequ() { tos = -(tos != 0) ; } // 0<> 1936 | primitive("0<>",forth0nequ) ; 1937 | describe("x -- f",any) ; 1938 | 1939 | 1940 | function forth0less() { tos = -(tos < 0) ; } // 0< 1941 | var x_0less = primitive("0<",forth0less) ; 1942 | describe("n -- f",any) ; 1943 | 1944 | 1945 | function forth0greater() { tos = -(tos > 0) ; } // 0> 1946 | var x_0greater = primitive("0>",forth0greater) ; 1947 | describe("n -- f",any) ; 1948 | 1949 | 1950 | 1951 | function forthuless() { // u< 1952 | w = s[sp--] ; 1953 | if (tos<0) tos += 0x100000000 ; 1954 | if (w<0) w += 0x100000000 ; 1955 | tos = -(w 1962 | w = s[sp--] ; 1963 | if (tos<0) tos += 0x100000000 ; 1964 | if (w<0) w += 0x100000000 ; 1965 | tos = -(w>tos) ; 1966 | } 1967 | primitive("u>",forthumore) ; 1968 | describe("u1 u2 -- f",any) ; 1969 | 1970 | 1971 | 1972 | 1973 | function forthwithin() { // ( x1 x2 x3 -- flag ) // within 1974 | w = s[sp--] ; 1975 | var temp = s[sp--] ; 1976 | var temp2 = tos ; 1977 | tos = -1 ; 1978 | if (w < temp2) { 1979 | if (w <= temp) { 1980 | if (temp < temp2) return ; 1981 | } 1982 | } 1983 | if (w > temp2) { 1984 | if (w <= temp) return ; 1985 | if (temp < temp2) return ; 1986 | } 1987 | tos++ ; 1988 | } 1989 | primitive("within",forthwithin) ; 1990 | describe("x1 x2 x3 -- f",any) ; 1991 | 1992 | 1993 | 1994 | 1995 | 1996 | 1997 | 1998 | 1999 | // ================================================================================================= 2000 | // pictured number conversion 2001 | // ================================================================================================= 2002 | 2003 | // non standard stack: does currently not expect double, but single number 2004 | // that's why further implementation has been postponed - need double math first. 2005 | // ( d -- d ) 2006 | 2007 | var picturedoutpos ; 2008 | var picturedoutlen ; 2009 | 2010 | function forthlesshash() { // <# 2011 | picturedoutpos = dp + paddistance ; 2012 | picturedoutlen = 0 ; // avoiding len calc allow to allot 2013 | } // during pic num conv 2014 | var x_lesshash = primitive("<#",forthlesshash) ; 2015 | describe("--",any) ; 2016 | 2017 | 2018 | 2019 | function forthhold() { 2020 | m[--picturedoutpos] = tos ; 2021 | picturedoutlen++ ; 2022 | tos = s[sp--] ; 2023 | } 2024 | var x_hold = primitive("hold",forthhold) ; 2025 | describe("c --",any) ; 2026 | 2027 | 2028 | 2029 | function forthsign() { 2030 | if (tos<0) { 2031 | m[--picturedoutpos] = 45 ; 2032 | picturedoutlen++ ; 2033 | } 2034 | tos = s[sp--] 2035 | } 2036 | var x_sign = primitive("sign",forthsign) ; 2037 | describe("n --",any) ; 2038 | 2039 | 2040 | 2041 | 2042 | function forthhashmore() { // #> 2043 | s[sp] = picturedoutpos ; 2044 | tos = picturedoutlen ; 2045 | } // during pic num conv 2046 | var x_hashmore = primitive("#>",forthhashmore) ; 2047 | describe("-- a n",any) ; 2048 | 2049 | 2050 | 2051 | 2052 | 2053 | 2054 | 2055 | 2056 | 2057 | 2058 | // ================================================================================================= 2059 | // does> 2060 | // ================================================================================================= 2061 | 2062 | definitions(hidden) ; 2063 | 2064 | // linkage code for word, created by defining word. 2065 | function dodoes() { 2066 | s[++sp] = tos ; tos = x[w] ; // push words address of defined word 2067 | r[++rp] = ip ; // nest 2068 | ip = m[tos++] ; // set ip to does> part, and tos to body of defined word 2069 | w = m[ip++] ; t[w]() ; // next 2070 | } 2071 | 2072 | 2073 | 2074 | // compiled to end of create part by does> 2075 | // executed during execution of defining word 2076 | function setdoes() { // tos: xt of does> part 2077 | m[x[wc]] = ip+1 ; // created word points to does> 2078 | t[wc] = dodoes ; // created word linkage code is dodoes 2079 | } 2080 | var x_setdoes = primitive("setdoes",setdoes) ; 2081 | 2082 | 2083 | 2084 | 2085 | 2086 | 2087 | 2088 | 2089 | // ================================================================================================= 2090 | // flow control 2091 | // ================================================================================================= 2092 | 2093 | definitions(hidden) ; 2094 | 2095 | 2096 | function forthbrfor() { 2097 | r[++rp]=tos ; 2098 | r[++rp]=tos ; 2099 | ip++ ; 2100 | tos=s[sp--] ; 2101 | } 2102 | var x_brfor=primitive("(for)",forthbrfor) ; 2103 | 2104 | 2105 | function forthbrnext() { 2106 | r[rp]-- ; 2107 | if (r[rp]) { 2108 | ip+=m[ip] ; 2109 | } else { 2110 | ip++ ; 2111 | rp-=2 ; 2112 | } 2113 | } 2114 | var x_brnext=primitive("(next)",forthbrnext) ; 2115 | 2116 | 2117 | function forthbrdo() { 2118 | r[++rp]=s[sp--] ; 2119 | r[++rp]=tos ; 2120 | ip++ ; 2121 | tos=s[sp--] ; 2122 | } 2123 | var x_brdo=primitive("(do)",forthbrdo) ; 2124 | 2125 | 2126 | function forthbrqdo() { 2127 | if ( tos == s[sp] ) { 2128 | sp-- ; 2129 | ip+=m[ip] ; 2130 | } else { 2131 | r[++rp]=s[sp--] ; 2132 | r[++rp]=tos ; 2133 | ip++ ; 2134 | } 2135 | tos=s[sp--] ; 2136 | } 2137 | var x_brqdo=primitive("(?do)",forthbrqdo) ; 2138 | 2139 | 2140 | 2141 | // fig/f79 leave 2142 | function forthbrleave79() { r[rp] = r[rp-1]-1 ; } 2143 | var x_brleave79 = primitive("(leave)",forthbrleave79) ; 2144 | 2145 | 2146 | 2147 | // ans/f83 leave 2148 | function forthbrleave() { 2149 | rp -= 2 ; 2150 | ip = m[ip] ; 2151 | ip += m[ip] ; 2152 | } 2153 | var x_brleave=primitive("(leave)",forthbrleave) ; 2154 | 2155 | 2156 | 2157 | 2158 | function forthbrqleave() { 2159 | if (tos) { 2160 | rp -= 2 ; 2161 | ip = m[ip] ; 2162 | ip += m[ip] ; 2163 | } else { 2164 | ip++ ; 2165 | } 2166 | tos=s[sp--] ; 2167 | } 2168 | var x_brqleave=primitive("(?leave)",forthbrqleave) ; 2169 | 2170 | 2171 | 2172 | 2173 | function forthbrloop() { 2174 | r[rp]++ ; 2175 | if ( r[rp] != r[rp-1] ) { 2176 | ip+=m[ip] ; 2177 | } else { 2178 | ip++ ; 2179 | rp-=2 ; 2180 | } 2181 | } 2182 | var x_brloop=primitive("(loop)",forthbrloop) ; 2183 | describe("--",jsf) ; 2184 | 2185 | 2186 | 2187 | function forthbrplusloop() { // (+loop) 2188 | w = r[rp] - r[rp-1] ; 2189 | r[rp] += tos ; 2190 | tos=s[sp--] ; 2191 | if ( (( r[rp] - r[rp-1]) ^ w ) > 0 ) { 2192 | ip+=m[ip] ; 2193 | } else { 2194 | ip++ ; 2195 | rp-=2 ; 2196 | } 2197 | } 2198 | var x_brplusloop=primitive("(+loop)",forthbrplusloop) ; 2199 | describe("n --",jsf) ; 2200 | 2201 | 2202 | 2203 | 2204 | function forthbrunloop() { rp-=2 ; } 2205 | var x_brunloop = primitive("(unloop)",forthbrunloop) ; 2206 | describe("--",jsf) ; 2207 | 2208 | 2209 | 2210 | 2211 | function forthbrof() { // (of) 2212 | w = tos ; 2213 | tos = s[sp--] ; 2214 | if (w == tos) { 2215 | tos = s[sp--] 2216 | ip++ 2217 | } else { 2218 | ip+=m[ip] ; 2219 | } 2220 | } 2221 | var x_brof = primitive("(of)",forthbrof) ; 2222 | describe("x1 x2 -- x1 |",jsf) ; 2223 | 2224 | 2225 | 2226 | 2227 | 2228 | 2229 | definitions(forth) ; 2230 | 2231 | function forthexecute() { w=tos ; tos=s[sp--] ; t[w]() ; } 2232 | var x_execute = primitive("execute",forthexecute) ; 2233 | describe("xt --",any) ; 2234 | 2235 | 2236 | function forthperform() { w=m[tos] ; tos=s[sp--] ; t[w]() ; } 2237 | var x_perform = primitive("perform",forthperform) ; 2238 | describe("a --",jsf) ; 2239 | 2240 | 2241 | 2242 | 2243 | function forthi() { s[++sp]=tos ; tos=r[rp] ; } 2244 | var x_i=primitive("i",forthi) ; 2245 | describe("-- x",any) ; 2246 | 2247 | 2248 | function forthj() { s[++sp]=tos ; tos=r[rp-2] ; } 2249 | var x_j=primitive("j",forthj) ; 2250 | describe("-- x",any) ; 2251 | 2252 | 2253 | 2254 | definitions(hidden) ; 2255 | 2256 | var controlflow = new Array("","if", "", "begin", "while", "do or ?do", "for", "case", "of") 2257 | var controlflowwant = new Array("","else or then","then","while,until or again","repeat","loop or +loop", "next", "endcase", "endof") 2258 | function forthunstructured() { 2259 | systemerror[66] = "unstructured, missing " + controlflow[tos] + ", expected " + controlflowwant[s[sp]] ; 2260 | throwerror(-66) ; 2261 | } 2262 | var x_unstructured = primitive("unstructured",forthunstructured) 2263 | 2264 | 2265 | 2266 | 2267 | 2268 | // ================================================================================================= 2269 | // strings 2270 | // ================================================================================================= 2271 | 2272 | 2273 | definitions(forth) ; 2274 | 2275 | function forthmove() { // move 2276 | if ( s[sp] > s[sp+1] ) { 2277 | dest = s[sp--] + tos ; 2278 | src = s[sp--] + tos ; 2279 | for ( ; tos ; tos-- ) m[--dest] = m[--src] ; 2280 | } else { 2281 | var dest = s[sp--] ; 2282 | var src = s[sp--] ; 2283 | for ( ; tos ; tos-- ) m[dest++] = m[src++] ; 2284 | } 2285 | tos = s[sp--] ; 2286 | } 2287 | var x_move = primitive("move",forthmove) ; 2288 | describe("a1 a2 u --",any) ; 2289 | 2290 | primitive("cmove",forthmove) ; 2291 | describe("a1 a2 u",any) ; 2292 | 2293 | 2294 | 2295 | definitions(hidden) ; 2296 | 2297 | function forthmovestr() { // ( a1 n a2 -- ) // move$ 2298 | w = s[sp] ; 2299 | m[tos++] = w ; 2300 | s[sp] = tos ; 2301 | tos = w ; 2302 | forthmove() ; 2303 | } 2304 | var x_movestr = primitive("move$",forthmovestr) ; 2305 | describe("a1 n a2 --",jsf) ; 2306 | 2307 | 2308 | 2309 | definitions(forth) ; 2310 | 2311 | function forthmintrailing() { // a1 n1 -- a2 n2 ) 2312 | var temp = s[sp] + tos ; 2313 | for ( i=tos ; i ; i-- ) { 2314 | if (m[--temp] != 32) break ; 2315 | tos-- ; 2316 | } 2317 | } 2318 | var x_mintrailing = primitive("-trailing",forthmintrailing) ; 2319 | describe("a1 u1 -- a2 u2",any) ; 2320 | 2321 | 2322 | 2323 | 2324 | 2325 | 2326 | 2327 | 2328 | // ----- number input conversion ----- 2329 | 2330 | 2331 | 2332 | function forthdigit() { // ( c -- u | -1 ) 2333 | tos -= 48 ; 2334 | if ( tos > 9 ) { 2335 | if ( tos < 17) tos = -1 ; 2336 | tos -= 7 ; 2337 | } 2338 | if ( tos > 41 ) tos -= 32 ; 2339 | if ( tos >= 0) { 2340 | if (tos < m[base]) return ; 2341 | } 2342 | tos = -1 ; 2343 | } 2344 | var x_digit = primitive("digit",forthdigit); 2345 | describe("c -- u|-1",jsf) ; 2346 | 2347 | 2348 | 2349 | definitions(hidden) ; 2350 | 2351 | function forthqsinglenumber() { // a n -- x -1 | 0 ) 2352 | var digit ; 2353 | var sign=0 ; 2354 | var radix=m[base] ; 2355 | i = tos ; // number of digits to test/convert 2356 | tos = -1 ; // assume valid number 2357 | w = s[sp] ; // addr of next digit 2358 | s[sp] = 0 ; // accumulator 2359 | if ( m[w] == 45 ) { // leading - 2360 | sign = -1 ; 2361 | w++ ; // strip 2362 | i-- ; 2363 | } 2364 | for ( var i ; i ; i-- ) { // for all digits 2365 | digit = m[w++] - 48 ; // read digit 2366 | if ( digit == -2 ) exception("no input support for floating point numbers yet") ; 2367 | if ( digit > 9 ) { 2368 | if ( digit < 17) { tos = 0 ; break ; } 2369 | digit -= 7 ; 2370 | } 2371 | if ( digit > 41 ) digit -= 32 ; 2372 | if ( digit < 0 ) { tos = 0 ; break ; } 2373 | if (digit >= radix) { tos = 0 ; break ; } 2374 | s[sp] *= radix ; 2375 | s[sp] += digit ; 2376 | } 2377 | if (tos) { 2378 | if (sign) s[sp] = -s[sp] ; 2379 | s[sp] &= 0xffffffff ; 2380 | } else { 2381 | sp-- ; // drop string address 2382 | } 2383 | } 2384 | 2385 | // parseFloat(string) ; 2386 | 2387 | 2388 | function forthqnumber() { // a n -- x -1 | 0 ) 2389 | if (m[s[sp]+tos-1]==46) { 2390 | exception("no input support for double length numbers yet") ; 2391 | sp-- ; tos=0 ; 2392 | } else { 2393 | forthqsinglenumber() 2394 | } 2395 | } 2396 | var x_qnumber = primitive("?number",forthqnumber) ; 2397 | 2398 | 2399 | 2400 | 2401 | function forthinterpretnumber() { // ( a n -- x -1 | d -1 | r -1 | -1 | 0 ) 2402 | forthqnumber() ; 2403 | if (tos) { 2404 | if (m[state]) { 2405 | m[dp++] = x_lit ; 2406 | m[dp++] = s[sp--] ; 2407 | tos = -1 ; 2408 | } 2409 | } 2410 | } 2411 | var x_interpretnumber = primitive("interpretnumber",forthinterpretnumber) ; 2412 | 2413 | 2414 | 2415 | 2416 | // function forthinterpretnumber() 2417 | // first char = - ? 2418 | // if remember skip then 2419 | // for all chars in string: 2420 | // next char = digit ? 2421 | // if accumulate 2422 | // else 2423 | // char = . ? 2424 | // if 2425 | // 2426 | // else 2427 | // otherlegalchars? none if NaN then 2428 | // then 2429 | // then 2430 | // next 2431 | // negate? 2432 | // state @ if 2433 | // compile lit 2434 | // then ; 2435 | 2436 | 2437 | 2438 | // ================================================================================================= 2439 | // dictionary, compiling 2440 | // ================================================================================================= 2441 | 2442 | 2443 | 2444 | definitions(forth) ; 2445 | 2446 | 2447 | // this has been speeded up a lot, by using an 2448 | // improvement suggested by TheBlueWizard. 2449 | function forthwords() { // words 2450 | for (var i=wc; i; i--) { 2451 | if (h[i]) { 2452 | if (m[context] & ds[i]) { 2453 | if (m[compliance] & ds[i]) querytype(h[i]+" ") ; 2454 | } 2455 | } 2456 | } 2457 | } 2458 | var x_words = primitive("words",forthwords) ; 2459 | describe("--",f83|ans|jsf|foerthchen|only) ; 2460 | 2461 | 2462 | function forthvlist() { forthwords() ; } 2463 | primitive("vlist",forthvlist) ; 2464 | describe("--",f79|fig) ; 2465 | 2466 | 2467 | 2468 | function forthhere() { s[++sp]=tos ; tos=dp ; } // here 2469 | var x_here= primitive("here",forthhere) ; 2470 | describe("-- a",any) ; 2471 | 2472 | 2473 | 2474 | 2475 | function forthallot() { // allot 2476 | if ((dp+tos)>dictionaryfull) { 2477 | throwerror(-8) ; 2478 | } else { 2479 | dp+=tos ; 2480 | tos=s[sp--] ; 2481 | } 2482 | } 2483 | var x_allot= primitive("allot",forthallot) ; 2484 | describe("n --",any) ; 2485 | 2486 | 2487 | function forthhide() { hf[wc] &= (!smudgebit) ; } // hide 2488 | var x_hide= primitive("hide",forthhide) ; 2489 | describe("--",f83) ; 2490 | 2491 | 2492 | function forthreveal() { hf[wc] |= smudgebit ; } // reveal 2493 | var x_reveal= primitive("reveal",forthreveal) ; 2494 | describe("--",f83) ; 2495 | 2496 | 2497 | 2498 | function comma(x) { 2499 | if ((dp+1) >= dictionaryfull) { 2500 | throwerror(-8) ; 2501 | } else { 2502 | m[dp++] = x ; 2503 | } 2504 | } 2505 | function forthcomma() { comma(tos) ; tos = s[sp--] ; } // , 2506 | var x_comma = primitive(",",forthcomma) ; 2507 | describe("x --",any) ; 2508 | var x_ccomma = primitive("c,",forthcomma) ; // c, 2509 | describe("c --",any) ; 2510 | 2511 | 2512 | 2513 | 2514 | function compile() { for (var i=0 ; ibody",forthtobody) ; 2598 | describe("a1 -- a2",any) ; 2599 | 2600 | 2601 | function forthbodyfrom() { // ( a1 -- a2 ) 2602 | tos-- ; 2603 | for (var i=wc; i; i--) { // loop through headers last first 2604 | if (h[i]) { 2605 | if (x[i] == tos) { // word pointer match ? 2606 | tos = i; // yes, return xt 2607 | return; 2608 | } 2609 | } 2610 | } 2611 | throwerror(-65) ; 2612 | } 2613 | primitive("body>",forthbodyfrom) ; 2614 | describe("a1 -- a2",jsf) ; 2615 | 2616 | 2617 | 2618 | 2619 | definitions(hidden) ; 2620 | 2621 | 2622 | function forthqimm() { tos = -(hf[tos] & precedencebit) ; } // ( xt -- f ) 2623 | var x_qimm = primitive("?immediate",forthqimm) ; // ?immediate 2624 | 2625 | 2626 | 2627 | function forthcompiling() { s[++sp] = tos ; tos = m[state] ; } // compiling 2628 | var x_compiling = primitive("compiling",forthcompiling) ; 2629 | 2630 | 2631 | definitions(forth) ; 2632 | 2633 | 2634 | function forthimmediate() { hf[wc] |= precedencebit ; } // immediate 2635 | primitive("immediate",forthimmediate) ; 2636 | describe("--",any) ; 2637 | 2638 | 2639 | 2640 | 2641 | 2642 | 2643 | function forthbrclose() { m[state] = true ; } // ] 2644 | var x_brclose = primitive("]",forthbrclose) ; 2645 | describe("--",any) ; 2646 | 2647 | 2648 | function forthbropen() { m[state] = false ; } // [ 2649 | var x_bropen = primitive("[",forthbropen,immediate) ; 2650 | describe("--",any) ; 2651 | 2652 | 2653 | definitions(hidden) ; 2654 | 2655 | function forthnewheader() { // newheader 2656 | forthpack() ; 2657 | newheader(tos) ; 2658 | tos=s[sp--] ; 2659 | } 2660 | var x_newheader = primitive("newheader",forthnewheader) ; 2661 | 2662 | 2663 | definitions(forth) ; 2664 | 2665 | 2666 | function forthdotname() { // ( xt -- ) // .name 2667 | type(h[tos]) ; 2668 | tos = s[sp--] ; 2669 | } 2670 | var x_dotname = primitive(".name",forthdotname) ; 2671 | describe("xt --",jsf) ; 2672 | 2673 | 2674 | function forthname() { // ( xt -- a n ) // name 2675 | sp++ ; 2676 | s[++sp] = h[tos] ; 2677 | tos = dp ; 2678 | s[sp-1] = tos ; 2679 | unpack() ; 2680 | } 2681 | primitive("name",forthname) ; 2682 | describe("x1 -- a u",jsf) ; 2683 | 2684 | 2685 | 2686 | definitions(hidden) ; 2687 | 2688 | function forthcreateheader() { 2689 | s[++sp] = tos ; 2690 | tos = bl ; 2691 | forthparse() ; 2692 | forthnewheader() ; 2693 | } 2694 | var x_createheader = primitive("createheader",forthcreateheader) ; 2695 | 2696 | 2697 | function forthuse() { 2698 | forthcreateheader() ; 2699 | forthcomma() ; 2700 | t[wc] = nexthilevel ; 2701 | } 2702 | var x_use = primitive("use",forthuse) ; 2703 | 2704 | 2705 | 2706 | definitions(forth) ; 2707 | 2708 | function forthcolonnoname() { // :noname 2709 | s[++sp] = tos ; 2710 | newheader("") ; 2711 | tos = wc ; 2712 | comma(x_nest) ; 2713 | m[state] = -1 ; 2714 | t[wc] = nexthilevel ; 2715 | } 2716 | primitive(":noname",forthcolonnoname) 2717 | describe("-- a",ans|jsf) ; 2718 | 2719 | 2720 | 2721 | 2722 | function forthunused() { 2723 | s[++sp] = tos ; 2724 | tos = dictionaryfull - dp ; 2725 | } 2726 | primitive("unused",forthunused) ; 2727 | describe("-- u",ans|jsf) ; 2728 | 2729 | 2730 | 2731 | 2732 | 2733 | function forthheap() { // ( -- a ) 2734 | s[++sp] = tos ; 2735 | tos = heapend ; 2736 | } 2737 | primitive("heap",forthheap) ; 2738 | describe("-- a",jsf) ; 2739 | 2740 | 2741 | function forthbrmarker() { // ( wc dp -- ) 2742 | dp = tos ; 2743 | wc = s[sp--] ; 2744 | m[lastxt] = wc ; 2745 | tos = s[sp--] ; 2746 | } 2747 | primitive("(marker)",forthbrmarker) ; 2748 | describe("wc dp heap --",jsf) ; 2749 | 2750 | 2751 | 2752 | 2753 | 2754 | // ================================================================================================= 2755 | // mass storage 2756 | // ================================================================================================= 2757 | 2758 | 2759 | 2760 | 2761 | 2762 | 2763 | 2764 | // ------------------------------------------- memory drive -------------------------------------------- 2765 | 2766 | var ramblock = new Array() ; 2767 | var screenline ; 2768 | 2769 | function saveblock() { 2770 | for (i=screenline.length ; i<16 ; i++) screenline.push("") ; 2771 | for (i=screenline.length ; i>16 ; i--) screenline.pop() ; 2772 | ramblock.push(screenline) ; 2773 | } 2774 | 2775 | 2776 | 2777 | screenline = new Array() ; 2778 | screenline.push("( ramdrive block 0 - essential block words -load- )") ; 2779 | screenline.push(": copy (s u1 u2 -- ) swap block swap buffer c/s move update ;") ; 2780 | screenline.push(": clear (s u -- ) buffer c/s blank update ;") ; 2781 | screenline.push(": index1 (s u -- ) dup scr ! 2 .r space 0 .line ;") ; 2782 | screenline.push(": index (s u1 u2 -- ) 1+ swap ?do cr i index1 loop ;") ; 2783 | screenline.push(": ls (s -- ) 0 capacity 1- index ;") ; 2784 | screenline.push(": w (s -- ) last @ 1+ 1 do i name dup if ") ; 2785 | screenline.push(" 2dup info s\" \" ...info i stackeffect ...info") ; 2786 | screenline.push(" then 2drop loop ;") ; 2787 | screenline.push(": --> (s -- ) blk @ 1+ block c/s !source >in off ; immediate") ; 2788 | screenline.push(": uppercase dup char a char z 1+ within 32 and - ;") ; 2789 | screenline.push(": p (s -- ) scr @ 1- 0 max scr ! ;") ; 2790 | screenline.push(": n (s -- ) scr @ 1+ capacity 1- min scr ! ;") ; 2791 | screenline.push(": view (s -- ) begin key dup esc <> while uppercase") ; 2792 | screenline.push(" dup char N = if n else dup char P = if p then then") ; 2793 | screenline.push(" drop cls l repeat drop ;") ; 2794 | saveblock() ; 2795 | 2796 | 2797 | 2798 | screenline = new Array() ; 2799 | screenline.push("( ramdrive block 1 - MARKER + info screen words -load- )") ; 2800 | screenline.push(": marker here last @ create , ,") ; 2801 | screenline.push(" does> skim swap @ (marker) ;") ; 2802 | screenline.push("") ; 2803 | screenline.push(": cr2 (s -- ) s\" \" info ;") ; 2804 | screenline.push("") ; 2805 | screenline.push(": .line2 (s u -- ) c/l * screen + c/l -trailing info ;") ; 2806 | screenline.push("") ; 2807 | screenline.push("( list screen on info window )") ; 2808 | screenline.push(": list2 (s u -- ) scr ! l/s 0 do i .line2 loop ;") ; 2809 | screenline.push("") ; 2810 | screenline.push("( list all screens on info, enable backscroll )") ; 2811 | screenline.push(": sources (s -- ) capacity 0 do i list2 loop all ;") ; 2812 | saveblock() ; 2813 | 2814 | 2815 | 2816 | screenline = new Array() ; 2817 | screenline.push("( ramdrive block 2 - hex dump -load- )") ; 2818 | screenline.push("hidden definitions 6 constant dumps/line"); 2819 | screenline.push(": safe-emit (s c -- ) dup bl 128 within 0=") ; 2820 | screenline.push(" if drop char . then emit ;") ; 2821 | screenline.push(": ######## (s u -- ) 0 <# 8 for # next #> type ;") ; 2822 | screenline.push(": .cell (s u -- ) 16 base exchange swap ######## space base ! ;") ; 2823 | screenline.push(": .addr (s u -- ) .cell ;") ; 2824 | screenline.push(": pad_dump1 (s n -- ) 4 swap - 3 * spaces ;") ; 2825 | screenline.push(": dump_cells (s a n -- ) for skim .cell next drop ;") ; 2826 | screenline.push(": dump_chars (s a n -- ) for count safe-emit next drop ;") ; 2827 | screenline.push(": dump1line (s a n -- ) dumps/line min dup if over .addr") ; 2828 | screenline.push(" 2 spaces 2dup dump_cells dup pad_dump1 2 spaces") ; 2829 | screenline.push(" 2dup dump_chars then 2drop ;") ; 2830 | screenline.push("forth definitions hidden") ; 2831 | screenline.push(": dump (s a n -- ) begin ?dup while 2dup cr dump1line") ; 2832 | screenline.push(" dumps/line /string repeat drop ; forth") ; 2833 | saveblock() ; 2834 | 2835 | 2836 | 2837 | screenline = new Array(); 2838 | screenline.push("( ramdrive block 3 - modified retro editor )") ; 2839 | screenline.push(": line (s u -- a ) c/l * screen + ;") ; 2840 | screenline.push(": s (s u -- ) scr ! ;") ; 2841 | screenline.push(": ia (s a u -- ) line + >r 0 parse r> swap cmove ;") ; 2842 | screenline.push(": r (s u -- ) 0 swap ia ;") ; 2843 | screenline.push(": d (s u -- ) line c/l blank ;") ; 2844 | screenline.push(": x (s -- ) clear ;") ; 2845 | screenline.push(": v (s -- ) l ;") ; 2846 | screenline.push("( extensions: bubble up and down lines )") ; 2847 | screenline.push(": >pad (s a n -- ) pad swap move ;") ; 2848 | screenline.push(": pad> (s a n -- ) pad -rot move ;") ; 2849 | screenline.push(": lines (s u1 u2 -- a1 a2 ) line swap line swap ;") ; 2850 | screenline.push(": xchg lines over >r dup c/l >pad c/l move r> c/l pad> ;") ; 2851 | screenline.push(": bu (s u1 -- ) ?dup if dup 1- xchg then ;") ; 2852 | screenline.push(": bd (s u1 -- ) dup l/s 1- < if dup 1+ bu then drop ;") ; 2853 | saveblock() ; 2854 | 2855 | 2856 | 2857 | screenline = new Array("( ramdrive block 4 - empty )") ; saveblock() ; 2858 | screenline = new Array("( ramdrive block 5 - empty )") ; saveblock() ; 2859 | screenline = new Array("( ramdrive block 6 - empty )") ; saveblock() ; 2860 | screenline = new Array("( ramdrive block 7 - empty )") ; saveblock() ; 2861 | screenline = new Array("( ramdrive block 8 - empty )") ; saveblock() ; 2862 | screenline = new Array("( ramdrive block 9 - empty )") ; saveblock() ; 2863 | screenline = new Array("( ramdrive block 10 - empty )") ; saveblock() ; 2864 | screenline = new Array("( ramdrive block 11 - empty )") ; saveblock() ; 2865 | 2866 | 2867 | 2868 | 2869 | 2870 | // ---------------------------- ram drive ---------------------------- 2871 | 2872 | 2873 | function loadblockfromram(n,a) { // unpack block n to address 2874 | debug("ram drive: block " + n + " to addr " + a) ; 2875 | var temp = a ; 2876 | for ( i=0; i<16; i++ ) { 2877 | s[++sp] = lineofspaces.substr(0,64) ; tos = temp ; unpack() ; 2878 | s[++sp] = ramblock[n][i].substr(0,64) ; tos = temp ; unpack() ; 2879 | temp += 64 ; 2880 | } 2881 | return a ; 2882 | } 2883 | 2884 | 2885 | 2886 | function savebuftoram(addr,blocknum) { 2887 | debug("ram drive: from " + addr + " to ramblock " + blocknum) 2888 | for ( i=0; i<16; i++ ) { 2889 | ramblock[blocknum][i] = pack(addr,64) ; 2890 | addr += 64 ; 2891 | } 2892 | } 2893 | 2894 | 2895 | 2896 | 2897 | 2898 | 2899 | 2900 | function ramdrivecapacity() { return ramblock.length } ; 2901 | 2902 | 2903 | 2904 | // ------------------------- cookie drive ------------------------------ 2905 | 2906 | 2907 | var cookiesectorsize = 1024 // decrease size to spread block across multiple cookies 2908 | 2909 | function loadblockfromcookie(blknum,destaddr) { // unpack block to address 2910 | debug("cookie drive: block " + blknum + " to addr " + destaddr) ; 2911 | for (var i=0 ; i<1024 ; i+=cookiesectorsize) { 2912 | var cookiename = (cookiebasename + blknum + "_" + i) ; 2913 | var temp = (readcookie(cookiename, destaddr+i)) 2914 | if (temp) { 2915 | unpackstring(temp.substr(0,cookiesectorsize),destaddr+i) ; 2916 | } else { 2917 | temp = destaddr+i ; 2918 | for (var j=0 ; j=capacity()) || (tos<0)) throwerror(-35) ; 3011 | if (blockstat[tos] >= 0) { // block already mapped: 3012 | hotbuffer = blockstat[tos] ; 3013 | tos = buf[hotbuffer] ; // return buffer address 3014 | } else { // block not mapped: 3015 | nextbuf++ ; // next available buffer 3016 | nextbuf %= maxbufs ; 3017 | if (bufblk[nextbuf] >= 0) { // buffer used for another block 3018 | if (bufdirty[nextbuf]) savebuf(nextbuf) ; // dirty ? 3019 | blockstat[bufblk[nextbuf]] = -1; // write block info "unbuffered" 3020 | } 3021 | var temp = tos ; 3022 | if (flag) { 3023 | tos = loadblock(tos,buf[nextbuf]) ; // block: fill block with data from mass memory. 3024 | } else { 3025 | tos = buf[nextbuf] ; // buffer: indefinite buffer contents. 3026 | } 3027 | hotbuffer = nextbuf ; 3028 | bufblk[nextbuf] = temp ; // associate buf with block# 3029 | blockstat[temp] = nextbuf ; // set block info "buffered in ..." 3030 | } 3031 | } 3032 | 3033 | 3034 | 3035 | 3036 | function forthbuffer() { forthblockorbuffer(false) ; } // ( u -- a ) 3037 | var x_buffer = primitive("buffer",forthbuffer) ; 3038 | describe("u -- a",any) ; 3039 | 3040 | 3041 | 3042 | function forthblock() { forthblockorbuffer(true) ; } // ( u -- a ) 3043 | var x_block = primitive("block",forthblock) ; 3044 | describe("u -- a",any) ; 3045 | 3046 | 3047 | 3048 | function forthupdate() { bufdirty[hotbuffer] = -1 ; } 3049 | primitive("update",forthupdate) ; 3050 | describe("--",any) ; 3051 | 3052 | 3053 | 3054 | 3055 | function forthsavebuffers() { 3056 | for (var i=0 ; i=0) { // buffer has block in ? 3070 | blockstat[bufblk[i]] = -1 ; // mark block as not buffered anymore 3071 | bufblk[i] = -1 ; // mark buffer as not containing a block 3072 | bufdirty[i] = 0 ; // set clean 3073 | } 3074 | } 3075 | } 3076 | primitive("empty-buffers",forthemptybuffers) ; 3077 | describe("--",any) ; 3078 | 3079 | 3080 | 3081 | 3082 | 3083 | function forthblockstats() { 3084 | cr() ; type("checking blocks:") ; 3085 | var temp = capacity() 3086 | for (var i=0 ; i=0x20000000) { 3144 | throwerror(-69) ; 3145 | } else { 3146 | forthcreateheader() ; 3147 | vocname.push(wc) ; 3148 | t[wc] = dovocabulary ; 3149 | nextvocabulary <<= 1 ; 3150 | m[dp++] = nextvocabulary ; 3151 | forthreveal() ; 3152 | } 3153 | } 3154 | primitive("vocabulary",forthvocabulary) ; 3155 | describe(" --",any) ; 3156 | 3157 | 3158 | 3159 | 3160 | 3161 | 3162 | 3163 | 3164 | 3165 | function forthonly() { 3166 | for ( var i=vocstack.length ; i ; i--) vocstack.pop() ; 3167 | m[context] = only ; 3168 | vocstack.push(only) ; } 3169 | primitive("only",forthonly) ; 3170 | describe("--",any) ; 3171 | vocname.push(wc) ; 3172 | 3173 | 3174 | 3175 | function forthforth() { m[context] = forth ; } 3176 | primitive("forth",forthforth) ; 3177 | describe("--",any|only) ; 3178 | vocname.push(wc) ; 3179 | 3180 | 3181 | 3182 | function forthhidden() { m[context] = hidden ; } 3183 | primitive("hidden",forthhidden) ; 3184 | describe("--",jsf|f83|ans) ; 3185 | vocname.push(wc) ; 3186 | 3187 | 3188 | 3189 | 3190 | function forthteststuff() { m[context] = teststuff ; } 3191 | primitive("teststuff",forthteststuff) ; 3192 | describe("--",jsf) ; 3193 | vocname.push(wc) ; 3194 | 3195 | 3196 | 3197 | 3198 | 3199 | function forthdefinitions() { m[current] = m[context] ; } 3200 | primitive("definitions",forthdefinitions) ; 3201 | describe("--",any) ; 3202 | 3203 | 3204 | 3205 | 3206 | function forthorder() { 3207 | printvocname(m[context]) ; 3208 | for (var i=vocstack.length ; i ; i--) printvocname(vocstack[i-1]) ; 3209 | type(" ") ; printvocname(m[current]) ; 3210 | } 3211 | primitive("order",forthorder) ; 3212 | describe("--",ans|jsf|only) ; 3213 | 3214 | 3215 | function forthalso() { vocstack.push(m[context]) ; } 3216 | primitive("also",forthalso) ; 3217 | describe("--",ans|jsf) ; 3218 | 3219 | 3220 | function forthprevious() { m[context] = vocstack.pop() ; } 3221 | primitive("previous",forthprevious) ; 3222 | describe("--",ans|jsf) ; 3223 | 3224 | 3225 | 3226 | function forthvocs() { for (i=vocname.length ; i ; type(h[vocname[--i]] + " ")) ; } 3227 | primitive("vocs",forthvocs) ; 3228 | describe("--",fig|f79|f83|jsf) ; 3229 | 3230 | 3231 | 3232 | 3233 | // ================================================================================================= 3234 | // floating point 3235 | // ================================================================================================= 3236 | 3237 | 3238 | definitions(teststuff) ; 3239 | // fconstants, testing 3240 | function forth1point5() { f.push(ftos) ; ftos=1.5 ; } ; primitive("1.5",forth1point5) ; 3241 | function forthmin1point5() { f.push(ftos) ; ftos=-1.5 ; } ; primitive("-1.5",forthmin1point5) ; 3242 | function forth2point8() { f.push(ftos) ; ftos=2.8 ; } ; primitive("2.8",forth2point8) ; 3243 | function forthmin2point8() { f.push(ftos) ; ftos=-2.8 ; } ; primitive("-2.8",forthmin2point8) ; 3244 | 3245 | 3246 | 3247 | definitions(forth) ; 3248 | function forthfdots() { // f.s 3249 | f.push(ftos) ; 3250 | for (var i=1 ; i < f.length ; type(f[i++] + " ")) ; 3251 | ftos = f.pop() ; 3252 | } 3253 | primitive("f.s",forthfdots) ; 3254 | describe("--",any) ; 3255 | 3256 | 3257 | 3258 | 3259 | function forthfdrop() { ftos = f.pop() ; } // fdrop 3260 | primitive("fdrop",forthfdrop) ; 3261 | describe("r --",any) ; 3262 | 3263 | 3264 | 3265 | function forthfdup() { f.push(ftos) ; } // fdup 3266 | primitive("fdup",forthfdup) ; 3267 | describe("r -- r r",any) ; 3268 | 3269 | 3270 | 3271 | function forthfswap() { // fswap 3272 | w = f.pop() ; 3273 | f.push(ftos) ; 3274 | ftos = w ; 3275 | } 3276 | primitive("fswap",forthfswap) ; 3277 | describe("r1 r2 -- r2 r1",any) ; 3278 | 3279 | 3280 | 3281 | function forthfover() { // fover 3282 | f.push(ftos) ; 3283 | ftos = f[f.length-2] ; 3284 | } 3285 | primitive("fover",forthfover) ; 3286 | describe("r1 r2 -- r1 r2 r1",any) ; 3287 | 3288 | 3289 | 3290 | function forthffetch() { // f@ 3291 | f.push(ftos) ; 3292 | ftos = (m[tos]) ; 3293 | tos = s[sp--] ; 3294 | } 3295 | primitive("f@",forthffetch) ; 3296 | describe("a -- r",any) ; 3297 | 3298 | 3299 | 3300 | function forthfstore() { // f! 3301 | m[tos] = ftos ; 3302 | ftos = f.pop() ; 3303 | tos = s[sp--] ; 3304 | } 3305 | primitive("f!",forthfstore) ; 3306 | describe("r a --",any) ; 3307 | 3308 | 3309 | 3310 | 3311 | 3312 | 3313 | function forthfequ() { // f= 3314 | s[++sp] = tos ; 3315 | tos = -(ftos == f.pop()) ; 3316 | } 3317 | primitive("f=",forthfequ) ; 3318 | describe("r1 r2 -- f",any) ; 3319 | 3320 | 3321 | 3322 | 3323 | function forthfnequ() { // f<> 3324 | s[++sp] = tos ; 3325 | tos = -(ftos != f.pop()) ; 3326 | } 3327 | primitive("f<>",forthfnequ) ; 3328 | describe("r1 r2 -- f",any) ; 3329 | 3330 | 3331 | 3332 | function forthfmore() { // f> 3333 | s[++sp] = tos ; 3334 | tos = -(f.pop() > ftos) ; 3335 | } 3336 | primitive("f>",forthfmore) ; 3337 | describe("r1 r2 -- f",any) ; 3338 | 3339 | 3340 | 3341 | function forthfless() { // f< 3342 | s[++sp] = tos ; 3343 | tos = -(f.pop() < ftos) ; 3344 | } 3345 | primitive("f<",forthfless) ; 3346 | describe("r1 r2 -- f",any) ; 3347 | 3348 | 3349 | 3350 | function forthf0equ() { // f0= 3351 | s[++sp] = tos ; 3352 | tos = -(ftos == 0) ; 3353 | ftos = f.pop() ; 3354 | } 3355 | primitive("f0=",forthf0equ) ; 3356 | describe("r -- f",any) ; 3357 | 3358 | 3359 | 3360 | function forthf0nequ() { // f0<> 3361 | s[++sp] = tos ; 3362 | tos = -(ftos != 0) ; 3363 | ftos = f.pop() ; 3364 | } 3365 | primitive("f0<>",forthf0nequ) ; 3366 | describe("r -- f",any) ; 3367 | 3368 | 3369 | 3370 | function forthf0less() { // f0< 3371 | s[++sp] = tos ; 3372 | tos = -(ftos < 0) ; 3373 | ftos = f.pop() ; 3374 | } 3375 | primitive("f0<",forthf0less) ; 3376 | describe("r -- f",any) ; 3377 | 3378 | 3379 | 3380 | function forthf0greater() { // f0> 3381 | s[++sp] = tos ; 3382 | tos = -(ftos > 0) ; 3383 | ftos = f.pop() ; 3384 | } 3385 | primitive("f0>",forthf0greater) ; 3386 | describe("r -- f",any) ; 3387 | 3388 | 3389 | 3390 | function forthfnegate() { // fnegate 3391 | ftos = -ftos ; 3392 | } 3393 | primitive("fnegate",forthfnegate) ; 3394 | describe("r1 -- r2",any) ; 3395 | 3396 | 3397 | 3398 | function forthfabs() { // fabs 3399 | ftos = Math.abs(ftos) ; 3400 | } 3401 | primitive("fabs",forthfabs) ; 3402 | describe("r1 -- r2",any) 3403 | 3404 | 3405 | 3406 | function forthfround() { // fround 3407 | ftos = Math.round(ftos) ; 3408 | } 3409 | primitive("fround",forthfround) ; 3410 | describe("r1 -- r2",any) 3411 | 3412 | 3413 | 3414 | 3415 | 3416 | function forthfdepth() { // fdepth 3417 | s[sp++] = tos ; 3418 | tos = f.length ; 3419 | } 3420 | primitive("fdepth",forthfdepth) ; 3421 | describe(" -- u",any) 3422 | 3423 | 3424 | 3425 | function forthdtof() { // d>f 3426 | f.push(ftos) ; 3427 | ftos = tos * 0x100000000 + s[sp--] ; 3428 | tos = s[sp--] ; 3429 | } 3430 | primitive("d>f",forthdtof) ; 3431 | describe("d --",jsf|ans) ; 3432 | 3433 | 3434 | function forthftod() { // f>d 3435 | s[++sp] = tos ; 3436 | tos = ftos ; 3437 | ftos = f.pop() ; 3438 | s[++sp] = tos & 0xffffffff ; 3439 | tos = tos/0x100000000 3440 | if (tos<0) tos+=floorfix ; 3441 | tos = Math.floor(tos) ; 3442 | } 3443 | primitive("f>d",forthftod) ; 3444 | describe("r -- d",jsf|ans) ; 3445 | 3446 | 3447 | 3448 | function forthstof() { // s>f 3449 | f.push(ftos) ; 3450 | ftos = tos ; 3451 | tos = s[sp--] ; 3452 | } 3453 | primitive("s>f",forthstof) ; 3454 | describe("x --",jsf) ; 3455 | 3456 | 3457 | 3458 | function forthfplus() { // f+ 3459 | ftos += f.pop() ; 3460 | } 3461 | primitive("f+",forthfplus) ; 3462 | describe("r1 r2 -- r3",jsf|ans) ; 3463 | 3464 | 3465 | 3466 | function forthfminus() { // f- 3467 | ftos = f.pop()-ftos ; 3468 | } 3469 | primitive("f-",forthfminus) ; 3470 | describe("r1 r2 -- r3",jsf|ans) ; 3471 | 3472 | 3473 | 3474 | function forthfmul() { // f* 3475 | ftos *= f.pop() ; 3476 | } 3477 | primitive("f*",forthfmul) ; 3478 | describe("r1 r2 -- r3",jsf|ans) ; 3479 | 3480 | 3481 | function forthfdiv() { // f/ 3482 | var temp = f.pop() ; 3483 | ftos = temp/ftos ; 3484 | } 3485 | primitive("f/",forthfdiv) ; 3486 | describe("r1 r2 -- r3",jsf|ans) ; 3487 | 3488 | 3489 | 3490 | function forthfsin() { // fsin 3491 | ftos = Math.sin(ftos) ; 3492 | } 3493 | primitive("fsin",forthfsin) ; 3494 | describe("r1 -- r2",jsf|ans) ; 3495 | 3496 | 3497 | 3498 | function forthfcos() { // fcos 3499 | ftos = Math.cos(ftos) ; 3500 | } 3501 | primitive("fcos",forthfcos) ; 3502 | describe("r1 -- r2",jsf|ans) ; 3503 | 3504 | 3505 | 3506 | function forthftan() { // ftan 3507 | ftos = Math.tan(ftos) ; 3508 | } 3509 | primitive("ftan",forthftan) ; 3510 | describe("r1 -- r2",jsf|ans) ; 3511 | 3512 | 3513 | 3514 | 3515 | function forthfasin() { // fasin 3516 | ftos = Math.asin(ftos) ; 3517 | } 3518 | primitive("fasin",forthfasin) ; 3519 | describe("r1 -- r2",jsf|ans) ; 3520 | 3521 | 3522 | 3523 | 3524 | function forthfatan() { // fatan 3525 | ftos = Math.atan(ftos) ; 3526 | } 3527 | primitive("fatan",forthfatan) ; 3528 | describe("r1 -- r2",jsf|ans) ; 3529 | 3530 | 3531 | 3532 | function forthfatan2() { // fatan2 3533 | ftos = Math.atan2(f.pop(),ftos) ; 3534 | } 3535 | primitive("fatan2",forthfatan2) ; 3536 | describe("r1 r2 -- r3",jsf|ans) ; 3537 | 3538 | 3539 | 3540 | 3541 | function forthfacos() { // facos 3542 | ftos = Math.acos(ftos) ; 3543 | } 3544 | primitive("facos",forthfacos) ; 3545 | describe("r1 -- r2",jsf|ans) ; 3546 | 3547 | 3548 | 3549 | 3550 | function forthfpower() { // f** 3551 | ftos = Math.pow(f.pop(),ftos) ; 3552 | } 3553 | primitive("f**",forthfpower) ; 3554 | describe("r1 r2 -- r3",jsf|ans) ; 3555 | 3556 | 3557 | 3558 | function forthfln() { // fln 3559 | ftos = Math.log(ftos) ; 3560 | } 3561 | primitive("fln",forthfln) ; 3562 | describe("r1 -- r2",jsf|ans) ; 3563 | 3564 | 3565 | 3566 | 3567 | // function forthflog() { // flog 3568 | // ftos = Math.log(10,ftos) ; 3569 | // } 3570 | // primitive("flog",forthflog) ; 3571 | // describe("r1 -- r2",jsf|ans) ; 3572 | 3573 | 3574 | 3575 | // (Math.log) : e based 3576 | 3577 | 3578 | 3579 | function forthfalog() { // falog 3580 | ftos = Math.pow(10,ftos) ; 3581 | } 3582 | primitive("falog",forthfalog) ; 3583 | describe("r1 -- r2",jsf|ans) ; 3584 | 3585 | 3586 | 3587 | 3588 | 3589 | 3590 | function forthfsqrt() { // fsqrt 3591 | ftos = Math.sqrt(ftos) ; 3592 | } 3593 | primitive("fsqrt",forthfsqrt) ; 3594 | describe("r1 -- r2",jsf|ans) ; 3595 | 3596 | 3597 | 3598 | 3599 | function forthfmin() { // fmin 3600 | ftos = Math.min(ftos,f.pop()) ; 3601 | } 3602 | primitive("fmin",forthfmin) ; 3603 | describe("r1 r2 -- r3",jsf|ans) ; 3604 | 3605 | 3606 | 3607 | function forthfmax() { // fmax 3608 | ftos = Math.max(ftos,f.pop()) ; 3609 | } 3610 | primitive("fmax",forthfmax) ; 3611 | describe("r1 r2 -- r3",jsf|ans) ; 3612 | 3613 | 3614 | 3615 | 3616 | function forthfdot() { // f. 3617 | type(ftos + " ") ; 3618 | ftos = f.pop() ; 3619 | } 3620 | primitive("f.",forthfdot) ; 3621 | describe("r --",jsf|ans) ; 3622 | 3623 | 3624 | function forthpi() { // pi 3625 | f.push(ftos) ; 3626 | ftos = Math.PI ; 3627 | } 3628 | primitive("pi",forthpi) ; 3629 | describe("-- r",jsf|ans) ; 3630 | 3631 | 3632 | 3633 | function forthreciproc() { // 1/F 3634 | ftos = 1/ftos ; 3635 | } 3636 | primitive("1/f",forthreciproc) ; 3637 | describe("r1 -- r2",jsf|ans) ; 3638 | 3639 | 3640 | 3641 | 3642 | function forthfcomma() { m[dp++] = ftos ; ftos = f.pop() ; } // f, 3643 | var x_fcomma = primitive("f,",forthfcomma) ; 3644 | describe("r --",any) ; 3645 | 3646 | 3647 | primitive("falign",noop,immediate) // falign 3648 | describe("--",ans) ; 3649 | 3650 | primitive("faligned",noop,immediate) // faligned 3651 | describe("--",ans) ; 3652 | 3653 | 3654 | 3655 | 3656 | 3657 | // ================================================================================================= 3658 | // heap 3659 | // ================================================================================================= 3660 | 3661 | 3662 | var nusedchunks = 0 ; 3663 | var nfreechunks = 0 ; 3664 | 3665 | 3666 | 3667 | // return data address of chunk 3668 | function newchunk(size) { 3669 | m[heapend++] = nusedchunks ; 3670 | m[heapend++] = size ; 3671 | usedchunk[nusedchunks++] = heapend ; 3672 | var temp = heapend ; 3673 | heapend += tos ; 3674 | return temp ; 3675 | } 3676 | 3677 | 3678 | 3679 | // return data address of chunk 3680 | function splitchunk(fit,newsize) { 3681 | var chunkaddr = freechunk[fit] ; 3682 | var chunksizeleft = m[chunkaddr-1] - (newsize+2) ; 3683 | if ((chunksizeleft) > 0) { // split chunk into two: 3684 | m[chunkaddr-1] = chunksizeleft++ ; // new size old chunk 3685 | chunkaddr += chunksizeleft ; // new addr new chunk 3686 | m[chunkaddr++] = newsize ; // new size new chunk 3687 | } else { // use chunk completely: 3688 | freechunk[fit] = freechunk[--nfreechunks] ; // last chunk takes place of used chunk 3689 | freechunk.pop() ; // shorten array of freed chunks 3690 | } 3691 | m[chunkaddr-2] = nusedchunks ; // index into usedchunks array to this chunk 3692 | usedchunk[nusedchunks++] = chunkaddr ; // move new chunk to usedchunks 3693 | return chunkaddr ; 3694 | } 3695 | 3696 | 3697 | 3698 | 3699 | function searchfit(size) { 3700 | var fit = -1 ; 3701 | if (nfreechunks) { 3702 | var temp = 0xffffffff ; // any chunk is better 3703 | for (var i=0 ; i 2 ) { 3707 | if (!fittype) return i ; 3708 | if ( slack < temp ) { 3709 | fit = i ; 3710 | temp = slack ; 3711 | } 3712 | } 3713 | } 3714 | } 3715 | return fit ; 3716 | } 3717 | 3718 | 3719 | 3720 | function forthallocate() { // ( u -- a 0 | err ) 3721 | var fit = searchfit(tos) ; 3722 | if (fit<0) { 3723 | s[++sp] = newchunk(tos) ; 3724 | } else { 3725 | s[++sp] = splitchunk(fit,tos) ; 3726 | } 3727 | tos = 0 ; 3728 | } 3729 | primitive("allocate",forthallocate) ; 3730 | describe("u -- a 0 | err",ans|jsf) ; 3731 | 3732 | 3733 | 3734 | 3735 | function forthfree() { // ( a -- 0 | err ) 3736 | var temp = Math.min(m[tos-2],nusedchunks-1) ; 3737 | var chunkaddr = usedchunk[temp] ; 3738 | if (chunkaddr != tos) { 3739 | throwerror(-72) ; 3740 | } else { 3741 | freechunk[nfreechunks++] = chunkaddr ; 3742 | nusedchunks-- ; 3743 | var lastchunk = usedchunk.pop() ; 3744 | if (temp < nusedchunks) { 3745 | m[lastchunk-2] = temp ; 3746 | usedchunk[temp] = lastchunk ; 3747 | } 3748 | } 3749 | freechunk.sort() 3750 | chunkaddr = freechunk[0] + m[freechunk[0]-1] + 2; 3751 | 3752 | // combining from end of memory towards lower addresses may be quicker . 3753 | for (temp = 1 ; temp < nfreechunks ; temp++) { 3754 | if (freechunk[temp] == chunkaddr) { // merge chunks 3755 | chunksize = m[freechunk[temp]-1] + 2 ; 3756 | m[freechunk[temp-1]-1] += chunksize ; 3757 | chunkaddr += chunksize ; 3758 | nfreechunks-- ; 3759 | for (var i=temp ; i words 3938 | function forthwordtype() { // ( xt1 -- xt2 ) 3939 | if (tos <= primitives) { 3940 | tos = 0 ; // primitive 3941 | } else { 3942 | tos = m[x[tos]] ; // other 3943 | } 3944 | } 3945 | primitive("wordtype",forthwordtype) ; 3946 | describe("xt1 -- xt2",jsf) ; 3947 | 3948 | 3949 | // returns source of a primitive 3950 | function forthdisassemble() { // ( xt a -- n ) 3951 | var temp = (x[s[sp--]]) + " " ; 3952 | tos = unpackstring(temp,tos) ; 3953 | } 3954 | primitive("disassemble",forthdisassemble) ; 3955 | describe("xt a -- n",jsf) ; 3956 | 3957 | definitions(forth) ; 3958 | 3959 | 3960 | 3961 | 3962 | // ----- info screen tools ----- 3963 | 3964 | 3965 | 3966 | 3967 | function infosall() { /* No-op. */ } ; primitive("all",infosall) ; 3968 | describe("--",jsf) ; 3969 | 3970 | function infostail() { /* No-op. */ } ; primitive("tail",infostail) ; 3971 | describe("--",jsf) ; 3972 | 3973 | 3974 | 3975 | function setinfoslines() { 3976 | infolines = tos ; 3977 | info("* buffer size set to " + tos + " lines.") ; 3978 | tos = s[sp--] ; 3979 | } 3980 | primitive("infolines",setinfoslines) ; 3981 | describe("u --",jsf) ; 3982 | 3983 | 3984 | 3985 | 3986 | // -------------------------------------- 3987 | 3988 | 3989 | 3990 | 3991 | function forthloadhelp() { // ( a n -- ) 3992 | var temp = "docs/jsforth.html" + "#" + pack(s[sp],tos); 3993 | window.frames['help'].window.location.replace(temp.toUpperCase()) ; 3994 | sp-- ; 3995 | tos = s[sp--] ; 3996 | } 3997 | var x_loadhelp = primitive("loadhelp",forthloadhelp) ; 3998 | 3999 | 4000 | 4001 | 4002 | 4003 | 4004 | 4005 | 4006 | // ================================================================================================= 4007 | // ================================================================================================= 4008 | // ================================================================================================= 4009 | // ================================================================================================= 4010 | // ================================================================================================= 4011 | // no more primitives below this point 4012 | // ================================================================================================= 4013 | // ================================================================================================= 4014 | // ================================================================================================= 4015 | // ================================================================================================= 4016 | // ================================================================================================= 4017 | 4018 | 4019 | var primitives = wc ; 4020 | 4021 | 4022 | 4023 | 4024 | 4025 | 4026 | 4027 | 4028 | 4029 | // ================================================================================================= 4030 | // builders for non-primitive words 4031 | // ================================================================================================= 4032 | 4033 | // could speed this up with proper linkage code in t[wc] 4034 | function constant(name,value) { 4035 | newheader(name,smudgebit) ; 4036 | comma(x_doconst) ; 4037 | comma(value) ; 4038 | t[wc] = nextconstant ; 4039 | return wc ; 4040 | } 4041 | 4042 | 4043 | function variable(name) { 4044 | newheader(name,smudgebit); 4045 | comma(x_dovar); 4046 | comma(0); 4047 | t[wc] = nextvariable ; 4048 | return wc; 4049 | } 4050 | 4051 | 4052 | 4053 | 4054 | function colon(name,flags) { 4055 | newheader(name,flags|smudgebit); 4056 | comma(x_nest); 4057 | t[wc] = nexthilevel ; 4058 | return wc; 4059 | } 4060 | 4061 | 4062 | function alias(name,flags) { 4063 | newheader(name,flags|smudgebit); 4064 | x[wc] = x[wc-1] ; 4065 | t[wc] = t[wc-1] ; 4066 | return wc; 4067 | } 4068 | 4069 | 4070 | function semicolon() { jscomma(x_unnest) } 4071 | 4072 | 4073 | 4074 | // ================================================================================================= 4075 | // control flow for using in this script 4076 | // ================================================================================================= 4077 | 4078 | 4079 | 4080 | function IF() { m[dp++] = x_0branch ; s[++sp] = tos ; tos = dp ; dp++ ; } 4081 | function ELSE() { m[dp++] = x_branch ; s[++sp] = dp ; dp++ ; m[tos] = dp-tos ; tos = s[sp--] ; } 4082 | function THEN() { m[tos] = dp-tos ; tos = s[sp--] ; } 4083 | function BEGIN() { s[++sp] = tos ; tos = dp ; } 4084 | function UNTIL() { m[dp++] = x_0branch ; m[dp] = tos-dp++ ; tos = s[sp--]; } 4085 | function WHILE() { IF() ; } 4086 | function REPEAT() { m[dp++] = x_branch ; m[dp] = s[sp--]-dp++ ; m[tos] = dp-tos ; tos = s[sp--]; } 4087 | function AGAIN() { m[dp++] = x_branch ; m[dp] = tos-dp++ ; tos = s[sp--]; } 4088 | function makeDO(xt) { m[dp++] = xt; s[++sp] = m[innerloop]; m[innerloop] = dp; s[++sp] = dp ; dp++ ; } 4089 | function DO() { makeDO(x_brdo) ; } 4090 | function QDO() { makeDO(x_brqdo) ; } 4091 | function LOOP() { m[dp++] = x_brloop; m[dp++] = s[sp]+2-dp; m[s[sp]] = dp-s[sp--]; m[innerloop] = s[sp--]; } 4092 | function LEAVE() { m[dp++] = x_brleave ; m[dp++] = m[innerloop] ; } 4093 | function QLEAVE() { m[dp++] = x_brqleave ; m[dp++] = m[innerloop] ; } 4094 | 4095 | 4096 | 4097 | 4098 | 4099 | 4100 | // ================================================================================================= 4101 | // forth-visible constants and variables 4102 | // ================================================================================================= 4103 | 4104 | 4105 | definitions(hidden) ; 4106 | var x_innerloop = constant("innerloop",innerloop) ; 4107 | var x_innercase = constant("innercase",innercase) ; 4108 | 4109 | 4110 | definitions(forth) ; 4111 | var x_minus1 = constant("-1",-1) ; describe("-- -1",jsf|foerthchen); 4112 | var x_0 = constant("0",0) ; describe("-- 0",any) ; 4113 | var x_1 = constant("1",1) ; describe("-- 1",any) ; 4114 | constant("cell",1) ; describe("-- u",ans|jsf) ; 4115 | var x_2 = constant("2",2) ; describe("-- 2",any) ; 4116 | var x_bl = constant("bl",bl); describe("-- c",any) ; 4117 | var x_esc = constant("esc",esc) ; describe("-- c",jsf) ; 4118 | constant("compliance",compliance) ; describe("-- a",jsf) ; 4119 | constant("true",-1) ; describe("-- -1",any) ; 4120 | constant("false",0) ; describe("-- 0",any) ; 4121 | constant("casesensitive",casesensitive) ; describe("-- a",jsf) ; 4122 | constant("warnings",warnings) ; describe("-- a",jsf) ; 4123 | constant("debugger",debugging) ; describe("-- a",jsf) ; 4124 | var x_xontext = constant("context",context) ; describe("-- a",jsf) ; 4125 | var x_current = constant("current",current) ; describe("-- a",jsf) ; 4126 | var x_blk = constant("blk",blk) ; describe("-- a",any) ; 4127 | var x_scr = constant("scr",scr) ; describe("-- a",any) ; 4128 | var x_lastxt = constant("last",lastxt) ; describe("-- a",jsf) ; 4129 | var x_base = constant("base",base) ; describe("-- a",any) ; 4130 | var x_tib = constant("tib",tib) ; describe("-- a",any) ; 4131 | var x_span = constant("span",span) ; describe("-- a",fig|f79|f83|ans) ; 4132 | var x_hashtib = constant("#tib",hashtib) ; describe("-- a","obsolete, variable containing #chars in tib",fig|f79|f83|ans) ; 4133 | var x_in = constant(">in",toin) ; describe("-- a",any) ; 4134 | var x_state = constant("state",state) ; describe("-- a",any) ; 4135 | constant("outfile",outfile) ; describe("-- a",jsf) ; 4136 | constant("fit",fittype) ; describe("-- a",jsf) ; 4137 | constant("c/l",64) ; describe("-- u",jsf) ; 4138 | constant("l/s",16) ; describe("-- u",jsf) ; 4139 | constant("c/s",1024) ; describe("-- u",jsf) ; 4140 | 4141 | 4142 | 4143 | var x_literal = colon("literal",immediate) ; 4144 | compile(x_lit,x_lit,x_comma,x_comma) ; 4145 | semicolon() ; 4146 | describe("x --",any) ; 4147 | 4148 | 4149 | 4150 | 4151 | // ================================================================================================= 4152 | // errors 4153 | // ================================================================================================= 4154 | 4155 | definitions(hidden) ; 4156 | var x_stackunderflow = colon("underflow") ; compile(x_lit,-4,x_throw) ; 4157 | var x_notfound = colon("notfound") ; compile(x_lit,-13,x_throw) ; 4158 | definitions(hidden) ; 4159 | 4160 | definitions(forth) ; 4161 | var x_abort = colon("abort") ; compile(x_lit,-1,x_throw) ; 4162 | describe("--",any) ; 4163 | 4164 | 4165 | 4166 | 4167 | 4168 | 4169 | 4170 | // ================================================================================================= 4171 | // compilation 4172 | // ================================================================================================= 4173 | 4174 | 4175 | var x_qcomp = colon("?comp") ; 4176 | compile(x_compiling,x_0equ) ; 4177 | IF() ; 4178 | compile(x_lit,-14,x_throw) ; 4179 | THEN() ; 4180 | semicolon() ; 4181 | describe("--",jsf) ; 4182 | 4183 | 4184 | var x_qexec = colon("?exec") ; 4185 | compile(x_compiling) ; 4186 | IF() ; 4187 | compile(x_lit,-64,x_throw) ; 4188 | THEN() ; 4189 | semicolon() ; 4190 | describe("--",jsf) ; 4191 | 4192 | 4193 | var x_compilecomma = colon("compile,",immediate) ; 4194 | compile(x_qcomp,x_comma) ; 4195 | semicolon() ; 4196 | describe("xt --",any) ; 4197 | 4198 | 4199 | 4200 | 4201 | 4202 | 4203 | 4204 | // ================================================================================================= 4205 | // strings 4206 | // ================================================================================================= 4207 | 4208 | 4209 | definitions(hidden) ; 4210 | 4211 | var x_commastr = colon(",$") ; 4212 | compile(x_here,x_over,x_1plus,x_allot,x_movestr); 4213 | semicolon() 4214 | describe("a n --",jsf) ; 4215 | 4216 | 4217 | definitions(forth) ; 4218 | 4219 | // # ( -- ) compile a string from input stream 4220 | var x_commaquote = colon(',"'); 4221 | compile(x_lit,34,x_parse,x_commastr); 4222 | semicolon(); 4223 | describe("--",jsf) ; 4224 | 4225 | 4226 | // # ( -- ) compile a string from input stream 4227 | var x_commatick = colon(",'"); 4228 | compile(x_lit,39,x_parse,x_commastr); 4229 | semicolon(); 4230 | describe("--",jsf) ; 4231 | 4232 | 4233 | function forthscan() { // ( a1 n2 c -- a2 n2 ) 4234 | var temp = s[sp--] ; 4235 | for ( ; temp ; temp--) { 4236 | if (m[s[sp]] == tos) break ; 4237 | s[sp]++ ; 4238 | } 4239 | tos = temp ; 4240 | } 4241 | primitive("scan",forthscan) ; 4242 | describe("a1 n2 c -- a2 n2",any) ; 4243 | 4244 | 4245 | 4246 | 4247 | function forthskip() { // ( a1 n2 c -- a2 n2 ) 4248 | var temp = s[sp--] ; 4249 | for ( ; temp ; temp--) { 4250 | if (m[s[sp]] != tos) break ; 4251 | s[sp]++ ; 4252 | } 4253 | tos = temp ; 4254 | } 4255 | primitive("skip",forthskip) ; 4256 | describe("a1 n2 c -- a2 n2",any) ; 4257 | 4258 | 4259 | 4260 | 4261 | definitions(hidden) ; 4262 | 4263 | var x_compilestringword = colon('string\",') ; 4264 | compile(x_qcomp,x_comma,x_commaquote) ; 4265 | semicolon() ; 4266 | 4267 | var x_compiletickstringword = colon("string',") ; 4268 | compile(x_qcomp,x_comma,x_commatick) ; 4269 | semicolon() ; 4270 | 4271 | 4272 | definitions(forth) ; 4273 | 4274 | var x_squote = colon('s"',immediate) ; 4275 | compile(x_lit,x_brsquote,x_compilestringword); 4276 | semicolon(); 4277 | describe("--",any) ; 4278 | 4279 | 4280 | 4281 | var x_cquote = colon('c"',immediate); 4282 | compile(x_lit,x_brcquote,x_compilestringword); 4283 | semicolon(); 4284 | describe("--",ans|jsf) ; 4285 | 4286 | 4287 | 4288 | var x_dotquote = colon('."',immediate); 4289 | compile(x_lit,x_brdotquote,x_compilestringword); 4290 | semicolon(); 4291 | describe("--",any|foerthchen) ; 4292 | 4293 | 4294 | 4295 | 4296 | 4297 | colon("s'",immediate) ; 4298 | compile(x_lit,x_brsquote,x_compiletickstringword); 4299 | semicolon(); 4300 | describe("--",any) ; 4301 | 4302 | 4303 | colon(".'",immediate); 4304 | compile(x_lit,x_brdotquote,x_compiletickstringword); 4305 | semicolon(); 4306 | describe("--",any|foerthchen) ; 4307 | 4308 | 4309 | var x_dumul = colon("du*") // ( ud1 u -- ud2 ) 4310 | compile(x_tuck,x_2tor,x_ummul,x_0,x_2rfrom,x_mul,x_dplus) 4311 | semicolon() ; 4312 | 4313 | 4314 | 4315 | colon(">number") ; 4316 | compile(x_2dup,x_plus,x_tor); 4317 | compile(x_0) ; 4318 | QDO() ; 4319 | compile(x_count,x_digit,x_dup,x_0less) ; 4320 | IF() ; 4321 | compile(x_drop,x_1minus) ; 4322 | LEAVE() ; 4323 | THEN() ; 4324 | compile(x_swap,x_tor,x_tor); 4325 | compile(x_base,x_fetch,x_dumul); 4326 | compile(x_rfrom,x_0,x_dplus); 4327 | compile(x_rfrom) ; 4328 | LOOP() ; 4329 | compile(x_rfrom,x_over,x_minus); 4330 | 4331 | semicolon() ; 4332 | describe("ud1 a1 u1 -- ud2 a2 u2",ans|jsf) 4333 | 4334 | 4335 | 4336 | 4337 | // function forthtonumber() { // ( ud1 a1 u1 -- ud2 a2 u2 ) 4338 | // var digit ; 4339 | // var radix = m[base] ; 4340 | // w = s[sp] ; 4341 | // for ( ; tos ; tos-- ) { 4342 | // digit = m[w] - 48 ; 4343 | // if ( digit > 16 ) digit -= 7 ; 4344 | // if ( digit > 36 ) digit -= 32 ; 4345 | // if ( (digit >= 0) && (digit < radix) ) { 4346 | 4347 | // s[sp-2] *= radix ; 4348 | // s[sp-2] += digit ; 4349 | 4350 | // w++ ; 4351 | // } else { 4352 | // s[sp] = w ; 4353 | // break ; 4354 | // } 4355 | // } 4356 | // } 4357 | // primitive(">number",forthtonumber) ; 4358 | // describe("d1 a1 n1 -- d2 a2 n2",ans|jsf) ; 4359 | 4360 | 4361 | 4362 | 4363 | 4364 | 4365 | 4366 | var x_abortquote = colon('abort"',immediate); 4367 | compile(x_lit,x_brabortquote,x_compilestringword); 4368 | semicolon(); 4369 | describe("--",any) ; 4370 | 4371 | 4372 | 4373 | 4374 | 4375 | 4376 | 4377 | // ================================================================================================= 4378 | // defining words 4379 | // ================================================================================================= 4380 | 4381 | 4382 | // ( a -- ) 4383 | var x_create = colon("create") ; compile(x_lit,x_dovar,x_use,x_reveal) ; semicolon() ; 4384 | describe("--",any) ; 4385 | 4386 | 4387 | var x_const = colon("constant") ; 4388 | compile(x_lit,x_doconst,x_use,x_comma,x_reveal) ; // which is left in here for the moment. doesn't hurt. 4389 | semicolon() ; 4390 | describe("x --",any) ; 4391 | 4392 | 4393 | colon("fconstant") ; compile(x_lit,x_dofconst,x_use,x_fcomma,x_reveal) ; semicolon() ; 4394 | describe("r -- ) ( -- r )",ans|jsf) ; 4395 | 4396 | 4397 | colon("value") ; compile(x_lit,x_dovalue,x_use,x_comma,x_reveal) ; semicolon() ; 4398 | describe("x --",ans|jsf) ; 4399 | 4400 | 4401 | colon("variable") ; compile(x_create,x_0,x_comma) ; semicolon() ; 4402 | describe("--",any) ; 4403 | 4404 | alias("fvariable") ; 4405 | describe("-- ) ( -- a",any) ; 4406 | 4407 | 4408 | colon(";",immediate) ; compile(x_lit,x_unnest,x_comma,x_bropen,x_reveal) ; semicolon() ; 4409 | describe("--",any|foerthchen) ; 4410 | 4411 | 4412 | colon(":") ; compile(x_lit,x_nest,x_use,x_brclose) ; semicolon() ; 4413 | describe(" --",any|foerthchen) ; 4414 | 4415 | 4416 | colon("does>",immediate) ; 4417 | compile(x_lit,x_setdoes,x_compilecomma) ; 4418 | compile(x_lit,x_unnest,x_compilecomma) ; 4419 | semicolon() ; 4420 | describe("--",any) ; 4421 | 4422 | 4423 | 4424 | 4425 | // ================================================================================================= 4426 | // i/o 4427 | // ================================================================================================= 4428 | 4429 | 4430 | var x_keyq = colon("key?") ; compile(x_key1query,x_key2query) ; semicolon() ; 4431 | describe("-- f",jsf) ; 4432 | 4433 | 4434 | colon("?terminal") ; compile(x_keyq) ; semicolon() ; 4435 | describe("-- f",fig|f79) ; 4436 | 4437 | 4438 | var x_key = colon("key") ; compile(x_key1,x_key2) ; semicolon() ; 4439 | describe("-- c",any) ; 4440 | 4441 | 4442 | 4443 | var x_word = colon("word") ; 4444 | compile(x_parse,x_here,x_movestr,x_here) ; 4445 | semicolon() ; 4446 | describe("c -- a",any|foerthchen) ; 4447 | 4448 | 4449 | 4450 | var x_accept = colon("accept") ; // ( a n1 -- n2 ) 4451 | compile(x_over,x_swap,x_1plus) ; 4452 | BEGIN() ; 4453 | compile(x_qdup) ; 4454 | WHILE() ; 4455 | compile(x_key,x_decode) ; 4456 | REPEAT() ; 4457 | compile(x_swap,x_minus) ; 4458 | semicolon() ; 4459 | describe("a n1 -- n2",ans|jsf) ; 4460 | 4461 | 4462 | 4463 | colon("expect") 4464 | compile(x_accept,x_span,x_store) ; 4465 | semicolon() ; 4466 | describe("a n --",fig|f79|f83|ans) ; 4467 | 4468 | 4469 | 4470 | 4471 | var x_query = colon("query") ; 4472 | compile(x_tib,x_dup,x_lit,tibsize,x_accept) ; 4473 | compile(x_dup,x_hashtib,x_store,x_storesource) ; 4474 | compile(x_in,x_off) ; 4475 | semicolon() ; 4476 | describe("--",any) ; 4477 | 4478 | 4479 | 4480 | var x_sbr = colon("s(") ; 4481 | compile(x_lit,41,x_parse) ; 4482 | semicolon() ; 4483 | describe("-- a n",jsf) ; 4484 | 4485 | 4486 | 4487 | colon(".(",immediate) ; 4488 | compile(x_sbr,x_type) ; 4489 | semicolon() ; 4490 | describe(" --",ans|jsf) ; 4491 | 4492 | 4493 | 4494 | var x_char = colon("char",immediate) ; // char 4495 | compile(x_bl,x_parse,x_drop,x_cfetch); 4496 | compile(x_compiling) ; 4497 | IF() ; 4498 | compile(x_literal) ; 4499 | THEN() ; 4500 | semicolon() ; 4501 | describe(" -- c",ans|jsf) ; 4502 | alias("[char]",immediate) ; // [char] 4503 | describe(" -- c",ans|jsf) ; 4504 | 4505 | 4506 | 4507 | colon("\\",immediate) ; 4508 | compile(x_0,x_parse,x_2drop) ; 4509 | semicolon() ; 4510 | describe(" --",any) ; 4511 | 4512 | 4513 | 4514 | colon("(",immediate) ; 4515 | compile(x_lit,41,x_parse,x_2drop) ; 4516 | semicolon() ; 4517 | describe(" --",any) ; 4518 | 4519 | 4520 | 4521 | colon("(s",immediate) ; 4522 | compile(x_lit,41,x_parse,x_mintrailing,x_storestackeffect) ; 4523 | semicolon() ; 4524 | describe(" --",any) ; 4525 | 4526 | 4527 | 4528 | var x_hash = colon("#") ; 4529 | compile(x_base,x_fetch,x_udslashmod,x_rot,x_lit,9,x_over,x_less) 4530 | IF() ; 4531 | compile(x_lit,39,x_plus) ; 4532 | THEN() ; 4533 | compile(x_lit,48,x_plus,x_hold) ; 4534 | semicolon() ; 4535 | describe("d1 -- d2",any) ; 4536 | 4537 | 4538 | 4539 | var x_hashs = colon("#s") ; 4540 | BEGIN() ; 4541 | compile(x_hash,x_2dup,x_or,x_0equ) 4542 | UNTIL() ; 4543 | semicolon() ; 4544 | describe("d1 -- d2",any) ; 4545 | 4546 | 4547 | 4548 | 4549 | 4550 | 4551 | var x_parenddot = colon("(d.)") ; 4552 | compile(x_dup,x_tor,x_dabs,x_lesshash,x_hashs,x_rfrom,x_sign,x_hashmore,x_type) ; 4553 | semicolon() ; 4554 | describe("d --",any) ; 4555 | 4556 | 4557 | 4558 | var x_ddot = colon("d.") ; // d. 4559 | compile(x_parenddot,x_space) ; 4560 | semicolon() ; 4561 | describe("d --",any) ; 4562 | 4563 | 4564 | 4565 | var x_ddotr = colon("d.r") ; // d.r 4566 | compile(x_tor) ; 4567 | compile(x_dup,x_tor,x_dabs,x_lesshash,x_hashs,x_rfrom,x_sign,x_hashmore) ; 4568 | compile(x_rfrom,x_2dup,x_more) ; 4569 | IF() ; 4570 | BEGIN() ; 4571 | compile(x_qdup) ; 4572 | WHILE() ; 4573 | compile(x_1minus,x_lit,42,x_emit) 4574 | REPEAT() ; 4575 | compile(x_2drop) ; 4576 | ELSE() ; 4577 | compile(x_over,x_minus,x_spaces,x_type) ; 4578 | THEN() ; 4579 | semicolon() ; 4580 | describe("d --",any) ; 4581 | 4582 | 4583 | 4584 | var x_udot = colon("u.") ; // u. 4585 | compile(x_0,x_ddot) ; 4586 | semicolon() ; 4587 | describe("u --",any) ; 4588 | 4589 | 4590 | 4591 | var x_dot = colon(".") ; // . 4592 | compile(x_stod,x_ddot) ; 4593 | semicolon() ; 4594 | describe("n --",any) ; 4595 | 4596 | 4597 | 4598 | colon("(.)") ; 4599 | compile(x_stod,x_parenddot) ; 4600 | semicolon() ; 4601 | describe("n --",foerthchen) ; 4602 | 4603 | 4604 | 4605 | 4606 | colon("u.r") ; // u.r ( u1 u2 -- ) 4607 | compile(x_0,x_swap,x_ddotr) ; 4608 | semicolon() ; 4609 | describe("u1 u2 --",any) ; 4610 | 4611 | 4612 | 4613 | var x_dotr = colon(".r") ; // .r ( n u -- ) 4614 | compile(x_tor,x_stod,x_rfrom,x_ddotr) ; 4615 | semicolon() ; 4616 | describe("n u --",any) ; 4617 | 4618 | 4619 | 4620 | 4621 | 4622 | 4623 | // ================================================================================================= 4624 | // flow control 4625 | // ================================================================================================= 4626 | 4627 | 4628 | 4629 | definitions(hidden) ; 4630 | 4631 | var x_structured = colon("structured") ; 4632 | compile(x_2dup,x_nequ) ; 4633 | IF() ; 4634 | compile(x_unstructured) 4635 | THEN() ; 4636 | compile(x_2drop) ; 4637 | semicolon() ; 4638 | 4639 | var x_resolve = colon("resolve") ; 4640 | compile(x_here,x_minus,x_comma) ; 4641 | semicolon() ; 4642 | 4643 | var x_resolveback = colon(" -- xt",ans|f83|jsf) ; 4895 | 4896 | 4897 | 4898 | colon("'") ; 4899 | compile(x_tick,x_tobody) ; 4900 | semicolon() ; 4901 | describe(" -- a",fig|f79) ; 4902 | 4903 | 4904 | 4905 | var x_brtick = colon("[']",immediate) ; 4906 | compile(x_tick,x_literal) ; 4907 | semicolon() ; 4908 | describe("-- a",any) ; 4909 | 4910 | 4911 | 4912 | colon("[compile]",immediate) ; 4913 | compile(x_tick,x_comma) ; 4914 | semicolon() ; 4915 | describe("--",any) ; 4916 | 4917 | 4918 | 4919 | colon("recurse",immediate) ; 4920 | compile(x_lastxt,x_fetch,x_comma) ; 4921 | semicolon() ; 4922 | describe("--",ans|f83|jsf) ; 4923 | 4924 | 4925 | 4926 | colon("to",immediate) 4927 | compile(x_tick,x_tobody,x_dup,x_1minus,x_fetch,x_lit,x_dovalue,x_nequ,x_lit,-67,x_and,x_throw) ; 4928 | compile(x_compiling) ; 4929 | IF() ; 4930 | compile(x_lit,x_brto,x_comma,x_comma) ; 4931 | ELSE() ; 4932 | compile(x_store) ; 4933 | THEN() ; 4934 | semicolon() ; 4935 | describe(" x --",ans|jsf) ; 4936 | 4937 | 4938 | 4939 | 4940 | 4941 | // ================================================================================================= 4942 | // interpreter 4943 | // ================================================================================================= 4944 | 4945 | 4946 | definitions(hidden); 4947 | 4948 | var x_interpret = colon("interpret") ; // ( -- ) 4949 | BEGIN() ; 4950 | compile(x_bl,x_parse,x_dup) ; 4951 | WHILE() ; 4952 | compile(x_2dup,x_search,x_qdup) ; 4953 | IF() ; 4954 | compile(x_nip,x_nip,x_dup,x_qimm) ; 4955 | IF() ; 4956 | compile(x_execute) ; 4957 | ELSE() ; 4958 | compile(x_compiling) ; 4959 | IF() ; 4960 | compile(x_comma) ; 4961 | ELSE() ; 4962 | compile(x_execute) ; 4963 | THEN() ; 4964 | THEN() ; 4965 | compile(x_depth,x_0less) ; 4966 | IF() ; 4967 | compile(x_stackunderflow) ; 4968 | THEN() ; 4969 | ELSE() ; 4970 | compile(x_interpretnumber,x_0equ) ; 4971 | IF() ; 4972 | compile(x_notfound); 4973 | THEN() ; 4974 | THEN() ; 4975 | REPEAT() ; 4976 | compile(x_2drop) ; 4977 | semicolon(); 4978 | describe("--",jsf) ; 4979 | 4980 | 4981 | 4982 | 4983 | 4984 | 4985 | definitions(forth) ; 4986 | 4987 | var x_evaluate = colon("evaluate") ; // ( a n -- ) 4988 | compile(x_pushsource) ; 4989 | compile(x_in,x_off) ; 4990 | compile(x_storesource); 4991 | compile(x_interpret) ; 4992 | compile(x_popsource) ; 4993 | semicolon() ; 4994 | describe("a n --",ans|jsf) ; 4995 | 4996 | 4997 | 4998 | 4999 | var x_load = colon("load") ; 5000 | compile(x_dup,x_blk,x_exchange,x_tor) ; 5001 | compile(x_block,x_lit,1024,x_evaluate) ; 5002 | compile(x_rfrom,x_dup,x_blk,x_store) ; 5003 | compile(x_dup,x_0less,x_0equ) 5004 | IF() ; 5005 | compile(x_dup,x_block,x_lit,1024,x_storesource) ; 5006 | THEN() ; 5007 | compile(x_drop) ; 5008 | semicolon() ; 5009 | describe("u --",any) 5010 | 5011 | 5012 | 5013 | 5014 | var x_screen = colon("screen") ; 5015 | compile(x_scr,x_fetch,x_block) ; 5016 | semicolon() ; 5017 | describe("-- a",jsf) ; 5018 | 5019 | 5020 | 5021 | var x_dotline = colon(".line") ; 5022 | compile(x_lit,64,x_mul,x_screen,x_plus,x_lit,64,x_mintrailing,x_type) ; 5023 | semicolon() ; 5024 | describe("u --",jsf) ; 5025 | 5026 | 5027 | 5028 | var x_plusload = colon("+load") ; 5029 | compile(x_blk,x_fetch,x_plus,x_load) ; 5030 | semicolon() ; 5031 | describe("u --",any) ; 5032 | 5033 | 5034 | 5035 | colon("thru") ; 5036 | compile(x_1plus,x_swap) ; 5037 | QDO() ; 5038 | compile(x_i,x_load) ; 5039 | LOOP(); 5040 | semicolon() ; 5041 | describe("u1 u2 --",any) ; 5042 | 5043 | 5044 | 5045 | colon("+thru") ; 5046 | compile(x_1plus,x_swap) ; 5047 | QDO() ; 5048 | compile(x_i,x_plusload) ; 5049 | LOOP(); 5050 | semicolon() ; 5051 | describe("u1 u2 --",any) ; 5052 | 5053 | 5054 | 5055 | var x_l = colon("l") ; 5056 | compile(x_lit,16,x_0) ; 5057 | DO() ; 5058 | compile(x_cr,x_i,x_2,x_dotr,x_lit,124,x_emit,x_i,x_dotline) ; 5059 | LOOP() ; 5060 | semicolon() ; 5061 | describe("--",jsf) ; 5062 | 5063 | 5064 | 5065 | colon("list") ; 5066 | compile(x_scr,x_store,x_l) ; 5067 | semicolon() ; 5068 | describe("u --",any) ; 5069 | 5070 | 5071 | 5072 | colon("blank") ; 5073 | compile(x_bl,x_fill) ; 5074 | semicolon() ; 5075 | describe("a u --",any) ; 5076 | 5077 | 5078 | 5079 | // ================================================================================================= 5080 | // utility 5081 | // ================================================================================================= 5082 | 5083 | 5084 | colon("help") ; 5085 | compile(x_bl,x_parse,x_loadhelp) ; 5086 | semicolon() ; 5087 | 5088 | 5089 | definitions(teststuff) ; 5090 | var x_x = colon("x") ; // execute rest of line as javscript 5091 | compile(x_0,x_parse,x_eval) ; 5092 | semicolon() ; 5093 | describe(" --",jsf) ; 5094 | 5095 | 5096 | var x_jsconsole = colon("") ; 5097 | BEGIN() ; 5098 | compile(x_cr,x_lit,62,x_emit,x_query,x_x) ; 5099 | AGAIN() ; 5100 | semicolon() ; 5101 | 5102 | 5103 | colon("js") ; // javascript console 5104 | BEGIN() ; 5105 | compile(x_lit,x_jsconsole,x_catch,x_drop) ; 5106 | AGAIN() ; 5107 | semicolon() ; 5108 | describe("--",jsf) ; 5109 | 5110 | 5111 | 5112 | 5113 | 5114 | 5115 | // ================================================================================================= 5116 | // interpreter entry points 5117 | // ================================================================================================= 5118 | 5119 | 5120 | definitions(forth) ; 5121 | var x_quit = colon("quit") ; 5122 | BEGIN() ; 5123 | compile(x_query,x_source,x_qdup) 5124 | IF() ; 5125 | compile(x_evaluate) ; 5126 | compile(x_0) ; 5127 | THEN() ; 5128 | compile(x_drop,x_prompt) ; 5129 | AGAIN() ; 5130 | describe("??? --",any) ; 5131 | semicolon() ; 5132 | 5133 | var x_warm = colon("warm") ; compile(x_warminit,x_quit) ; 5134 | describe("??? --",jsf) ; 5135 | 5136 | 5137 | definitions(hidden) ; 5138 | 5139 | var x_error = colon("error") ; 5140 | compile(x_throw) ; 5141 | describe("??? n --",jsf) ; 5142 | 5143 | definitions(forth) ; 5144 | 5145 | 5146 | var warm = dp ; comma(x_warm) ; // called with virtualmachine(warm) 5147 | var error = dp ; comma(x_error) ; // called from javascript onError 5148 | 5149 | 5150 | function virtualmachine(entrypoint) { 5151 | suspended = 0 ; 5152 | ip=entrypoint ; 5153 | do { 5154 | w=m[ip++] ; // read next xt from address list 5155 | t[w](); // execute 5156 | } while (!suspended) ; 5157 | } 5158 | 5159 | 5160 | // ================================================================================================= 5161 | // jsrepl helpers 5162 | // ================================================================================================= 5163 | 5164 | function _init() { 5165 | virtualmachine(warm); 5166 | } 5167 | 5168 | function _run(str) { 5169 | for (var i = 0; i < str.length; i++) { 5170 | var chr = str.charCodeAt(i); 5171 | inbuf.push(chr === 10 ? 13 : chr); 5172 | } 5173 | inbuf.push(carriagereturn); 5174 | virtualmachine(ip); 5175 | } 5176 | 5177 | function _stacktop(elementCount) { 5178 | // Must be called during execution. 5179 | var buffer = []; 5180 | s[++sp] = tos; 5181 | for (var i = 1; i < sp && i <= elementCount; i++) { 5182 | buffer.push(s[sp - i + 1].toString(m[base])); 5183 | } 5184 | sp-- ; 5185 | return buffer.reverse(); 5186 | } 5187 | 5188 | function _input(callback) { 5189 | // Nothing. 5190 | } 5191 | 5192 | definitions(forth) ; 5193 | function _finish() { 5194 | console.log('finished.'); 5195 | } 5196 | primitive("_finish", function() { _finish(); }) ; 5197 | describe("--", jsf); 5198 | 5199 | function _setPrint(fn) { 5200 | _print = fn; 5201 | } 5202 | 5203 | 5204 | module.exports = { 5205 | init: _init, 5206 | run: _run, 5207 | setPrint: _setPrint, 5208 | finish: _finish, 5209 | stacktop: _stacktop 5210 | }; 5211 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "HeartForth", 3 | "description": "An emoji dialect of Forth", 4 | "version": "0.0.1", 5 | "author": { 6 | "name": "Neil Kandalgaonkar", 7 | "email": "neilk@neilk.net", 8 | "url": "http://neilk.net/" 9 | }, 10 | "license": { 11 | "type": "MIT" 12 | }, 13 | "repository": { 14 | "type": "git", 15 | "url": "http://github.com/neilk/heartforth.git" 16 | }, 17 | "engines": { 18 | "node": "0.10.x", 19 | "npm": "1.1.x" 20 | }, 21 | "dependencies": { 22 | "emoji": "git://github.com/neilk/emoji.git#master", 23 | "lazy": "*", 24 | "prompt": "*", 25 | "word-wrap": "*" 26 | } 27 | } 28 | --------------------------------------------------------------------------------