muforth/startup.mu4

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