398 lines
13 KiB
Forth
Executable File
398 lines
13 KiB
Forth
Executable File
#! /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
|