# fib.sed
# Mike Wilson, cmikewilsonAgmailDcom
# June 14, 2005

s/^#.*//
s/$/,/
G
s/\n//
/^,/d
s/,$/,@/

:cycle
t cycle    # clear sed substitution flag
#p
/^IADD /b iadd
/^ISUB /b isub
/^DECR /b decr
/^INCR /b incr
/^UNPAD /b unpad
/^NEG /b neg
/^RETURN /b return
/^SUBST /b subst
/^FIB /b fib
/^PRINT /b print
/^READCMD /b readcmd
/^ERROR /b error
/^EXIT[ ,]/b exit


:nomatch
s/^@/READCMD,@/
t readcmd
s/^\([^,]\+\),.*/ERROR Unrecognized Command: \1,/
t error
b exit


:fib
# fib(0) => 0
# fib(1) => 1
# fib(x) => fib(x-2) + fib(x-1) => x1=x-1; t=fib(x1); iadd(t,fib(x1-1))
s/^FIB B0,/RETURN B0,/
s/^FIB B1,/RETURN B1,/
t return
s/^FIB B\([01]\+\),/DECR B\1,SUBST X1 _,FIB {X1},SUBST T _,DECR {X1},FIB _,IADD {T} _,!,/
t decr
b loop-error


:incr    # increment
s/^INCR B\([01]*\)0,/RETURN B\11,/
t return
s/^INCR B1,/RETURN B10,/
t return
s/^INCR B\([01]\+\)1,/INCR B\1,RETURN _0,/
t incr
s/^INCR B-\([01]\+\),/DECR B\1,NEG _,/
t decr
b loop-error


:decr    # decrement
s/^DECR B0,/RETURN B-1,/
t return
s/^DECR B\([01]*\)1,/RETURN B\10,/
t return
s/^DECR B\([01]\+\)0,/DECR B\1,UNPAD _1,/
t decr
s/^DECR B-\([01]\+\),/INCR B\1,NEG _,/
t incr
b loop-error


:unpad
# remove leading zeroes
s/^UNPAD B\(-\?\)0*\([01]\+\),/RETURN B\1\2,/
t return
b loop-error


:neg    # negate
s/^NEG B0,/RETURN B0,/
t return
s/^NEG B\([01]\+\),/RETURN B-\1,/
t return
s/^NEG B-\([01]\+\),/RETURN B\1,/
t return
b loop-error


:iadd
# negative numbers or zero
/^IADD B\([-0]\|[01]\+ B[-0]\)/{
    s/^IADD B0 B\(-\?[01]\+\),/RETURN B\1,/
    t return
    s/^IADD B\(-\?[01]\+\) B0,/RETURN B\1,/
    t return
    s/^IADD B-\([01]\+\) B\([01]\+\),/ISUB B\2 B\1,/
    t isub+
    s/^IADD B-\([01]\+\) B-\([01]\+\),/IADD B\1 B\2,NEG _,/
    t iadd+
    s/^IADD B\([01]\+\) B-\([01]\+\),/ISUB B\1 B\2,/
    t isub+
    b loop-error
}
:iadd+
# Reverse A and B and interleave the digits, padding with zero if one runs out
# Then add a carry digit to the front, and lookup the first three digits
# to get the rightmost digit of the result.
# IADD
#     A B => X=blank, IADD2 A B X
# IADD2
#     Aa Bb X => IADD2 A B Xab
#      x Bb X => IADD3 B X0b
#     Aa  x X => IADD4 A Xa0
#      x  x X => R=blank, IADD5 0X R
# IADD3
#     Bb X => IADD3 B X0b
#      x X => R=blank, IADD5 0X R
# IADD4
#     Aa X => IADD4 A Xa0
#      x X => R=blank, IADD5 0X R
# IADD5
#     cabX R => cr=(lookup cab), IADD5 cX rR
#     c    R => c=0, return R; c=1, return 1R
s/^IADD B\([01]\+\) B\([01]\+\),/IADD2 B\1 B\2 ,/
t iadd2
b loop-error
:iadd2
s/^IADD2 B\([01]*\)\([01]\) B\([01]*\)\([01]\) \([01]*\),/IADD2 B\1 B\3 \5\2\4,/
t iadd2
s/^IADD2 B B\([01]*\)\([01]\) \([01]*\),/IADD3 B\1 \30\2,/
t iadd3
s/^IADD2 B\([01]*\)\([01]\) B \([01]*\),/IADD4 B\1 \3\20,/
t iadd4
s/^IADD2 B B \([01]\+\),/IADD5 0\1 B,/
t iadd5
b loop-error
:iadd3
s/^IADD3 B\([01]*\)\([01]\) \([01]*\),/IADD3 B\1 \30\2,/
t iadd3
s/^IADD3 B \([01]\+\),/IADD5 0\1 B,/
t iadd5
b loop-error
:iadd4
s/^IADD4 B\([01]*\)\([01]\) \([01]*\),/IADD4 B\1 \3\20,/
t iadd4
s/^IADD4 B \([01]\+\),/IADD5 0\1 B,/
t iadd5
b loop-error
:iadd5
s/^IADD5 000\([01]*\) B\([01]*\),/IADD5 0\1 B0\2,/
t iadd5
s/^IADD5 001\([01]*\) B\([01]*\),/IADD5 0\1 B1\2,/
t iadd5
s/^IADD5 010\([01]*\) B\([01]*\),/IADD5 0\1 B1\2,/
t iadd5
s/^IADD5 011\([01]*\) B\([01]*\),/IADD5 1\1 B0\2,/
t iadd5
s/^IADD5 100\([01]*\) B\([01]*\),/IADD5 0\1 B1\2,/
t iadd5
s/^IADD5 101\([01]*\) B\([01]*\),/IADD5 1\1 B0\2,/
t iadd5
s/^IADD5 110\([01]*\) B\([01]*\),/IADD5 1\1 B0\2,/
t iadd5
s/^IADD5 111\([01]*\) B\([01]*\),/IADD5 1\1 B1\2,/
t iadd5
s/^IADD5 0 B\([01]\+\),/RETURN B\1,/
t return
s/^IADD5 1 B\([01]\+\),/RETURN B1\1,/
t return
b loop-error


:isub
# find negative number or zero
/^ISUB B\([-0]\|[01]\+ B[-0]\)/{
    s/^ISUB B0 B\(-\?[01]\+\),/NEG B\1,/
    t neg
    s/^ISUB B\(-\?[01]\+\) B0,/RETURN B\1,/
    t return
    s/^ISUB B-\([01]\+\) B\([01]\+\),/IADD B\1 B\2,NEG _,/
    t iadd+
    s/^ISUB B-\([01]\+\) B-\([01]\+\),/ISUB B\2 B\1,/
    t isub+
    s/^ISUB B\([01]\+\) B-\([01]\+\),/IADD B\1 B\2,/
    t iadd+
    b loop-error
}
# Reverse and interleave the digits of A and B, padding with zero if necessary
# Add a borrow bit to the front and lookup the first three bits
# and add to the result.
# A might turn out less than B, so we call ISUB B A,NEG _.
# Rather than keep up with the original A and B the whole time,
# push TMP A B on the stack and either use it or remove it.
# ISUB
#     A B => X=blank, ISUB2 A B X,TMP A B
# ISUB2
#     Aa Bb X => ISUB2 A B Xab
#     x  Bb X => (A<B), call ISUB B A,NEG _
#     Aa x  X => ISUB3 A Xa0
#     x  x  X => R=blank, ISUB4 0X R
# ISUB3
#     Aa X => ISUB3 A Xa0
#     x  X => R=blank, ISUB4 0X R
# ISUB4 (c = borrow)
#     cabX R => rc=(lookup cab), ISUB4 cX rR
#     0x   R => remove ISUB B A stack frame, return R
#     1x   R => (A<B), call ISUB B A,NEG _
:isub+
s/^ISUB B\([01]\+\) B\([01]\+\),/ISUB2 B\1 B\2 ,TMP B\1 B\2,/
t isub2
b loop-error
:isub2
s/^ISUB2 B\([01]*\)\([01]\) B\([01]*\)\([01]\) \([01]*\),/ISUB2 B\1 B\3 \5\2\4,/
t isub2
s/^ISUB2 B B[01]\+ [01]*,TMP B\([01]\+\) B\([01]\+\),/ISUB B\2 B\1,NEG _,/
t isub+
s/^ISUB2 B\([01]*\)\([01]\) B \([01]*\),/ISUB3 B\1 \3\20,/
t isub3
s/^ISUB2 B B \([01]\+\),/ISUB4 0\1 B,/
t isub4
b loop-error
:isub3
s/^ISUB3 B\([01]*\)\([01]\) \([01]*\),/ISUB3 B\1 \3\20,/
t isub3
s/^ISUB3 B \([01]\+\),/ISUB4 0\1 B,/
t isub4
b loop-error
:isub4
s/^ISUB4 000\([01]*\) B\([01]*\),/ISUB4 0\1 B0\2,/
t isub4
s/^ISUB4 001\([01]*\) B\([01]*\),/ISUB4 1\1 B1\2,/
t isub4
s/^ISUB4 010\([01]*\) B\([01]*\),/ISUB4 0\1 B1\2,/
t isub4
s/^ISUB4 011\([01]*\) B\([01]*\),/ISUB4 0\1 B0\2,/
t isub4
s/^ISUB4 100\([01]*\) B\([01]*\),/ISUB4 1\1 B1\2,/
t isub4
s/^ISUB4 101\([01]*\) B\([01]*\),/ISUB4 1\1 B0\2,/
t isub4
s/^ISUB4 110\([01]*\) B\([01]*\),/ISUB4 0\1 B0\2,/
t isub4
s/^ISUB4 111\([01]*\) B\([01]*\),/ISUB4 1\1 B1\2,/
t isub4
s/^ISUB4 0 B0*\([01]\+\),TMP B[01]\+ B[01]\+,/RETURN B\1,/
t return
s/^ISUB4 1 B[01]\+,TMP B\([01]\+\) B\([01]\+\),/ISUB B\2 B\1,NEG _,/
t isub+


:return
# We have a value, substitute into the caller (where the _ is)
# Value may be anything, but it may not contain a comma.
# Replace the _.
s/^RETURN \([^,]\+\),\([^,_]*\)_/\2\1/
t cycle
# If the recipient doesn't contain a _, throw the value away.
s/^RETURN [^,]\+,//
t cycle
b loop-error


:subst
# SUBST id value,...,!,
# substitute a value for {id} in the stack
# only affects up to the first ! frame
s/^SUBST \([[:alnum:]]\+\) \([^,]\+\),\([^!]*\){\1}\([^!]*\),!,/SUBST \1 \2,\3\2\4,!,/
t subst
s/^SUBST [[:alnum:]]\+ \([^,]\+\),\([^!]\+\),!,/\2,/
t cycle
s/^SUBST [[:alnum:]]\+ \([^,]\+\),!,//
t cycle
b loop-error


:print
# a simple, dumb, print
h
s/^PRINT \?\([^,]*\),.*/\1/
p
g
s/^PRINT \?\([^,]*\),//
t cycle
b loop-error


:readcmd    # read a new instruction (command) from the input stream
s/^READCMD,//
h
d


:error    # display error message and quit
/^ERROR /{
    s/^ERROR \([^,]\+\),.*/ERROR -- \1/
    q
}
b loop-error


:loop-error    # coding error; display stack and quit
#p
i\
** LOOP ERROR **
q


:exit
s/^EXIT \([^,]*\),/PRINT \1,EXIT,/
t print
s/.*//
q