#! /usr/pkg/bin/gforth-fast
\ rpn-n0.cgi - RPN Model n0 calculator CGI script
\ Copyright 2013 David Meyer <papa@sdf.org> +JMJ
\ Copying and distribution of this file, with or without
\ modification, are permitted in any medium without royalty
\ provided the copyright notice and this notice are preserved.
\ This file is offered as-is, without any warranty.
\ Global variables ...
variable register-x
variable register-y
variable register-z
variable register-t
variable register-s
variable mode \ 0: ENTER mode; next number will replace X
\ 1: Op mode; next number will push X
\ 2: Input mode; inputing number
variable error
variable query-adr
variable query-len
variable button-adr
variable button-len
\ Level 3 ...
: push-stack ( -- )
register-z @ register-t !
register-y @ register-z !
register-x @ register-y !
;
: rot4 ( a b c d -- d a b c ) swap >r rot rot r> ;
: trunc-fld-key ( c-field ufield ukey -- c-value uvalue )
dup >r - swap r> chars + swap
;
: value-str-chars ( addr u1 -- u2 )
over swap [char] & scan drop swap -
;
\ Level 2 ...
: init-state ( -- )
0 register-x !
0 register-y !
0 register-z !
0 register-t !
0 register-s !
0 mode !
0 button-len !
;
: nprint ( n -- )
s>d swap over dabs <<# #s rot sign #> type #>>
;
: parse-num-fld { c-key ulen a-reg -- }
query-adr @ query-len @ c-key ulen search if
ulen trunc-fld-key
over swap value-str-chars s>number? if
d>s a-reg !
else
2drop 0 a-reg !
then
else
0 a-reg !
then
;
: parse-str-fld { c-key ulen a-value a-vlen -- }
query-adr @ query-len @ c-key ulen search if
ulen trunc-fld-key
over swap value-str-chars
a-vlen ! a-value !
else
2drop 0 a-vlen !
then
;
: pressed-asterisk ( -- )
register-y @ register-x @ *
register-x !
register-z @ register-y !
register-t @ register-z !
1 mode !
;
: pressed-clr ( -- )
0 register-x !
0 register-y !
0 register-z !
0 register-t !
0 register-s !
0 mode !
;
: pressed-clx ( -- )
\ Or should this act like pop/drop?
0 register-x !
0 mode !
;
: pressed-enter ( -- )
push-stack
0 mode !
;
: pressed-minus ( -- )
register-y @ register-x @ -
register-x !
register-z @ register-y !
register-t @ register-z !
1 mode !
;
: pressed-mod ( -- )
register-x @ 0= if
true error !
0 mode !
else
register-y @ register-x @ mod
register-x !
register-z @ register-y !
register-t @ register-z !
1 mode !
then
;
: pressed-neg ( -- )
register-x @ -1 * register-x !
1 mode !
;
: pressed-num ( u -- )
mode @ case
0 of
2 mode !
endof
1 of
push-stack
2 mode !
endof
2 of
register-x @ 10 * +
endof
endcase
register-x !
;
: pressed-plus ( -- )
register-y @ register-x @ +
register-x !
register-z @ register-y !
register-t @ register-z !
1 mode !
;
: pressed-rcl ( -- )
push-stack
register-s @ register-x !
1 mode !
;
: pressed-rld ( -- )
register-x @
register-y @ register-x !
register-z @ register-y !
register-t @ register-z !
register-t !
1 mode !
;
: pressed-slash ( -- )
register-x @ 0= if
true error !
0 mode !
else
register-y @ register-x @ /
register-x !
register-z @ register-y !
register-t @ register-z !
1 mode !
then
;
: pressed-sto ( -- )
register-x @ register-s !
1 mode !
;
: pressed-swp ( -- )
register-x @ register-y @
register-x ! register-y !
1 mode !
;
\ Level 1 ...
: calculate ( -- )
button-len @ 0<> if
true case
button-adr @ button-len @ s" ENTER" str= of
pressed-enter
endof
button-adr @ button-len @ s" mod" str= of
pressed-mod
endof
button-adr @ button-len @ s" clx" str= of
pressed-clx
endof
button-adr @ button-len @ s" clr" str= of
pressed-clr
endof
button-adr @ button-len @ s" swp" str= of
pressed-swp
endof
button-adr @ button-len @ s" %2F" str= of
pressed-slash
endof
button-adr @ button-len @ s" rld" str= of
pressed-rld
endof
button-adr @ button-len @ s" *" str= of
pressed-asterisk
endof
button-adr @ button-len @ s" sto" str= of
pressed-sto
endof
button-adr @ button-len @ s" -" str= of
pressed-minus
endof
button-adr @ button-len @ s" rcl" str= of
pressed-rcl
endof
button-adr @ button-len @ s" neg" str= of
pressed-neg
endof
button-adr @ button-len @ s" %2B" str= of
pressed-plus
endof
button-adr @ button-len @ s>unumber?
rot rot d>s >r of
r> pressed-num
endof
endcase
then
;
: parse-query ( -- )
s" QUERY_STRING" getenv
dup 0= if
init-state
else
query-len ! query-adr !
s" s=" register-s parse-num-fld
s" t=" register-t parse-num-fld
s" z=" register-z parse-num-fld
s" y=" register-y parse-num-fld
s" x=" register-x parse-num-fld
s" mode=" mode parse-num-fld
s" button=" button-adr button-len parse-str-fld
then
;
: print-page ( -- )
." Content-Type: text/html"
cr cr .\" <!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">"
." <html><head><title>RPN Calculator Model n0</title>"
.\" <link rel=\"stylesheet\" type=\"text/css\" href=\"/style/rpn.css\">"
.\" <meta http-equiv=\"Content-type\" content=\"text/html;charset=UTF-8\"></head>"
.\" <body><h1>RPN Calculator Model n0</h1><form id=\"calc\" method=\"get\" action=\"rpn-n0.cgi\"><div class=\""
error @ if .\" disperr\">" else .\" disp\">" then
register-x @ nprint
.\" </div><table><tr><td colspan=2><input class=\"buttontw2\" type=\"submit\" name=\"button\" value=\"ENTER\" /></td>"
.\" <td><input class=\"buttontw\" type=\"submit\" name=\"button\" value=\"clx\" /></td>"
.\" <td><input class=\"buttontw\" type=\"submit\" name=\"button\" value=\"clr\" /></td></tr>"
.\" <tr><td><input class=\"buttontw\" type=\"submit\" name=\"button\" value=\"-\" /></td>"
.\" <td><input class=\"buttonwb\" type=\"submit\" name=\"button\" value=\"7\" /></td>"
.\" <td><input class=\"buttonwb\" type=\"submit\" name=\"button\" value=\"8\" /></td>"
.\" <td><input class=\"buttonwb\" type=\"submit\" name=\"button\" value=\"9\" /></td></tr>"
.\" <tr><td><input class=\"buttontw\" type=\"submit\" name=\"button\" value=\"+\" /></td>"
.\" <td><input class=\"buttonwb\" type=\"submit\" name=\"button\" value=\"4\" /></td>"
.\" <td><input class=\"buttonwb\" type=\"submit\" name=\"button\" value=\"5\" /></td>"
.\" <td><input class=\"buttonwb\" type=\"submit\" name=\"button\" value=\"6\" /></td></tr>"
.\" <tr><td><input class=\"buttontw\" type=\"submit\" name=\"button\" value=\"*\" /></td>"
.\" <td><input class=\"buttonwb\" type=\"submit\" name=\"button\" value=\"1\" /></td>"
.\" <td><input class=\"buttonwb\" type=\"submit\" name=\"button\" value=\"2\" /></td>"
.\" <td><input class=\"buttonwb\" type=\"submit\" name=\"button\" value=\"3\" /></td></tr>"
.\" <tr><td><input class=\"buttontw\" type=\"submit\" name=\"button\" value=\"/\" /></td>"
.\" <td><input class=\"buttontw\" type=\"submit\" name=\"button\" value=\"mod\" /></td>"
.\" <td><input class=\"buttonwb\" type=\"submit\" name=\"button\" value=\"0\" /></td>"
.\" <td><input class=\"buttontw\" type=\"submit\" name=\"button\" value=\"neg\" /></td></tr>"
.\" <tr><td><input class=\"buttonbw\" type=\"submit\" name=\"button\" value=\"rld\" /></td>"
.\" <td><input class=\"buttonbw\" type=\"submit\" name=\"button\" value=\"swp\" /></td>"
.\" <td><input class=\"buttonbw\" type=\"submit\" name=\"button\" value=\"sto\" /></td>"
.\" <td><input class=\"buttonbw\" type=\"submit\" name=\"button\" value=\"rcl\" /></td></tr></table>"
.\" <div class=\"stat\">"
.\" S<input readonly name=\"s\" value=\""
register-s @ nprint
.\" \" /><br />"
.\" T<input readonly name=\"t\" value=\""
register-t @ nprint
.\" \" /><br />"
.\" Z<input readonly name=\"z\" value=\""
register-z @ nprint
.\" \" /><br />"
.\" Y<input readonly name=\"y\" value=\""
register-y @ nprint
.\" \" /><br />"
.\" X<input readonly name=\"x\" value=\""
register-x @ nprint
\ .\" \" /><input type=\"hidden\" name=\"input\" value=\""
\ input @ nprint
.\" \" /><input type=\"hidden\" name=\"mode\" value=\""
mode @ nprint
.\" \" /></div><div class=\"label\">RPN CALCULATOR n0</div></form>"
.\" <div id=\"inst\">"
." <h3>Instructions</h3>"
.\" <p class=\"instp\">Enter numbers separated by "
." ENTER key, then press operation key to display the result "
." (= key is not needed). Numbers are stored in a "
." LIFO stack (registers X, Y, Z, T). Display shows the last "
." number (input or result) on the stack (register X). "
." Register S is for storing constants.</p>"
.\" <p class=\"instp\"><strong>Stack effects:</strong> "
." (<em>x, y, z, t, s,</em> are current register values.)</p>"
.\" <table><tr><td></td><td class=\"instblk\"><em>op</em></tr>"
.\" <tr><td class=\"instblk\"><input class=\"buttontwj\" type=\"button\" disabled value=\"ENTER\" /></td>"
.\" <td class=\"instblk\">(<input class=\"buttontwj\" type=\"button\" disabled value=\"+\" /><input class=\"buttontwj\" type=\"button\" disabled value=\"-\" /><input class=\"buttontwj\" type=\"button\" disabled value=\"*\" /><input class=\"buttontwj\" type=\"button\" disabled value=\"/\" /><input class=\"buttontwj\" type=\"button\" disabled value=\"mod\" />)</td>"
.\" <td class=\"instblk\"><input class=\"buttontwj\" type=\"button\" disabled value=\"neg\" /></td>"
.\" <td class=\"instblk\"><input class=\"buttonbwj\" type=\"button\" disabled value=\"sto\" /></td>"
.\" <td class=\"instblk\"><input class=\"buttonbwj\" type=\"button\" disabled value=\"rcl\" /></td></tr>"
.\" <tr><td class=\"instblk\"><em>z</em> → T<br /><em>y</em> → Z<br /><em>x</em> → Y,X</td>"
.\" <td class=\"instblk\"><em>t</em> → T,Z<br /><em>z</em> → Y<br /><em>y op x</em> → X</td>"
.\" <td class=\"instblk\"><em>-x</em> → X</td>"
.\" <td class=\"instblk\"><em>x</em> → S</td>"
.\" <td class=\"instblk\"><em>z</em> → T<br /><em>y</em> → Z<br /><em>x</em> → Y<br /><em>s</em> → X</td></tr></table>"
.\" <table><tr><td class=\"instblk\"><input class=\"buttonbwj\" type=\"button\" disabled value=\"rld\" /></td>"
.\" <td class=\"instblk\"><input class=\"buttonbwj\" type=\"button\" disabled value=\"swp\" /></td>"
.\" <td class=\"instblk\"><input class=\"buttontwj\" type=\"button\" disabled value=\"clx\" /></td>"
.\" <td class=\"instblk\"><input class=\"buttontwj\" type=\"button\" disabled value=\"clr\" /></td></tr>"
.\" <tr><td class=\"instblk\"><em>x</em> → T<br /><em>t</em> → Z<br /><em>z</em> → Y<br /><em>y</em> → X</td>"
.\" <td class=\"instblk\"><em>x</em> → Y<br /><em>y</em> → X</td>"
.\" <td class=\"instblk\">0 → X</td>"
.\" <td class=\"instblk\">0 → X,Y,Z,T,S</td></tr></table>"
.\" <p class=\"instp\"><strong>Precision and Fractional Arithmetic:</strong> "
." n0 processes all numbers as single-precision signed integers with a "
." range of -2,147,483,648 to 2,147,483,647. "
." It is possible to perform calculations with fractional "
." numbers by using the technique of "
." <strong>fixed-point arithmetic</strong>: The user multiplies input "
." operands and mentally divides results by appropriate powers of 10 to "
." obtain the required precision.</p></div>"
.\" <p><a href=\"rpn-n0-cgi.fs\">Program source.</a></p>"
." <p>Model n0 is the first of a series of online "
." calculators inspired by the Hewlett-Packard "
." line of slide rule pocket calculators "
." produced in the 1970s (n0 was designed "
." with refrence to the "
.\" <a href=\"http://www.hpmuseum.org/hp35.htm\">HP-35</a> "
." in particular) and the "
.\" <a href=\"http://www.forth.org/whatis.html\">"
." Forth programming language</a> invented by "
.\" <a href=\"http://www.colorforth.com/bio.html\">"
." Chuck Moore</a> in 1968.</p>"
." <p>RPN Calculator Model n0 is powered by "
.\" <a href=\"http://bernd-paysan.de/gforth.html\">Gforth</a> "
s" gforth" environment? if type space then
." on the MetaArray host at "
.\" <a href=\"http://www.sdf.org\">SDF</a>.</p>"
.\" <p class=\"ctr\"><a href=\"http://www.catholic.org/clife/prayers/prayer.php?p=1378\">+JMJ</a></p></div></body></html>"
;
\ Level 0: Main driver ...
false error !
parse-query
calculate
print-page
bye
\ Emacs metadata ...
\ Local variables:
\ mode: forth
\ End:
\ +JMJ