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

Diff for /gforth/arch/4stack/prim-new.fs between versions 1.1 and 1.6

version 1.1, 1997/05/29 19:42:44 version 1.6, 2008/10/19 21:19:06
Line 1 Line 1
 \ 4stack primitives  \ 4stack primitives
   
   \ Copyright (C) 2000,2007 Free Software Foundation, Inc.
   
   \ This file is part of Gforth.
   
   \ Gforth is free software; you can redistribute it and/or
   \ modify it under the terms of the GNU General Public License
   \ as published by the Free Software Foundation, either version 3
   \ of the License, or (at your option) any later version.
   
   \ This program is distributed in the hope that it will be useful,
   \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   \ GNU General Public License for more details.
   
   \ You should have received a copy of the GNU General Public License
   \ along with this program. If not, see http://www.gnu.org/licenses/.
   
 Label start  ;;  Label start  ;;
 nop          ;; first opcode must be a nop!  nop          ;; first opcode must be a nop!
 $80000000 ## ;;  $80000000 ## ;;
Line 55  docon:  .endif ;; Line 72  docon:  .endif ;;
         nop      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;          nop      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
 end-code  end-code
   
 -3 Alias: :docon  -2 Doer: :docol
   -3 Doer: :docon
   -4 Doer: :dovar
   -8 Doer: :dodoes
   -9 Doer: :doesjump
   
 Code execute ( xt -- )  Code execute ( xt -- )
         nop      nop       nop      ip@       br .endif          nop      nop       nop      ip@       br .endif
Line 154  Code (emit) Line 175  Code (emit)
         nop      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;          nop      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
 end-code  end-code
   
 : (type)  
     bounds ?DO  I c@ (emit)  LOOP ;  
 \    BEGIN  dup  WHILE  
 \       >r dup c@ (emit) 1+ r> 1-  REPEAT  2drop ;  
   
 \ obligatory code address manipulations  
   
 : >code-address ( xt -- addr )  cell+ @ -8 and ;  
 : >does-code    ( xt -- addr )  
     cell+ @ -8 and \ dup 3 and 3 <> IF  drop 0  EXIT  THEN  
     8 + dup cell - @ 3 and 0<> and ;  
 : code-address! ( addr xt -- )  >r 3 or $808 @ r> 2! ;  
 : does-code!    ( a_addr xt -- )  >r 5 - $808 @ r> 2! ;  
 : does-handler! ( a_addr -- )  $818 2@ rot 2! ;  
   
 \ this was obligatory, now some things to speed it up  
   
 Code 2/  Code 2/
         asr      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;          asr      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
 end-code  end-code
Line 400  Code (find-samelen) Line 404  Code (find-samelen)
         nop      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;          nop      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
 end-code  end-code
   
   \ obligatory code address manipulations
   
   : >code-address ( xt -- addr )  cell+ @ -8 and ;
   : >does-code    ( xt -- addr )
       cell+ @ -8 and \ dup 3 and 3 <> IF  drop 0  EXIT  THEN
       8 + dup cell - @ 3 and 0<> and ;
   : code-address! ( addr xt -- )  >r 3 or $808 @ r> 2! ;
   : does-code!    ( a_addr xt -- )  >r 5 - $808 @ r> 2! ;
   : does-handler! ( a_addr -- )  $818 2@ rot 2! ;
   
   \ this was obligatory, now some things to speed it up
   
   : (type)
       bounds ?DO  I c@ (emit)  LOOP ;
   \    BEGIN  dup  WHILE
   \       >r dup c@ (emit) 1+ r> 1-  REPEAT  2drop ;
   
 \ 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
Removed from v.1.1  
changed lines
  Added in v.1.6

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