Just a little exercise ("SQRT the hard way") rehosting the tiny FORTH
system from:
"forth in (many lines of) javascript"
http://lists.canonical.org/pipermail/kragen-discuss/2013-October/
001278.html
in dc(1)[0]. Now, dc does have a stack, but it doesn't have any way
to input or manipulate strings, so everything has to be goedel coded
[1]. I was lazy enough to use the dc arrays as the equivalent of
jump tables in assembly[2], not lazy enough (read: too stupid) to
have used them as dictionaries. Because the forth dictionary was
hand-rolled, it was exceedingly tempting to kludge the IMMediate flag
onto the normal dictionary entry.
-Dave
NB. Despite dc's arbitrary precision capability, there are many parts
of this system (especially the kludge for '<=') which are limited to
fixed, or even unknown but fairly small, values.
[0] I now have much more respect for Robert Morris and Lorinda Cherry
(authors of the original bc, which compiled to dc). The original
inspiration for this exercise was running across the 'a' command,
which would enable subroutine-threaded interpretation of native dc
code goedel-coded as integers, however, this implementation[3]
vectors through a primitive array and hence no longer uses 'a'.
[1] kludged here w/ awk(1)
[2] or sometimes just to avoid pressure in the single-character dc
namespace
[3] indirect threaded for convenience of CREATE DOES>
#!/bin/sh
########################################################################
# The FORTH application for integer SQRT. Output should be:
#
# 8 2
# 10 3
# 2013 44
########################################################################
prog=$(cat <<"EOF"
VAR P VAR Q VAR R
: SQRT R ! 0 P !
1 REPEAT DUP R @ <= IF 2* 2* AGAIN THEN Q !
REPEAT Q @ 1 <= NOT IF
Q @ 2/ 2/ Q !
P @ DUP 2/ P ! Q @ +
DUP R @ <= IF P @ Q @ + P !
DUP R @ SWAP - R !
THEN
DROP
AGAIN THEN
P @ ;
: TAB DUP . SQRT . CR ;
CR
8 TAB
10 TAB
2013 TAB
EOF
)
########################################################################
# FORTH words (control & data) implementing application language
########################################################################
boot=$(tail +2 <<"EOF"
' !!! this line is a kludge to keep the shell HEREDOC happy
' DO: , LABEL : [/] LIT DO: , LABEL [/] ' [/] ,
: ; LIT NEXT , [/] ' [/] , IMM
: REF> HERE HERE , ;
: <DEF HERE !~ ;
: IF LIT JZ , REF> ; IMM
: THEN <DEF ; IMM
: REPEAT R> HERE >R >R ; IMM
: AGAIN LIT JMP , R> R> , >R ; IMM
: CREATE LIT NEXT , LABEL ;
: DOES> LIT CFA , LIT LIT , REF> LIT !~ , LIT NEXT ,
LIT DOES: , <DEF ; IMM
: VAR 0 CREATE , DOES> ;
: ! SWAP !~ ;
EOF
)
########################################################################
# a FORTH in dc(1)
# we use the dc stack for data (exercise: replace by a variable)
# but we synthesize our own return stack and memory w/ dictionary.
# as dc doesn't do string input, nor partial-line numeric output,
# we must also hand-translate numbers (goedel-codes in, ascii out)
########################################################################
forthvm=$(cat <<"EOF"
# c=compile state, d=dictionary, h=HERE, i=IP, k=key/CFA kludge
# l=lastdef, m=MEMORY (array), p=primitive count, r=RSTACK
# x,y,z,_=scratch
## Dictionary/Memory ####################
[lh d 1+sh :m]s, # (,) append to memory
[1000~ l,x d0<S]sS # (S)tring literal
[ld l,x lhsd lSx lhsl 0* l,x]sE # (E)nter in dictionary
[lz1-sy 0 2Q]sB # (B)ad match
[ly;m800/sx ly1+sy 1 2Q]sG # (G)ood match
[lx200% ly;m200%- 0!=B lx 0=G lx1000/sx ly1+sy 0;Qx]0:Q # (Q)uery 1
[ly;msy lksx ly 0<Q]sC # (C)ontinue search
[lxsk lysz 0;Qx 0=C]sQ # (Q)uery dictionary
## I/O ##################################
[lyP9Pq]sU # o(U)tput number
[lx0=U lx 10~48+lzd1+sz256r^*ly+sy sx 1;Ux]1:U # digit
[48sy d0=U sx 0sz 0sy 1;Ux]0:U # *entry
[lyq]sN # i(N)put number
[lx0=N lx 1000~48-lzd1+sz10r^*ly+sy sx 1;Nx]1:N # digit
[sx 0sz 0sy 1;Nx]0:N # *entry
## Inner Interpreter ####################
[500-;Oxq]sP # (P)rimitive execute
[lr1000*li+sr d1-si]sT # (T)hreaded execute
[li d1+ si ;m d500!>P lTx]sL # thread e(L)ement
[lLx li0<J]sJ # (J)oin thread: *inner
## Outer Interpreter ####################
[s_ lk 0;Nx q]sA # (A) interpret number
[s_ 508 l,x lk 0;Nx l,x q]sD # (D) comp number !!! 508=LIT
[s_ ly1+;m 500-;Ox q]sH # (H) interpret primitive
[s_ ly1+;m 1-]sY # (Y) compile primitive
[ly0=A ly=H lr1000*sr dsi 1+ lJx]0:I # (0:I) interpret
[ly0=D ly=Y 1+ l,x]1:I # (1:I) compile
[sx ld sy lQx ly d;m lxly*lc+Z0r^;Ix]sX # (X) lookup word & process
[lXx lhli<Z]sW # (W) X until QUIT
[1si ? lWx]sZ # (Z) *outer interpreter
## initialize... ############################
0sh 0sd 500 l,x 1sc 0sr # initialize mem, interp
0sp [lp:O lEx lh l,x lpd1+sp 500+ l,x]sV # define primiti(V)e
## core prims ###############################
081085073084 [li0r^0r^999*si] lVx # 500 QUIT
078069088084 [lr 1000~ si sr] lVx # 501 NEXT
068079058 [si] lVx # 502 DO:
076065066069076 [lh1-dsh;msk?lExlkl,x] lVx # 503 LABEL
073077077 [ll800r:m] lVx # 504 IMM
091047093 [lc0r^sc4Q] lVx 4;Ox # 505 [/] (IMM)
039 [? sx ld sy lQx ly d;m ly=Y 1+] lVx # 506 ''
044 l, lVx # 507 ,
076073084 [li d 1+si ;m] lVx # 508 LIT
033031 [r:m] lVx # 509 !~
072069082069 [lh] lVx # 510 HERE
074090 [0r^ li;mli-1-*1+li+ 1000% si] lVx # 511 JZ
074077080 [li;msi] lVx # 512 JMP
082062 [ lr 1000~ rsr] lVx # 513 R>
062082 [1000% lr 1000* +sr] lVx # 514 >R
067070065 [ll1+] lVx # 515 CFA
068079069083058 [lr1000/sr s_] lVx # 516 DOES:
## application specific prims ###############
043 [+] lVx # 517 +
045 [-] lVx # 518 -
050042 [2*] lVx # 519 2*
050047 [2/] lVx # 520 2/
060061 [r-2r^Z0r^0r^] lVx # 522 <=
078079084 [0r^] lVx # 523 NOT
064 [;m] lVx # 524 @
068085080 [d] lVx # 525 DUP
068082079080 [s_] lVx # 526 DROP
083087065080 [r] lVx # 527 SWAP
046 [0;Ux] lVx # 528 .
067082 [10P] lVx # 529 CR
## ... and execute ##########################
lZx
EOF
)
########################################################################
# Goedel-code strings for dc (exercise: allow primitive defns in input)
########################################################################
todc=$(cat <<'EOF'
{for(f=1;f<=NF;f++) { print todc($f); }}
END { print todc("QUIT") }
BEGIN {
xtab = " !\"#$%&'()*+,-./"
xtab = xtab "0123456789:;<=>?"
xtab = xtab "@ABCDEFGHIJKLMNO"
xtab = xtab "PQRSTUVWXYZ[\\]^_"
}
function todc(f) {
n=split(f,a,""); s="";
for(i=0;i<n;i++) {
s=sprintf("%s%03d", s, 31+index(xtab,a[i+1]));
}
return s;
}
EOF
)
echo "$boot" "$prog" | awk "$todc" | dc -e "$forthvm"
## QEF ##
--
To unsubscribe: http://lists.canonical.org/mailman/listinfo/kragen-discuss
