home bbs files messages ]

Forums before death by AOL, social media and spammers... "We can't have nice things"

   comp.lang.forth      Forth programmers eat a lot of Bratwurst      117,927 messages   

[   << oldest   |   < older   |   list   |   newer >   |   newest >>   ]

   Message 117,861 of 117,927   
   Hans Bezemer to All   
   I'm not close, but it's fun!   
   30 Jan 26 16:57:26   
   
   From: the.beez.speaks@gmail.com   
      
   Although I'm not even *remotely* close to executing a non-trivial Factor   
   program, this thing runs virtually unmodified   
   (https://rosettacode.org/wiki/Ethiopian_multiplication#Factor):   
      
   include lib/factor.4th   
   include 4pp/lib/factor.4pp   
      
   : odd? ( n -- ? ) 1 bitand 1 number= ;   
   : double ( n -- 2*n ) 2 * ;   
   : halve ( n -- n/2 ) 2 /i ;   
      
   : ethiopian-mult ( a b -- a*b )   
        [ 0 ] 2dip   
        [ dup 0 > ] [   
            [ odd? [ + ] [ drop ] if ] 2keep   
            [ double ] [ halve ] bi*   
        ] while 2drop ;   
      
   34 17 ethiopian-mult .   
      
   Decompile (of the interesting bits):   
      
       358| branch                            363   odd?   
       359| literal                             1   
       360| and                                 0   
       361| literal                             1   
       362| =                                   0   
       363| exit                                0   
       364| branch                            366   double   
       365| *literal                            2   
       366| exit                                0   
       367| branch                            369   halve   
       368| /literal                            2   
       369| exit                                0   
       370| branch                            416   ethiopian-mult   
       371| literal                           372   
       372| branch                            374   
       373| literal                             0   
       374| exit                                0   
       375| call                              151   2dip   
       376| literal                           377   
       377| branch                            381   
       378| dup                                 0   
       379| literal                             0   
       380| >                                   0   
       381| exit                                0   
       382| literal                           383   
       383| branch                            403   
       384| literal                           385   
       385| branch                            395   
       386| call                              358   odd?   
       387| literal                           388   
       388| branch                            390   
       389| +                                   0   
       390| exit                                0   
       391| literal                           392   
       392| branch                            394   
       393| drop                                0   
       394| exit                                0   
       395| branch                             78   if?   
       396| call                              197   2keep   
       397| literal                           398   
       398| branch                            399   
       399| branch                            364   double   
       400| literal                           401   
       401| branch                            402   
       402| branch                            367   halve   
       403| branch                            265   bi*   
       404| >r                                  0   
       405| >r                                  0   
       406| r@                                  0   
       407| execute                             0   
       408| 0branch                           411   
       409| r'@                                 0   
       410| execute                             0   
       411| branch                            405   
       412| rdrop                               0   
       413| rdrop                               0   
       414| drop                                0   
       415| drop                                0   
       416| exit                                0   
       417| literal                            34   
       418| literal                            17   
       419| call                              370   ethiopian-mult   
       420| .                                   0   
       421| cr                                  0   
      
   An finally, the output:   
      
   $ pp4th -x ethimul.4pp   
   578   
   $   
      
   Hans Bezemer   
      
   --- SoupGate-Win32 v1.05   
    * Origin: you cannot sedate... all the things you hate (1:229/2)   

[   << oldest   |   < older   |   list   |   newer >   |   newest >>   ]


(c) 1994,  bbs@darkrealms.ca