buzzard2.des

1984-1993模糊 C 源代码竞赛.zip 非常的好,不过这是DOS格式,要用UE去打开.

  @			Get the value there--the address of the "next word"
  exit

		Now we're set.  ; should be an immediate word that pushes
		the address of exit onto the stack, then writes it out.
: ; immediate
  ' exit 		Get the address of exit
  ,			Compile it
  exit			And we should return

		Now let's test out ; by defining a useful word:
: drop 0 * + ;

		Since we have 'inc', we ought to make 'dec':
: dec dup @ 1 - swap ! ;

		Our next goal, now that we have ;, is to implement
		if-then.  To do this, we'll need to play fast and
		loose with the return stack, so let's make some
		words to save us some effort.

		First we want a word that pops off the top of the normal
		stack and pushes it on top of the return stack.  We'll
		call this 'tor', for TO-Return-stack.   It sounds easy,
		but when tor is running, there's an extra value on the
		return stack--tor's return address!  So we have to pop
		that off first...  We better just bite the bullet and
		code it out--but we can't really break it into smaller
		words, because that'll trash the return stack.
: tor
  r @ @			Get the value off the top of the return stack
  swap			Bring the value to be pushed to the top of stack
  r @ !			Write it over the current top of return stack
  r @ 1 + r !		Increment the return stack pointer--but can't use inc
  r @ !			Store our return address back on the return stack
;

		Next we want the opposite routine, which pops the top
		of the return stack, and puts it on the normal stack.
: fromr
  r @ @			Save old value
  r @ 1 - r !		Decrement pointer
  r @ @			Get value that we want off
  swap			Bring return address to top
  r @ !			Store it and return
;

		Now, if we have a routine that's recursing, and we
		want to be polite about the return stack, right before
		we recurse we can run { fromr drop } so the stack won't
		blow up.  This means, though, that the first time we
		enter this recursive routine, we blow our *real* return
		address--so when we're done, we'll return up two levels.
		To save a little, we make 'tail' mean { fromr drop };
		however, it's more complex since there's a new value on
		top of the return stack.
: tail fromr fromr drop tor ;

		Now, we want to do 'if'.  To do this, we need to convert
		values to boolean values.  The next few words set this
		up.	

		minus gives us unary negation.
: minus 0 swap - ;

		If top of stack is boolean, bnot gives us inverse
: bnot 1 swap - ;

		To compare two numbers, subtract and compare to 0.
: < - <0 ;

		logical turns the top of stack into either 0 or 1.
: logical
  dup			Get two copies of it
  0 <			1 if < 0, 0 otherwise
  swap minus		Swap number back up, and take negative
  0 <			1 if original was > 0, 0 otherwise
  +			Add them up--has to be 0 or 1!
;

		not returns 1 if top of stack is 0, and 0 otherwise
: not logical bnot ;

		We can test equality by subtracting and comparing to 0.
: = - not ;

		Just to show how you compute a branch:  Suppose you've
		compiled a call to branch, and immediately after it is
		an integer constant with the offset of how far to branch.
		To branch, we use the return stack to read the offset, and
		add that on to the top of the return stack, and return.
: branch
  r @			Address of top of return stack
  @			Our return address
  @			Value from there: the branch offset
  r @ @			Our return address again
  +			The address we want to execute at
  r @ !			Store it back onto the return stack
;

		For conditional branches, we want to branch by a certain
		amount if true, otherwise we want to skip over the branch
		offset constant--that is, branch by one.  Assuming that
		the top of the stack is the branch offset, and the second
		on the stack is 1 if we should branch, and 0 if not, the
		following computes the correct branch offset.
: computebranch 1 - * 1 + ;

		Branch if the value on top of the stack is 0.
: notbranch
  not
  r @ @ @		Get the branch offset
  computebranch		Adjust as necessary
  r @ @ +		Calculate the new address
  r @ !			Store it
;

		here is a standard FORTH word which returns a pointer to
		the current dictionary address--that is, the value of
		the dictionary pointer.
: here h @ ;

		We're ALL SET to compile if...else...then constructs!
		Here's what we do.  When we get 'if', we compile a call
		to notbranch, and then compile a dummy offset, because
		we don't know where the 'then' will be.  On the *stack*
		we leave the address where we compiled the dummy offset.
		'then' will calculate the offset and fill it in for us.
: if immediate
  ' notbranch ,		Compile notbranch
  here			Save the current dictionary address
  0 ,			Compile a dummy value
;

		then expects the address to fixup to be on the stack.
: then immediate
  dup			Make another copy of the address
  here			Find the current location, where to branch to
  swap -		Calculate the difference between them
  swap !		Bring the address to the top, and store it.
;

		Now that we can do if...then statements, we can do
		some parsing!  Let's introduce real FORTH comments.
		find-) will scan the input until it finds a ), and
		exit.
: find-)
  key			Read in a character
  ')' =			Compare it to close parentheses
  not if		If it's not equal
    tail find-)		repeat (popping R stack)
  then			Otherwise branch here and exit
;

: ( immediate
  find-)
;

( we should be able to do FORTH-style comments now )

( now that we've got comments, we can comment the rest of the code
  in a legitimate [self parsing] fashion.  Note that you can't
  nest parentheses... )

: else immediate
  ' branch ,		( compile a definite branch )
  here			( push the backpatching address )
  0 ,			( compile a dummy offset for branch )
  swap			( bring old backpatch address to top )
  dup here swap -	( calculate the offset from old address )
  swap !		( put the address on top and store it )
;

: over _x! _y! _y _x _y ;

: add
  _x!			( save the pointer in a temp variable )
  _x @			( get the value pointed to )
  +			( add the incremement from on top of the stack )
  _x !			( and save it )
;

: allot	h add ;

: maybebranch
  logical		( force the TOS to be 0 or 1 )
  r @ @ @		( load the branch offset )
  computebranch		( calculate the condition offset [either TOS or 1])
  r @ @ +		( add it to the return address )
  r @ !			( store it to our return address and return )
;

: mod _x! _y!		( get x then y off of stack )
  _y _y _x / _x *	( y - y / x * x )
  -
;

: printnum
  dup
  10 mod '0' +
  swap 10 / dup
  if
    printnum
    echo
  else
    drop
    echo
  then
;

: .
  dup 0 <
  if
    '-' echo minus
  then
  printnum
  'space' echo
;

: debugprint dup . cr ;

( the following routine takes a pointer to a string, and prints it,
  except for the trailing quote.  returns a pointer to the next word
  after the trailing quote )

: _print
  dup 1 +
  swap @
  dup '"' =
  if
    drop exit
  then
  echo
  tail _print
;

: print _print ;

  ( print the next thing from the instruction stream )
: immprint
  r @ @
  print
  r @ !
;

: find-"
  key dup ,
  '"' =
  if
    exit
  then
  tail find-"
;

: " immediate
  key drop
  ' immprint ,
  find-"
;

: do immediate
  ' swap ,		( compile 'swap' to swap the limit and start )
  ' tor ,		( compile to push the limit onto the return stack )
  ' tor ,		( compile to push the start on the return stack )
  here			( save this address so we can branch back to it )
;

: i r @ 1 - @ ;
: j r @ 3 - @ ;

: > swap < ;
: <= 1 + < ;
: >= swap <= ;

: inci 
  r @ 1 - 	( get the pointer to i )
  inc		( add one to it )
  r @ 1 - @ 	( find the value again )
  r @ 2 - @	( find the limit value )
  <=
  if
    r @ @ @ r @ @ + r @ ! exit		( branch )
  then
  fromr 1 +
  fromr drop
  fromr drop
  tor
;

: loop immediate ' inci @ here - , ;

: loopexit

  fromr drop		( pop off our return address )
  fromr drop		( pop off i )
  fromr drop		( pop off the limit of i )
;			( and return to the caller's caller routine )

: execute
  8 !
  ' exit 9 !
  8 tor
;

: :: ;          ( :: is going to be a word that does ':' at runtime )

: fix-:: immediate 3 ' :: ! ;
fix-::

        ( Override old definition of ':' with a new one that invokes ] )
: : immediate :: ] ;

: command
  here 5 !              ( store dict pointer in temp variable )
  _read                 ( compile a word )
                        ( if we get control back: )
  here 5 @
  = if
    tail command        ( we didn't compile anything )
  then
  here 1 - h !          ( decrement the dictionary pointer )
  here 5 @              ( get the original value )
  = if
    here @              ( get the word that was compiled )
    execute             ( and run it )
  else
    here @              ( else it was an integer constant, so push it )
    here 1 - h !        ( and decrement the dictionary pointer again )
  then
  tail command
;

: make-immediate        ( make a word just compiled immediate )
  here 1 -              ( back up a word in the dictionary )
  dup dup               ( save the pointer to here )
  h !                   ( store as the current dictionary pointer )
  @                     ( get the run-time code pointer )
  swap                  ( get the dict pointer again )
  1 -                   ( point to the compile-time code pointer )
  !                     ( write run-time code pointer on compile-time pointer )
;

: <build immediate
  make-immediate        ( make the word compiled so far immediate )
  ' :: ,                ( compile '::', so we read next word )
  2 ,                   ( compile 'pushint' )
  here 0 ,              ( write out a 0 but save address for does> )
  ' , ,                 ( compile a push that address onto dictionary )
;

: does> immediate
  ' command ,           ( jump back into command mode at runtime )
  here swap !           ( backpatch the build> to point to here )
  2 ,                   ( compile run-code primitive so we look like a word )
  ' fromr ,             ( compile fromr, which leaves var address on stack )
;


: _dump                 ( dump out the definition of a word, sort of )
  dup " (" . " , "
  dup @                 ( save the pointer and get the contents )
  dup ' exit
  = if
        " ;)" cr exit
  then
  . " ), "
  1 +
  tail _dump
;

: dump _dump ;

: # . cr ;
  
: var <build , does> ;
: constant <build , does> @ ;
: array <build allot does> + ;

: [ immediate command ;
: _welcome " Welcome to THIRD.
Ok.
" ;

: ; immediate ' exit , command exit

[

_welcome