third

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

: immediate _read @ ! - * / <0 exit echo key _pick

: debug immediate 1 5 ! exit

: r 1 exit

: ] r @ 1 - r ! _read ]

: _main immediate r @ 7 ! ]
_main


: _x 3 @ exit
: _y 4 @ exit
: _x! 3 ! exit
: _y! 4 ! exit


: swap _x! _y! _x _y exit

: + 0 swap - - exit

: dup _x! _x _x exit

: inc dup @ 1 + swap ! exit

: h 0 exit

: , h @ ! h inc exit


: ' r @ @ dup 1 + r @ ! @ exit

: ; immediate ' exit , exit


: drop 0 * + ;

: dec dup @ 1 - swap ! ;

: tor r @ @ swap r @ ! r @ 1 + r ! r @ ! ;

: fromr r @ @ r @ 1 - r ! r @ @ swap r @ ! ;

: tail fromr fromr drop tor ;

: minus 0 swap - ;

: bnot 1 swap - ;

: < - <0 ;

: logical dup 0 < swap minus 0 < + ;

: not logical bnot ;

: = - not ;

: branch r @ @ @ r @ @ + r @ ! ;

: computebranch 1 - * 1 + ;

: notbranch
  not
  r @ @ @
  computebranch
  r @ @ +
  r @ !
;

: here h @ ;

: if immediate ' notbranch , here 0 , ;

: then immediate dup here swap - swap ! ;

: ')' 0 ;

: _fix key drop key swap 2 + ! ;

: fix-')' immediate ' ')' _fix ;

fix-')' )

: find-) key ')' = not if tail find-) then ;

: ( immediate find-) ;

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

( this works as follows: ( is an immediate word, so it gets
  control during compilation.  Then it simply reads in characters
  until it sees a close parenthesis.  once it does, it exits.
  if not, it pops off the return stack--manual tail recursion. )

( now that we've got comments, we can comment the rest of the code! )

: 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 )
  -
;

: '\n' 0 ;
: '"' 0 ;
: '0' 0 ;
: 'space' 0 ;

: fix-'\n' immediate ' '\n' _fix ;
: fix-'"' immediate ' '"' _fix ;
: fix-'0' immediate ' '0' _fix ;
: fix-'space' immediate ' 'space' _fix ;

fix-'0' 0 fix-'space'  fix-'"' "
fix-'\n'


: cr '\n' echo exit

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

: .
  dup 0 <
  if
    45 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 )

: isprime
  dup 2 = if
    exit
  then
  dup 2 / 2		( loop from 2 to n/2 )
  do
    dup			( value we're checking if it's prime )
    i mod		( mod it by divisor )
    not if
      drop 0 loopexit	( exit from routine from inside loop )
    then
  loop 
;

: primes
  " The primes from "
  dup .
  "  to "
  over .
  "  are:"
  cr

  do
    i isprime 
    if
      i . 'space' echo
    then
  loop
  cr
;

: 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