\ 4stack primitives
\ Copyright (C) 2000 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 2
\ 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, write to the Free Software
\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
Label start ;;
nop ;; first opcode must be a nop!
$80000000 ## ;;
#, ;;
sr! jmpa $828 >IP ;;
$800 .org
ip0: .int 0
.int 0
conpat: nop nop ip@ jmpa ;;
varpat: nop nop ip@ jmpa ;;
jmppat: nop ip@ nop jmpa ;;
colpat: nop nop ip@ jmpa ;;
;; ds cfa fs rs
main: ;;
-$200 ## nop nop nop -12 # ld 1: ip ;;
#, nop nop nop set 0: R3 ;;
nop nop nop nop 0 # set 1: R1 ;;
nop nop nop nop 0 # ld 1: R1 N+ ;;
nop nop nop nop 0 # ld 1: R1 N+ ;;
nop ip! nop nop 0 # ld 1: R1 N+ ;;
nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
docol: .endif ;;
;; nop nop ip@ jmp docol ;;
;; ds ca cfa fs rs
nop 8 # drop -12 # get 0: R1 get 3: R1 ;;
drop add 0s0 nop add 0 # set 1: R1 ;;
nop drop nop nop 0 # ld 1: R1 N+ ;;
nop drop nop nop 0 # ld 1: R1 N+ ;;
nop ip! nop nop 0 # ld 1: R1 N+ ;;
nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
dodoes: .endif ;;
;; nop nop ip@ jmp doesjump
;; nop ip@ nop jmp dodoes
;; ds df ca cfa fs rs
8 # nop drop -12 # get 0: R1 get 3: R1 ;;
add nop nop add 0 # set 1: R1 ;;
nop drop nop nop 0 # ld 1: R1 N+ ;;
nop drop nop nop 0 # ld 1: R1 N+ ;;
nop ip! nop nop 0 # ld 1: R1 N+ ;;
nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
dovar: .endif ;;
;; nop nop ip@ jmp dovar ;;
;; ds cfa fs rs
8 # swap ip! nop get 0: R1 ;;
add ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
docon: .endif ;;
;; nop nop ip@ jmp dovar ;;
;; ds cfa fs rs
nop swap ip! nop ld 0: R1 2 # ;;
nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
-3 Alias: :docon
Code execute ( xt -- )
nop nop nop ip@ br .endif
ip! drop pick 0s0 nop set 2: R1 ;;
nop nop nop ip! -1 # ld 1: R1 ;;
end-code
Code ?branch
nop nop nop ip@ br .endif
nop swap nop nop br 0 ?0<>
nop nop nop nop -12 # R1= R1 3: +s0 ;;
nop drop nop nop 0 # ld 1: R1 N+ ;;
nop drop nop nop 0 # ld 1: R1 N+ ;;
.endif
nop ip! nop drop 0 # ld 1: R1 N+ ;;
nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code +
add ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code and
and ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code xor
xor ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code sp@
sp@ ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code sp!
sp! ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code rp@
nop nop ip@ sp@ br .endif
pick 3s0 swap ip! drop ;;
nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code rp!
drop nop ip@ pick 0s0 br .endif
nop swap ip! sp! ;;
nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code ;s
nop nop nop nop br .endif
nop drop nop nop 0 # set 3: R1 ;;
nop drop nop nop 0 # ld 1: R1 N+ ;;
nop nop nop nop 0 # ld 1: R1 N+ ;;
nop ip! nop nop 0 # ld 1: R1 N+ ;;
nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code @
nop nop ip@ nop br .endif
drop swap ip! nop ld 0: s0b 0 # ;;
nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code !
nop nop ip@ nop br .endif
drop swap ip! nop st 0: s0b 0 # ;;
nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
\ obligatory IO
Code key?
nop nop ip@ nop br .endif
nop swap nop nop inb R3 3 # ;;
nop nop ip! nop ;;
0<> ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code (key)
nop nop ip@ nop br .endif
.begin inb R3 3 # ;;
nop br 0 ?0= .until
inb R3 2 # ;;
nop swap ip! nop ;;
nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code (emit)
nop nop ip@ nop br .endif
;; .begin inb R3 1 # ;;
;; nop br 0 ?0= .until
outb 0: R3 0 # ;;
nop swap ip! nop ;;
nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
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/
asr ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code branch
nop nop nop ip@ br .endif
nop nop nop nop -12 # R1= R1 3: +s0 ;;
nop drop nop nop 0 # ld 1: R1 N+ ;;
nop drop nop nop 0 # ld 1: R1 N+ ;;
nop ip! nop drop 0 # ld 1: R1 N+ ;;
nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code (loop)
pick 3s1 nop nop ip@ br .endif
dec nop nop nop ;;
sub 3s1 swap nop nop br 0 ?0=
nop nop nop nop -12 # R1= R1 3: +s0 ;;
nop drop nop nop 0 # ld 1: R1 N+ ;;
nop drop nop nop 0 # ld 1: R1 N+ ;;
.endif
nop ip! nop drop 0 # ld 1: R1 N+ ;;
nop ip! ip@ inc set 2: R1 ld 1: R1 N+ ;;
end-code
Code (+loop)
pick 3s1 nop nop ip@ br .endif
subr 3s1 nop nop nop ;;
xor #min nop nop nop ;;
add s1 swap nop nop br 0 ?ov
nop nop nop nop -12 # R1= R1 3: +s0 ;;
nop drop nop nop 0 # ld 1: R1 N+ ;;
nop drop nop nop 0 # ld 1: R1 N+ ;;
.endif
nop ip! nop drop 0 # ld 1: R1 N+ ;;
drop ip! ip@ add 0s0 set 2: R1 ld 1: R1 N+ ;;
end-code
Code (do)
nop nop ip@ nop br .endif
nip swap ip! pick 0s1 ;;
drop ip! ip@ pick 0s0 set 2: R1 ld 1: R1 N+ ;;
end-code
Code -
subr ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code or
or ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code 1+
inc ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code 2*
asl ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code cell+
add c2 ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code cells
nop nop ip@ nop br .endif
asl swap ip! nop ;;
asl ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code c@
nop nop ip@ nop br .endif
drop swap ip! nop ldb 0: s0b 0 # ;;
nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code c!
nop nop ip@ nop br .endif
drop swap ip! nop stb 0: s0b 0 # ;;
nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code um*
nop nop ip@ nop br .endif
umul swap ip! nop ;;
mul@ ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code m*
nop nop ip@ nop br .endif
mul swap ip! nop ;;
mul@ ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code d+
nop nop ip@ nop br .endif
pass swap ip! nop ;;
mul@+ ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code >r
drop ip! ip@ pick 0s0 set 2: R1 ld 1: R1 N+ ;;
end-code
Code r>
pick 3s0 ip! ip@ drop set 2: R1 ld 1: R1 N+ ;;
end-code
Code drop
drop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code swap
swap ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code over
over ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code 2dup
nop nop ip@ nop br .endif
over swap ip! nop ;;
over ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code rot
rot ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code -rot
nop nop ip@ nop br .endif
rot swap ip! nop ;;
rot ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code i
pick 3s0 ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code i'
pick 3s1 ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code j
pick 3s2 ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code lit
ip@ nop pick 1s0 nop br .endif ;;
nop nip ip! nop 0 # ld 1: R1 N+ ;;
nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code 0=
0= ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code 0<>
0<> ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code u<
nop nop ip@ nop br .endif
subr swap ip! nop ;;
u< ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code u>
nop nop ip@ nop br .endif
subr swap ip! nop ;;
u> ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code u>=
nop nop ip@ nop br .endif
subr swap ip! nop ;;
u>= ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code u<=
nop nop ip@ nop br .endif
subr swap ip! nop ;;
u<= ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code >=
nop nop ip@ nop br .endif
subr swap ip! nop ;;
>= ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code <=
nop nop ip@ nop br .endif
subr swap ip! nop ;;
<= ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code =
nop nop ip@ nop br .endif
subr swap ip! nop ;;
0= ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
Code <>
nop nop ip@ nop br .endif
subr swap ip! nop ;;
0<> ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
\ : (find-samelen) ( u f83name1 -- u f83name2/0 )
\ BEGIN 2dup cell+ c@ $1F and <> WHILE @ dup 0= UNTIL THEN ;
Code (find-samelen)
nop nop ip@ nop br .endif
nop 0 # 0 # nop ;;
nop nop pick 0s0 nop ;;
.begin
drop drop nop nop ldb 0: s0b 4 # ;;
nop $1F # nip nop ld 2: s0b 0 # ;;
drop and 0s0 nop nop ;;
pick 2s0 sub 0s0 nop nop br 1&2 :0<> .until ;;
pick 2s1 nop pass nop br 1 ?0= ;;
drop swap ip! nop ;;
nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
.endif
nip swap ip! nop ;;
nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
end-code
\ division a/b
\ 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
\ Label idiv-table
\ idiv-tab:
\ .macro .idiv-table [F]
\ $100 $80 DO 0 $100 I 2* 1+ um/mod long, drop LOOP
\ .end-macro
\ .idiv-table
\ end-code
\
\ Code um/mod1 ( u -- 1/u )
\ ;; b -- -- -- -- -- ;;
\ ff1 -$1F # nop nop br 0 :0= div0
\ bfu add 0s0 ip@ nop set 2: R2 ;;
\ ;; b' -- -- -- -- -- ;;
\ lob $0FF ## pick 0s0 pick 0s0 0 # -$108 ## ;;
\ 1 # #, sub #min 1 # ld 0: R2 +s0 #, ;;
\ cm! and nop cm! br 2 ?0= by2
\ ;; est -- -- b' -- -- ;;
\ umul 3s0 pick 0s0 nop umul 0s0 0 # 0 # ;;
\ mulr<@ nop nop -mulr@ ;;
\ drop umul 3s0 nop umul 0s0 ;;
\ mulr<@ cm! nop -mulr@ ;;
\ umul 3s0 drop pick 1s0 drop ;;
\ drop mulr<@ ip! nop 0 # ld 1: R1 N+ ;;
\ pick 1s0 drop nop nop ;;
\ by2:
\ div0:
\ -1 # ip! nop nop 0 # ld 1: R1 N+ ;;
\ nop nop nop nop ;;
\ end-code
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>