go-first

Unnamed repository; edit this file 'description' to name the repository.
Log | Files | Refs | README | LICENSE

third (6553B)


      1 : debug immediate 1 5 ! exit
      2 
      3 : r 1 exit
      4 
      5 : ] r @ 1 - r ! _read ]
      6 
      7 : _main immediate r @ 7 ! ]
      8 _main
      9 
     10 
     11 : _x 3 @ exit
     12 : _y 4 @ exit
     13 : _x! 3 ! exit
     14 : _y! 4 ! exit
     15 
     16 
     17 : swap _x! _y! _x _y exit
     18 
     19 : + 0 swap - - exit
     20 
     21 : dup _x! _x _x exit
     22 
     23 : inc dup @ 1 + swap ! exit
     24 
     25 : h 0 exit
     26 
     27 : , h @ ! h inc exit
     28 
     29 
     30 : ' r @ @ dup 1 + r @ ! @ exit
     31 
     32 : ; immediate ' exit , exit
     33 
     34 
     35 : drop 0 * + ;
     36 
     37 : dec dup @ 1 - swap ! ;
     38 
     39 : tor r @ @ swap r @ ! r @ 1 + r ! r @ ! ;
     40 
     41 : fromr r @ @ r @ 1 - r ! r @ @ swap r @ ! ;
     42 
     43 : tail fromr fromr drop tor ;
     44 
     45 : minus 0 swap - ;
     46 
     47 : bnot 1 swap - ;
     48 
     49 : < - <0 ;
     50 
     51 : logical dup 0 < swap minus 0 < + ;
     52 
     53 : not logical bnot ;
     54 
     55 : = - not ;
     56 
     57 : branch r @ @ @ r @ @ + r @ ! ;
     58 
     59 : computebranch 1 - * 1 + ;
     60 
     61 : notbranch
     62   not
     63   r @ @ @
     64   computebranch
     65   r @ @ +
     66   r @ !
     67 ;
     68 
     69 : here h @ ;
     70 
     71 : if immediate ' notbranch , here 0 , ;
     72 
     73 : then immediate dup here swap - swap ! ;
     74 
     75 : ')' 0 ;
     76 
     77 : _fix key drop key swap 2 + ! ;
     78 
     79 : fix-')' immediate ' ')' _fix ;
     80 
     81 fix-')' )
     82 
     83 : find-) key ')' = not if tail find-) then ;
     84 
     85 : ( immediate find-) ;
     86 
     87 ( we should be able to do FORTH-style comments now )
     88 
     89 ( this works as follows: ( is an immediate word, so it gets
     90   control during compilation.  Then it simply reads in characters
     91   until it sees a close parenthesis.  once it does, it exits.
     92   if not, it pops off the return stack--manual tail recursion. )
     93 
     94 ( now that we've got comments, we can comment the rest of the code! )
     95 
     96 : else immediate
     97   ' branch ,		( compile a definite branch )
     98   here			( push the backpatching address )
     99   0 ,			( compile a dummy offset for branch )
    100   swap			( bring old backpatch address to top )
    101   dup here swap -	( calculate the offset from old address )
    102   swap !		( put the address on top and store it )
    103 ;
    104 
    105 : over _x! _y! _y _x _y ;
    106 
    107 : add
    108   _x!			( save the pointer in a temp variable )
    109   _x @			( get the value pointed to )
    110   +			( add the incremement from on top of the stack )
    111   _x !			( and save it )
    112 ;
    113 
    114 : allot	h add ;
    115 
    116 : maybebranch
    117   logical		( force the TOS to be 0 or 1 )
    118   r @ @ @		( load the branch offset )
    119   computebranch	( calculate the condition offset [either TOS or 1])
    120   r @ @ +		( add it to the return address )
    121   r @ !		( store it to our return address and return )
    122 ;
    123 
    124 : mod _x! _y!		( get x then y off of stack )
    125   _y
    126   _y _x / _x *		( y - y / x * x )
    127   -
    128 ;
    129 
    130 : '\n' 0 ;
    131 : '"' 0 ;
    132 : '0' 0 ;
    133 : 'space' 0 ;
    134 
    135 : fix-'\n' immediate ' '\n' _fix ;
    136 : fix-'"' immediate ' '"' _fix ;
    137 : fix-'0' immediate ' '0' _fix ;
    138 : fix-'space' immediate ' 'space' _fix ;
    139 
    140 fix-'0' 0 fix-'space'  fix-'"' "
    141 fix-'\n'
    142 
    143 
    144 : cr '\n' echo exit
    145 
    146 : printnum
    147   dup
    148   10 mod '0' +
    149   swap 10 / dup
    150   if
    151     printnum 0
    152   then
    153   drop echo
    154 ;
    155 
    156 : .
    157   dup 0 <
    158   if
    159     45 echo minus
    160   then
    161   printnum
    162   'space' echo
    163 ;
    164 
    165 
    166 : debugprint dup . cr ;
    167 
    168 ( the following routine takes a pointer to a string, and prints it,
    169   except for the trailing quote.  returns a pointer to the next word
    170   after the trailing quote )
    171 
    172 : _print
    173   dup 1 +
    174   swap @
    175   dup '"' =
    176   if
    177     drop exit
    178   then
    179   echo
    180   tail _print
    181 ;
    182 
    183 : print _print ;
    184 
    185   ( print the next thing from the instruction stream )
    186 : immprint
    187   r @ @
    188   print
    189   r @ !
    190 ;
    191 
    192 : find-"
    193   key dup ,
    194   '"' =
    195   if
    196     exit
    197   then
    198   tail find-"
    199 ;
    200 
    201 : " immediate
    202   key drop
    203   ' immprint ,
    204   find-"
    205 ;
    206 
    207 : do immediate
    208   ' swap ,		( compile 'swap' to swap the limit and start )
    209   ' tor ,		( compile to push the limit onto the return stack )
    210   ' tor ,		( compile to push the start on the return stack )
    211   here			( save this address so we can branch back to it )
    212 ;
    213 
    214 : i r @ 1 - @ ;
    215 : j r @ 3 - @ ;
    216 
    217 : > swap < ;
    218 : <= 1 + < ;
    219 : >= swap <= ;
    220 
    221 : inci 
    222   r @ 1 - 	( get the pointer to i )
    223   inc		( add one to it )
    224   r @ 1 - @ 	( find the value again )
    225   r @ 2 - @	( find the limit value )
    226   <
    227   if
    228     r @ @ @ r @ @ + r @ ! exit		( branch )
    229   then
    230   fromr 1 +
    231   fromr drop
    232   fromr drop
    233   tor
    234 ;
    235   	
    236 : loop immediate ' inci , here - , ;
    237 
    238 : loopexit
    239 
    240   fromr drop		( pop off our return address )
    241   fromr drop		( pop off i )
    242   fromr drop		( pop off the limit of i )
    243 ;			( and return to the caller's caller routine )
    244 
    245 : isprime
    246   dup 2 = if
    247     exit
    248   then
    249   dup 2 / 2		( loop from 2 to n/2 )
    250   do
    251     dup			( value we're checking if it's prime )
    252     i mod		( mod it by divisor )
    253     not if
    254       drop 0 loopexit	( exit from routine from inside loop )
    255     then
    256   loop 
    257 ;
    258 
    259 : primes
    260   " The primes from "
    261   dup .
    262   "  to "
    263   over .
    264   "  are:"
    265   cr
    266 
    267   do
    268     i isprime 
    269     if
    270       i . 'space' echo
    271     then
    272   loop
    273   cr
    274 ;
    275 
    276 : execute
    277   8 !
    278   ' exit 9 !
    279   8 tor
    280 ;
    281 
    282 : :: ;		( :: is going to be a word that does ':' at runtime )
    283 
    284 : fix-:: immediate 3 ' :: ! ;
    285 fix-::
    286 
    287 	( Override old definition of ':' with a new one that invokes ] )
    288 : : immediate :: ] ;
    289 
    290 : command
    291   here 5 !		( store dict pointer in temp variable )
    292   _read			( compile a word )
    293 			( if we get control back: )
    294   here 5 @
    295   = if
    296     tail command	( we didn't compile anything )
    297   then
    298   here 1 - h !		( decrement the dictionary pointer )
    299   here 5 @		( get the original value )
    300   = if
    301     here @		( get the word that was compiled )
    302     execute		( and run it )
    303   else
    304     here @		( else it was an integer constant, so push it )
    305     here 1 - h !	( and decrement the dictionary pointer again )
    306   then
    307   tail command
    308 ;
    309 
    310 : make-immediate	( make a word just compiled immediate )
    311   here 1 -		( back up a word in the dictionary )
    312   dup dup		( save the pointer to here )
    313   h !			( store as the current dictionary pointer )
    314   @			( get the run-time code pointer )
    315   swap			( get the dict pointer again )
    316   1 -			( point to the compile-time code pointer )
    317   !			( write run-time code pointer on compile-time pointer )
    318 ;
    319 
    320 : <build immediate
    321   make-immediate	( make the word compiled so far immediate )
    322   ' :: ,		( compile '::', so we read next word )
    323   2 ,			( compile 'pushint' )
    324   here 0 ,		( write out a 0 but save address for does> )
    325   ' , ,			( compile a push that address onto dictionary )
    326 ;
    327 
    328 : does> immediate
    329   ' command ,		( jump back into command mode at runtime )
    330   here swap !		( backpatch the build> to point to here )
    331   2 ,			( compile run-code primitive so we look like a word )
    332   ' fromr ,		( compile fromr, which leaves var address on stack )
    333 ;
    334 
    335 
    336 : _dump			( dump out the definition of a word, sort of )
    337   dup " (" . " , "
    338   dup @			( save the pointer and get the contents )
    339   dup ' exit
    340   = if
    341 	" ;)" cr exit
    342   then
    343   . " ), "
    344   1 +
    345   tail _dump
    346 ;
    347 
    348 : dump _dump ;
    349 
    350 : # . cr ;
    351   
    352 : var <build , does> ;
    353 : constant <build , does> @ ;
    354 : array <build allot does> + ;
    355 
    356 : [ immediate command ;
    357 : _welcome " Welcome to THIRD.
    358 Ok.
    359 " ;
    360 
    361 : ; immediate ' exit , command exit
    362 
    363 [
    364 
    365 _welcome