|
new : <:> -] new <:> -] ^ [ : definitions current ! ^ [ : forth .forth. definitions ^ [ : compiler .compiler. definitions ^ [ : literal (lit) (lit) compile, compile, ^ [ : ] literal -] ^ [ compiler : ; [ token ^ .forth. find huh? ] compile, [ token [ .compiler. find huh? compile, -] ^ [ forth : char token drop c@ ; : color=gray>( [ char ) ] parse 2drop ; ( Phew! now we can have comments!) ( This file is part of muFORTH: http://pages.nimblemachines.com/muforth Copyright 2002-2008 David Frech. All rights reserved, and all wrongs reversed. (See the file COPYRIGHT for details.) ( This file is muforth/startup.mu4. It contains high-level Forth code necessary to the useful execution of Forth. This file is loaded and interpreted when Forth starts up. The idea is to move as much code as possible -out- of the Forth kernel. Hence the name: "mu" is the Greek letter often used in engineering to represent "micro". I had called it "nu" Forth, because it was new, but I like this nu Greek letter better.) ( This file exemplifies a Forth strength - shared by Lisp and Smalltalk, among other interpretive/compiled languages - that I like to call "writing the reader"; the reader being, in this case, the Forth interpreter/compiler. As defined in the kernel, the interpreter/compiler is very simple; it only knows how to do the following things: 1. create a new colon word, making a dictionary entry for it; 2. compile a "call" to an already-defined word [Forth lingo for "named piece of code"], by appending its execution address to the end of the colon word we are compiling. That's it! In this file, in Forth, we need to extend the interpreter/compiler to do the following: 1. compile control structures: if/then, for/next, begin/while/repeat; 2. compile data structures: variables, constants, create/does words; 3. read and write numbers - an interesting exercise since muforth starts life not even knowing the constants 0 or 1; 4. read and write strings. Once these are complete we will have a useful Forth for doing real work. The order of business will sometimes seem haphazard; words can only be defined after the words they depend on have been defined, so we end up jumping around a bit in the "semantics" of the language. Hopefully the reader will find this an interesting exercise in bootstrapping, which was precisely my intention. So, here goes; now we start extending the language, bit by bit.) ( !! NOTE !! Do -NOT- change this part of the file without thinking VERY hard first. Make changes below the line marked `Add changes below this line', otherwise it may be difficult to diagnose problems added by new code.) ( First, we need compiler versions of ( and char. Since we no longer hide words as they are being defined, we need to be careful about how we do this. So let's define some words that are useful for searching specific dictionary chains and compiling words from them.) ( Stack comment and word comment words. We redefine these to generate documentation.) : (s ( ; ( stack comment) : (w ( ; (w word comment) ( Roll tokenizing and searching into one.) : token' token rot find ; (s chain - a u F | body T) ( Compiling from specific chains. Note that `\' is an elaboration of the basic scheme of `\chain'. These words will be handy in the assembler and target compiler.) ( Tick) : chain' token' huh? ; : \chain chain' compile, ; ( 28-apr-2000. Do we ever -really- want to search anything other than .forth.?) : ' .forth. chain' ; ( : ' current @ chain' ; ( XXX) compiler ( XXX: should this and ' do the same thing?) ( : ['] .forth. chain' literal ;) : ['] ' literal ; ( XXX: is this useful? Here? Maybe in a target compiler...) : \f .forth. \chain ; : \c .compiler. \chain ; ( until we have \ ; we need this for "if") ( Ok, now we can define our compiler comment char, ( .) : color=gray>( \f ( ; : (s \f ( ; (w stack comment) : (w \f ( ; (w word comment) forth ( Some useful tidbits.) : - negate + ; : u+ (s a b c - a+c b) rot + swap ; ( "under-plus") : v+ (s x1 y1 x2 y2 - x1+x2 y1+y2) push u+ pop + ; ( add 2-vectors) ( We don't even have any constants yet! So we make the easiest one first...) : 0 [ dup dup xor ] ; : -1 [ 0 invert ] ; : 1 [ -1 negate ] ; : 2 [ 1 2* ] ; : 1+ 1 + ; ( these are common) : 1- -1 + ; : cells cell-shift << ; : cell/ cell-shift >> ; ( signed) : cell [ 1 cells ] ; : cell+ [ cell ] + ; : cell- [ cell negate ] + ; : bl [ 2 2* 2* 2* 2* ] ; ( space character) : tuck (s a b - b a b) swap over ; : @+ (s a - n a+) dup @ swap cell+ ; : !+ (s n a - a+) tuck ! cell+ ; : 2@ @+ @ swap ; ( cell at lower address to TOP) : 2! !+ ! ; : 2dup over over ; : 2swap rot push rot pop ; : 2push (s a b -> R: a b) pop -rot swap push push push ; ( NOTAIL) : 2pop (s R: a b -> a b) pop pop pop swap rot push ; ( NOTAIL) ( Compatibility.) : not 0= ; : = xor 0= ; : bic invert and ; : lshift << ; : rshift >> ; : urshift u>> ; : @execute @ execute ; (w jump allows jumping thru a table of addresses; you are responsible for making sure the index is within range!) : jump (s n max) cells pop + @execute ; ( Now `ctrl' and the compiler's "char" and "ctrl".) : ctrl char [ bl 2* ( 64) ] xor ; ( how you get ^? = 127.) compiler : char \f char literal ; : ctrl \f ctrl literal ; forth ( A nice way to do full-line comments with no trailing delimiter.) : color=gray>-- ctrl J parse 2drop ; ( throw away until a newline) compiler : color=gray>-- \f -- ; forth ( the old definition) -- : ctrl char [ bl 1- ( 31) ] and ; ( elliptical, but it works :-) ( Compiler nuts and bolts.) -- Do something like this: (of course, I can't compile the variable yet...) -- Could define it like this: -- : dp [ r @ ( ram) 0 , ] ; -- variable dp -- : code h dp ! ; ( switch to code space) -- : data r dp ! ; ( switch to data space) -- : here dp @ @ ; -- : allot aligned dp @ +! ; -- : , dp @ ! cell allot ; : here h @ ; ( h points to the first free byte in code space) : ram r @ ; ( r points to the first free byte in data space) : aligned [ cell 1- ] + [ cell negate ] and ; : allot aligned r +! ; ( keeps ram space cell-aligned) : , ram ! cell allot ; ( We'll define words to compile into code space once we have create/does.) ( Mark a branch source for later fixup.) : mark> (s - src) here 0 code, ; ( Resolve a forward or backward jump, from src to dest.) ( In ITC land, this is easy: just store dest at src.) : <resolve (s dest src) ! ; : resolve> ( src dest) swap <resolve ; ( Going back to fig-FORTH!) : compile pop dup cell+ push @ compile, ; compiler : =if (s - src) compile (=0branch) mark> ; : if (s - src) compile (0branch) mark> ; : then (s src) here resolve> ; : else (s src0 - src1) compile (branch) mark> swap \c then ; : begin (s - dest) here ; : =until (s dest -) \c =if <resolve ; : until (s dest -) \c if <resolve ; : again (s dest -) compile (branch) mark> <resolve ; : =while (s dest - src dest) \c =if swap ; : while (s dest - src dest) \c if swap ; : repeat (s src dest -) \c again \c then ; ( n for .. next goes n times; 2^wordsize if n=0 ) ( n ?for .. next then goes n times; 0 if n=0 ) : for (s - dest) compile push \c begin ; : ?for (s - src dest) compile (?for) mark> \c begin ; : next (s dest -) compile (next) mark> <resolve ; ( make \ more like ANS-Forth's POSTPONE) ( Now, the confusion happens because we need to write code _in this word_ that will compile the above code into _other_ words. How about that?) ( Read a token out of the input stream. If the token is on the compiler chain, postpone its execution until the word we're compiling executes. If the token is on the forth chain, postpone its compilation until the word that we're compiling executes. Got that? ;-) : \ .compiler. token' if compile, ^ then .forth. find huh? literal ['] compile, compile, ; forth ( To bracket comments in a flexible way. If you've bracketed some text using comment, changing "comment" to "uncomment" will interpret the bracketed text - the delimiter becomes a noop.) : color=gray>comment token begin 2dup token string= until 2drop ; : uncomment new <:> \ ^ ; ( create a noop word) ( Defining words are next. Right now we only `know' how to make `colon' definitions. We need some structural help first.) ( Some notes on the newer, smarter ] . I wanted to gain a little of the clarity that Chuck Moore's colorForth gains by getting rid of "[ <calculate something here> ] literal". He replaces the whole construct with colored words that are executed or compiled depending on their color, but with a little added twist: words that are executed [of "execute" color] create what I call a "pending literal" that will be compiled just _before_ the next word that is compiled [of "compile" color]. Even if we don't have color, we do still have [ and ] and can use them to achieve the same end. [ creates a pending literal and ] compiles it. How does it work? Simple. ] _always_ compiles a literal before restarting the colon compiler. To restart it _without_ compiling a literal, use -] .) ( 2002-mar-18. New and modern create/does. Everything changes dramatically with native compilation. Let's look at what we have.) ( 2006-mar-30. I removed the big comment about create/does>. It's all in the README now, and also all out of date, since it's about the native-code version of muforth.) ( 2006-apr-11. Revamped create & does again. This time I think I got it right. Since a word's data are not stored in the dict [code] space, we compile a pointer into the word's definition [in code space] instead. This is not new, but the way it happens, and the semantics of some of the related words - like constant and create - is new. The fundamental defining word for data is *constant*. create is defined in terms of it. Words that allocate space in "ram" compile a pointer to that ram space as their constant. constant creates the head and compiles a code word pointing to <does>, an empty ip [does] pointer, and the constant. It then calls does>, which immediately rewrites the empty ip to point to constant's null does> body.) ( "nameless" colon words.) : -: here <:> -] ; ( For comparison, the regular : compiler is defined thus: : : new <:> -] ; ) ( Quick dictionary structure words.) : link>name cell+ dup 1+ swap c@ ; : link>code link>name + aligned ; : code>does ( 'code - 'does) cell+ ; : code>body ( 'code - 'body) [ 2 cells ] + ; : does> pop latest link>code code>does ! ; ( Nameless versions? Don't speculate!) : constant new <does> 0 code, ( does ip) code, ( constant) does> ; : create ram constant ; : _buffer (s default cells) ?for dup , next then drop ; : buffer create aligned cell/ 0 swap _buffer ; : variable create 0 , ; : 2variable variable 0 , ; ( An array with every cell set to a default value:) : defarray (s default cells) create _buffer does> (s i - a) swap cells + ; ( self-indexing!) : array (s cells) 0 swap defarray ; ( I guess we can have deferred words, even though they are, in some ways, inelegant. The alternative - creating a variable and a colon word that calls through that variable, for _every_ deferred word - is also in some ways inelegant - and clumsy. Actually, the way we define this is exactly equivalent to what we would have to do with variables; the difference is that instead of two named objects - the variable and the colon word that calls thru it - we have one - the deferred word - and we need an extra mechanism to get to its value to change it. The main argument _against_ deferred words is that they aren't orthogonal w.r.t. _user_ variables. The way we are defining them here they are implemented using a global, system variable. On muforth, we don't care, because we don't _have_ user variables; but on a properly multithreaded target machine things are different. There we probably wouldn't implement deferred words at all, using instead the "<variable> @execute" idiom; or, indeed, we could have all deferred use _user_ variables instead of globals. But that's what the fuss is. That and that "vectoring" them isn't strictly postfix. And it requires architecture-specific code!) variable undeferred ' nope undeferred ! : defer create undeferred @ , does> @execute ; : >data code>body @ ; ( given code addr of does word, fetch its constant) : 'data ' >data ; ( test!!) undeferred @ 0 undeferred ! undeferred @ drop undeferred ! zzz ( Syntactic sugar - from Rod Crawford's 4ARM.) : now ' ; : is 'data ! ; ( as in `now host-interpret is interpret') compiler : ['data] 'data literal ; : now \f now literal ; : is \ ['data] \ ! ; forth ( Number input) variable dpl ( location of , or . ) variable radix : radixer constant does> radix ! ; 2 2* 2* dup 2* ( 16!) radixer hex dup ( 8!) radixer octal 2 + ( 10!) radixer decimal 2 radixer binary decimal ( On and off) : on -1 swap ! ; : off 0 swap ! ; ( Punctuation in numbers: sign, radix, decimal point, separators.) ( 2006-mar-26. Ok, so this *totally* sucks. The presence of these bits of punctuation can mask a word not being found in the dictionary. A bare /, for instance, with no digits to keep it company, is happily parsed as a number. The number? 0. Urgh.) : punct (s a u ch - a' u' matched) over if ( still chars to process) swap push over c@ xor if ( no match) pop 0 ^ then ( match) pop 1 -1 v+ -1 ^ then ( end of input) drop 0 ; : ?sign char - punct if -1 ^ then 0 ; ( I wanted to add Michael Pruemm's '0' as a hex specifier, but it's not as simple as adding it to this list. It will match a bare 0, which won't be matched as a number.) : ?radix ( char 0 punct if hex ^ then ) char " punct if hex ^ then char # punct if decimal ^ then char ' punct if octal ^ then char % punct if binary ^ then ; ( . resets dpl; others leave it unchanged; this means that embedding . in a number causes a double number to be pushed, and dpl set to the count of digits _after_ the _last_ . in the number.) : ?dot char . punct if dpl off ^ then char , punct if ^ then char - punct if ^ then char / punct if ^ then char : punct if ^ then char _ punct if ^ then complain ; ( This is scary. We need a bunch of literals for `digit?'.) : digit? (s ch - digit T | junk F) char 0 - [ 2 2* 2* 1+ ] ( 9) over u< if ( !decimal) [ 2 2* 2* 2* 1+ ] ( 17) - [ 2 1+ 2* 2* 2* 1+ ] ( 25) over u< if ( !hex, UPPERCASE) [ 2 2* 2* 2* 2* ] ( 32) - [ 2 1+ 2* 2* 2* 1+ ] ( 25) over u< if ( !hex, lowercase) ( junk) 0 ^ then then ( hex) [ 2 2* 1+ 2* ] ( 10) + then ( decimal) dup radix @ u< ; : @digit? (s a - a digit T | a junk F) dup c@ digit? ; : *digit (s u a digit - u*base+digit a) swap push ( a) swap ( dig u) radix @ * + pop dpl @ 0< 1+ dpl +! ; ( 2002-mar-23. I still don't like how number parsing works. It seems clumsy. On the one hand, we know ahead of time exactly how many characters we have [in the token we are trying to convert]; on the other, the way the prefix [sign and radix] and embedded [. , - : /] characters work, we can't simply put them in a loop: there should be at most one sign and one radix at the beginning. Right now I have >number [which converts digits] and punct words _both_ checking if there are any characters left to process. This seems clumsy. And that "dpl!" in ?dot bugs me, too.) ( ANS compatible! - or at least it was when it converting with double numbers.) : >number (s u1 a1 c1 - u2 a2 c2) ( a2 is first unconvertible char) =if for @digit? while *digit 1+ next 0 ^ then drop pop then ; ( If >number can't convert any digits, complain.) : digits (s u1 a1 c1 - u2 a2 c2 u3) dup push ( chars left) >number pop over - ( count of digits converted) 0= if complain then ; : fancy-number (s a u - n) ( was -: ) 2push 0 2pop ?sign push ?radix dpl on begin digits =while ( still chars) ?dot repeat 2drop pop if negate then ; ( Now some help for the colon compiler. Note that the colon compiler now calls `number,' to convert-and-compile and calls `number' when interpreting. This is so that `number,' or `number' can reset dpl when they're done. We do this so that constants don't screw up fixed-point arithmetic conversion. Without this code, if you were to use a fixed-point number, 3.1415 eg, dpl would be set to 4. Then `0' pushes 0 on the stack but doesn't affect dpl, so Forth tries to convert it, and BOOM.) : number (s a u - n) radix @ push ['] fancy-number catch pop radix ! throw ; ( always reset the radix, even in case of error) ( Ok, folks, now that we have number parsing code we can redefine the interpreter and compiler, which up till this point have simply complained if they saw something not in the dictionary.) ( Ready for our new & improved interpreter and compiler? Here we go!) ( XXX: Is this the right way to do this? Truly, while it's "nice" to have the new interpreters written in - and running in! - true Forth, the only parts that have changed from the C version are the bits after the last "then": number [in interpreter], and "number literal" [in compiler].) ( To set the compiler consumer, we need a sneaky word to get the value of state while compiling - we use the same trick later to set the compiler prompt.) compiler : 'compiler-consume state @ ; forth ( Redefine, and then set the forth "consume".) -: ( interpret one token) .forth. find if execute ^ then number ; state @ ! ( Now set the compiler "consumer". To get access to the value of state at compile time, we turn on the compiler, but don't compile anything!) -: ( compile one token) .compiler. find if execute ^ then .forth. find if compile, ^ then number literal ; -] 'compiler-consume [ ! ( Basic character i/o.) 1024 constant #inbuf #inbuf buffer inbuf ( terminal input) variable keybuf variable emitbuf variable fd-in variable fd-out : writes fd-out ! ; : reads fd-in ! ; : <stdin 0 reads ; : >stdout 1 writes ; <stdin >stdout ( sanity) : >stderr 2 writes ; : <key (s fd - ch) keybuf 1 read drop keybuf c@ ; : >emit (s ch fd) swap emitbuf c! emitbuf 1 write ; : key (s - ch) fd-in @ <key ; : emit (s ch) fd-out @ >emit ; : space bl emit ; : cr ctrl J emit ; : type fd-out @ -rot write ; : accept (s a # - #in) fd-in @ -rot read ( 1-) ; ( ANS) ( chop trailing newline) : typing (s - a #) inbuf dup [ #inbuf 2 - ] accept ; ( get a line of input) ( WARNING: this is different from what the CPU would do; it ignores OVERFLOW, unlike the CPU's signed comparisons. <' is useful for `modulo' less than -- it compare two numbers in the same half of the number space. Useful for 32-bit clock operations [with monotonically increasing time] and for TCP sequence numbers.) : <' - 0< ; ( This violates what is -required- by FORTH-83 standard) : > swap < ; : min 2dup > if swap then drop ; : max 2dup < if swap then drop ; ( Pictured numeric output.) : /digit (s u - uquot umod) radix @ u/mod swap ; : >digit (s n - ch) ( convert 1 binary digit to char; hex to uppercase) 9 over u< 7 and + char 0 + ; : abs (s n - |n|) dup 0< if negate then ; : spaces (s n) 0 max ?for space next then ; ( pad is where we convert numbers to ASCII. A number is 1 cell - could be 64 bits! - and in binary would take 64 characters to represent, plus a character for the sign. pad returns the address of the _end_ of the buffer, since conversion occurs right-to-left.) ( Let's make this more configurable.) variable 'pad : pad 'pad @ ; 65 allot ram 'pad ! ( 64 digits + sign + alignment) variable hld : hold -1 hld +! hld @ c! ; : <# pad hld ! ; : #> (s u - a #) drop hld @ pad over - ; : sign (s n -) 0< if char - hold then ; : # (s u - u') /digit >digit hold ; : #s (s u - 0) begin # dup 0= until ; : (u.) (s u - a #) <# #s #> ; : u. (s u -) (u.) type space ; : (.) (s n - a #) dup push ( sign) abs <# #s pop sign #> ; : . (s n -) (.) type space ; ( This should truncate to field length. Actually, it shouldn't. Does it?) : truncating-field (s a c field - a' field) tuck swap - ( a field field-c) dup 0< if drop ^ then ?for bl hold next then #> ; ( Non-truncating field.) : field (s a c field - a c) over - spaces ; : (.r) (s n field - a #) push (.) pop field ; : .r (.r) type ; : (u.r) (s u field - a #) push (u.) pop field ; : u.r (u.r) type ; ( Useful.) : ? @ . ; : bits/cell [ cell 8 * ] ; : rotate ( rotates _right_; without =if/then, rotates by 0 break on x86.) =if 2dup u>> push negate bits/cell + << pop xor ^ then drop ; ( : p ctrl J parse 2dup u. u. char | emit type char | emit ; XXX ) ( String primitives.) ( 2003-dec-31!! Compiled strings have a cell-sized count and are referenced by pointing to the first character rather than to the count. I have also got rid of c" and now z" is the only string operator that returns a counted string. The z reminds us that it is also a null-terminated string. 2002-mar-18. All strings are compiled into data space and referenced by creating a normal literal with the string's address. Strings can then be used in an error or abort routine, or whatever. This is nice and postfix. It also means that if we want to, for example, return the address of the first character of the string - rather than of the count cell; eg, for strings used by the C library - we can calculate that address _before_ making a literal. Again, this works because the string isn't compiled inline, so we don't need to jump over it. Things are _much_ simpler this way!) ( all compiled strings have a zero terminator.) : count (s z" - a u) dup cell- @ ; : _string scrabble count cell+ 1+ allot ; : string, (s ch - z") parse _string ; : token, (s - z") token _string ; : (.") count type ; ( no more jumping over strings at run-time!) ( Compiled strings.) compiler : z" (s - z") char " string, literal ; ( z means zero-terminated) : " (s - a c) \ z" \ count ; : ." \ z" \ (.") ; : error" \ z" \ throw ; ( compile a C-style string for throw'ing) ( Interpreted strings. Strings that return an address always get compiled!) forth : z" (s - z") char " string, ; : " (s - a c) \f z" count ; ( ANS) : ." char " parse ( a #) type ; ( not compiled) ( Words that do something with each word being defined.) : being-defined constant does> 'new-hook ! ; ( To warn of re-defining a word.) -: ( a u) 2dup current @ find if fd-out @ push >stderr drop 2dup type ." again. " pop writes ^ then 2drop ; being-defined -redef -redef ( A useful list of words as they're being defined.) -: ( a u) current @ ( chain) . here . 2dup type cr ; being-defined -v ( be verbose) -- -v ( You can only do one of these at a time! Is there an easy way to hook the hook?) ( Now that we have strings, let's make a more useful definition of undeferred, so that defer'ed words that never get set to anything will complain when used.) -: error" undefined deferred word" ; undeferred ! ( !!!!-------------------- Add changes below this line -------------------!!!!) ( Word listing. Putting this in as soon as possible. Needs `space'.) : words 0 current @ ( count link) begin @ =while 1 u+ dup link>name type space space repeat drop cr ." (" . ." words)" ; ( XXX: should be primitive?) : fill (s a u n) -rot ?for 2dup c! 1+ next then 2drop ; : cell-fill (s a u n) -rot ?for 2dup ! cell+ next then 2drop ; : erase (s a u) 0 fill ; ( easy, what?) : blank (s a u) bl fill ; ( Go forth and multiply ... and divide. As of r438 - 2006-mar-26 - there are no double-length numbers! Our new primitives are: * : n1 n2 - n3 [single-length product] /mod : n1 n2 - mod quot u/mod : u1 u2 - umod uquot Any word whose name starts with 'u' is unsigned, both in its arguments and its results; the others are signed. */ and */mod no longer calculate a double-length intermediate product, so beware!) : / (s n1 n2 - quot) /mod nip ; : u/ (s u1 u2 - uquot) u/mod nip ; : mod (s n1 n2 - mod) /mod drop ; : umod (s u1 u2 - umod) u/mod drop ; : */mod (s n1 n2 n3 - mod quot) push * pop /mod ; : */ (s n1 n2 n3 - n1*n2/n3) */mod nip ; ( Within.) : within (s n lo hi - lo <= n < hi) over - push - pop u< ; ( Character classifications - useful for ASCII dumps and keyboard input.) : letter? 32 127 within ; ( excludes ctrls & DEL) : graphic? dup 160 256 within if drop -1 ^ then letter? ; ( Useful stack dump.) : .s ( stack) depth s0 cell- swap ?for cell- dup @ . next then drop ; ( Conditional compilation) ( 30-aug-1998. Created.) ( 28-apr-1999. Added compiler word to create conditionals.) ( 27-apr-2000. Changed names to more standard [if] [else] [then] and added the capability of nesting them.) ( 4-aug-2000. Added [with] and moved all conditional constants into `conditional' vocab.) ( Compiler/interpreter modes.) : mode create (s prompt interpret) , , does> state ! ; ( Defining new dictionary chains. These used to be in an array but are now independent of each other; now they are simply variables that point to the last-defined word on the chain.) : chain variable ; chain .conditional. : conditional .conditional. definitions ; -: ." (inside a conditional)" ; -: .conditional. find if execute ^ then 2drop ; mode eat variable cond-nest variable cond-save-state : cond[ state @ cond-save-state ! cond-nest off ; : ]cond cond-save-state @ state ! ; compiler : [else] cond[ eat ; : [if] (s f) 0= if \ [else] then ; : [then] ; : [with] .forth. token' if drop -1 ^ then 2drop 0 ; conditional : [if] 1 cond-nest +! ; : [else] cond-nest @ 0= if ]cond then ; : [then] -1 cond-nest +! cond-nest @ 0< if ]cond then ; forth : [if] \ [if] ; : [else] \ [else] ; : [then] ; : [with] \ [with] ; ( A defining word that makes words that return -1) : trues -1 constant ; ( The defining word `with' for creating conditional compilation words. No matter what chain we are compiling into, define the word - using "trues" - in .forth.) : with current @ forth trues definitions ; ( Now, the main reason for doing this is to have `debug' and `eprom' versions. The best way is to load the file `debug' or `eprom'!) ( Two useful sets of units; these adhere to SI and IEC guidelines. ;-) : k 1000 * ; ( "kilo": 10^3.) : M k k ; ( "mega": 10^6.) : Ki 10 << ; ( "Kibi", or "kilobinary": 2^10.) : Mi Ki Ki ; ( "Mebi", or "megabinary": 2^20.) ( For loading, to see if we've left anything lying about.) variable csp ( what does this stand for? `check stack pointer'?) : !csp depth csp ! ; : ?csp depth csp @ - =if . ." stack depth change: " hex .s cr ^ then drop ; ( Bracket the contents of a file and check for stack depth change.) : file[ (s a u) >stderr cr ." (( " type >stdout !csp ; : ]file >stderr ." )) " >stdout ?csp ; ( For counting the size of a loaded file.) : file[# (s a u) file[ here ; : #]file here swap - decimal >stderr . ." bytes " ]file ; ( Time, timestamp.) : "hold (s a n) dup negate hld +! hld @ swap cmove ; : ## (s n) # # drop ; ( Separators) : ": char : hold ; : "- char - hold ; : ". char . hold ; : || bl hold ; ( a space) : month" (s n - a n) ( n is 0--11) 3 * z" janfebmaraprmayjunjulaugsepoctnovdec" + 3 ; ( clock returns a count of seconds since 1970-jan-01 00:00:00 UTC, the Unix "epoch".) ( leaves a 0 which is consumed by #>) : <date> (s year month mday yday - 0) drop ## "- month" "hold "- #s ( year) ; : <hh:mm:ss> (s hms) ## ": ## ": ## ; : <hh:mm> (s hms) drop ( sec) ## ": ## ; : (time") (s year month mday yday hour min sec 'zone #zone - a #) radix @ push decimal <# "hold ( zone) || <hh:mm:ss> || <date> #> pop radix ! ; : (short-time") ( year month mday yday hour min sec 'zone #zone - a #) radix @ push decimal <# 2drop ( zone) <hh:mm> || <date> #> pop radix ! ; : (date") (s year month mday yday hour min sec 'zone #zone - a #) radix @ push decimal <# 2drop 2drop drop <date> #> pop radix ! ; : date (s epoch - y m d yday) local-time 2drop 2drop drop ; : date" (s epoch - a n) local-time (date") ; : time" (s epoch - a n) local-time (time") ; : utc" (s epoch - a n) utc (time") ; ( Better primitives? More elegant, certainly.) : s->sm (s s - s m) 60 u/mod ; : s->smh (s s - s m h) s->sm s->sm ; : s->smhd (s s - s m h d) s->smh 24 u/mod ; : sm->s 60 * + ; : smh->s sm->s sm->s ; : smhd->s 24 * + smh->s ; ( If anyone had any idea how long a year really is, we could also define s->smhdy and smhdy->s. ;-) : smhq->s 6 * + smh->s ; ( sec min hr quarter-day) : smhdy->s [ 365 3 * 366 + ] * ( quarter-days/yr) push 4 * pop + smhq->s ; ( for command-line args) : ld token _string load-file ; : -f ( load file) ld ; : --file -f ; : -d ( define) trues ; : --define -d ; ( Link to project home page.) : info ." For more information about muFORTH, please visit" cr cr ( ### httplink ###; keep following line, blank or not!) ." http://pages.nimblemachines.com/muforth" cr cr ; ( Prompt, quit, and warm.) compiler : 'compiler-prompt state @ cell+ ; forth -: ." (compiling)" 'compiler-prompt ; ! ( bwa ha ha!) : .mode-prompt state @ cell+ @execute ; ( secondary prompt) : .Ok ." Ok" ; : prompt .Ok .mode-prompt ; ( ` Ok' then sub-prompt) defer canonical ( XXX: is this obsolete?) -: forth \ [ ; is canonical ( If we run out of input, typing will return a string of length zero; we now test for this condition and exit muFORTH. This makes it usable for batch mode operation.) : quit begin cr <stdin >stdout typing =while interpret >stderr prompt repeat bye [ ( infinite loop, until input exhausted or error... ) ( 2004-jun-26. error now expects a cell-length-prefixed compiled string.) : error parsed type space count type ( cr) ; : carefully catch =if error sp! ^ then drop ; ( Loads a file inside of a catch frame which exits on error.) : -F token _string ['] load-file catch =if error bye then drop ; ( Sometimes we want to interpret from stdin _while_ we're still reading command line arguments, and, like -F, punt and exit if anything throws and error. This word lets us do that.) ( XXX: what should it be called?) ( XXX: difference betw error and warning, so that, eg, "isn't defined" doesn't clear the stack.) : banner ( Print banner.) ." muFORTH/ITC " build-time ( seconds since epoch) time" type cr ." Copyright (c) 2002-2008 David Frech. All rights reserved." cr cr ." muFORTH is free software; see the file COPYRIGHT for details." cr ." To read more about muFORTH, type " char " emit ." info" char " emit ." ." cr ; : warm >stderr banner >stdout command-line count ['] interpret carefully begin canonical ['] quit carefully again [ ( Identify ourselves.) trues muFORTH |