[BACK]Return to prim.fs CVS log [TXT] [DIR] Up to [gforth] / gforth / arch / 4stack

Diff for /gforth/arch/4stack/prim.fs between versions 1.8 and 1.9

version 1.8, 2003/08/17 22:52:33 version 1.9, 2003/08/18 19:29:15
Line 410  end-code Line 410  end-code
 : code-address! ( addr xt -- )  >r 3 or $808 @ r> 2! ;  : code-address! ( addr xt -- )  >r 3 or $808 @ r> 2! ;
 : does-code!    ( a_addr xt -- )  >r 5 - $808 @ r> 2! ;  : does-code!    ( a_addr xt -- )  >r 5 - $808 @ r> 2! ;
 : does-handler! ( a_addr -- )  >r $810 2@ r> 2! ;  : does-handler! ( a_addr -- )  >r $810 2@ r> 2! ;
   : finish-code ;
   
 : bye  0 execute ;  : bye  0 execute ;
 : (bye) 0 execute ;  : (bye) 0 execute ;
 : float+ 8 + ;  : float+ 8 + ;
   
 : sgn ( n -- -1/0/1 )  : sgn ( n -- -1/0/1 )
   dup 0= IF EXIT THEN  0< 2* 1+ ;   dup 0= IF EXIT THEN  0< 2* 1+ ;
 : -text  : -text ( c_addr1 u c_addr2 -- n )
   swap bounds   swap bounds
   ?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0   ?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0
   ELSE  c@ I c@ - unloop  THEN  sgn ;   ELSE  c@ I c@ - unloop  THEN  sgn ;
 : finish-code ;  : capscomp ( c_addr1 u c_addr2 -- n )
 : capscomp  ( c_addr1 u c_addr2 -- n )   swap bounds
   swap bounds   ?DO  dup c@ I c@ <>
   ?DO  dup c@ I c@ <>       IF  dup c@ toupper I c@ toupper =
       IF  dup c@ toupper I c@ toupper =       ELSE  true  THEN  WHILE  1+  LOOP  drop 0
       ELSE  true  THEN  WHILE  1+  LOOP  drop 0   ELSE  c@ toupper I c@ toupper - unloop  THEN  sgn ;
   ELSE  c@ toupper I c@ toupper - unloop  THEN  sgn ;  
   
 \ division a/b  \ division a/b
 \ x:=a, y:=b, r:=est; iterate(x:=x*r, y:=y*r, r:=2-y*r);  \ x:=a, y:=b, r:=est; iterate(x:=x*r, y:=y*r, r:=2-y*r);
 \ result: x=a/b; y=1; r=1  \ result: x=a/b; y=1; r=1
   
 \ Label idiv-table  Code u/mod ( u1 u2 -- q r )
 \ idiv-tab:      drop     nop       pick 0s0  call $43 +IP ;;
 \ .macro .idiv-table [F]      pick 1s0 drop      nop       nop                 ;;
 \       $100 $80 DO  0 $100 I 2* 1+ um/mod  long, drop  LOOP      swap     ip!       nop       nop       0 #         ld 1: R1 N+ ;;
 \ .end-macro      nop      nop       nop       nop                               ;;
 \       .idiv-table  .macro .idiv-table [F]
 \ end-code          $100 $80 DO  0 $100 I 2* 1+ um/mod  long, drop  LOOP
 \   .end-macro
 \ Code um/mod1 ( u -- 1/u )  approx:
 \ ;;    b        --        --       --        --          --          ;;     .idiv-table
 \       ff1      -$1F #    nop      nop       br 0 :0= div0  idiv:
 \       bfu      add 0s0   ip@      nop       set 2: R2               ;;  ;; a         --        b         --
 \ ;;    b'       --        --       --        --          --          ;;     nop       pick 2s0  ff1       1 #       br 1 :0=              ;;
 \       lob      $0FF ##   pick 0s0 pick 0s0  0 #         -$108 ## ;;     ip@       pick 2s0  bfu       cm!       set 0: R2             ;;
 \       1 #      #,        sub #min 1 #       ld 0: R2 +s0 #,         ;;  ;; a         n         b'        --
 \       cm!      and       nop      cm!       br 2 ?0= by2     nop       -$1D #    lob       pick 2s0  0 #            -$104 ## ;;
 \ ;;      est      --        --       b'        --          --          ;;     nop       add       pick 3s0  drop      ld 2: R2 +s0   #, ;;
 \       umul 3s0 pick 0s0  nop      umul 0s0  0 #         0 #         ;;     nop       cm!       nip       nop       ;;
 \       mulr<@   nop       nop      -mulr@                            ;;  ;; a         n         b' r      --
 \       drop     umul 3s0  nop      umul 0s0                          ;;     umul 2s0  pick 0s0  umul      nop       ;;
 \       mulr<@   cm!       nop      -mulr@                            ;;     mulr@     0 #       mulr@     -mulr@    ;; first iteration
 \       umul 3s0 drop      pick 1s0 drop                              ;;     umul 3s0  pick s2   umul 3s0  drop      ;;
 \       drop     mulr<@    ip!      nop       0 #         ld 1: R1 N+ ;;     mulr@     nop       nop       -mulr<@   ;; second iteration
 \       pick 1s0 drop      nop      nop                               ;;     umul 3s0  nop       nop       drop      ;;
 \ by2:     nop       mulr<@    nop       nop       ;; final iteration+shift
 \ div0:     pick 1s0  umul      nop       nop       ;;
 \       -1 #     ip!       nop      nop       0 #         ld 1: R1 N+ ;;     nop       -mul@+    nop       ret       br 1 ?0< ;;
 \       nop      nop       nop      nop                               ;;     nop       nip       nop       nop       ;;
 \ end-code  .endif
      dec       add       nop       nop       ;;
   ;; q         r
   
   .endif
      nop       drop      drop      drop      ;;
      dec       0 #       drop      ret       ;;
      nop                                     ;;
   end-code
   
   : /mod  ( d1 n1 -- n2 n3 )
    dup >r dup 0< IF  negate >r negate r>  THEN
    over       0< IF  tuck + swap  THEN
    u/mod
    r> 0< IF  swap negate swap  THEN ;
Removed from v.1.8  
changed lines
  Added in v.1.9

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>