home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload
/
ShartewareOverload.cdr
/
wp
/
brcalc.zip
/
CALC.M
next >
Wrap
Text File
|
1984-11-02
|
14KB
|
772 lines
;;; calculator program
;;; written by Mark U. Edwards
;;; 11-02-84
#define MAXSTRING 16
(macro calc
(
(int c_orig_buffer
c_acc
c_ans_buff
c_base
c_op
c_first_digit
c_stage
c_carry
c_number_in
c_display
c_tape_on
c_line
c_digits
)
(string c_number_out)
(global c_number_in
c_number_out
c_acc
c_ans_buff
c_base
c_op
c_first_digit
c_display
c_tape_on
c_line
c_digits
c_stage
c_carry
)
(pause_on_error)
(= c_ans_buff (create_buffer "Calculator" "$c$.tmp" 1))
(= c_orig_buffer (inq_buffer))
(set_buffer c_ans_buff)
(create_window 52 21 77 19 "F1 for Help")
(attach_buffer c_ans_buff)
(refresh)
(keyboard_push)
(assign_to_key "#27" "exit")
(assign_to_key "#48" "c_n_0")
(assign_to_key "#49" "c_n_1")
(assign_to_key "#50" "c_n_2")
(assign_to_key "#51" "c_n_3")
(assign_to_key "#52" "c_n_4")
(assign_to_key "#53" "c_n_5")
(assign_to_key "#54" "c_n_6")
(assign_to_key "#55" "c_n_7")
(assign_to_key "#56" "c_n_8")
(assign_to_key "#57" "c_n_9")
(assign_to_key "#97" "c_n_A")
(assign_to_key "#65" "c_n_A")
(assign_to_key "#98" "c_n_B")
(assign_to_key "#66" "c_n_B")
(assign_to_key "#99" "c_n_C")
(assign_to_key "#67" "c_n_C")
(assign_to_key "#100" "c_n_D")
(assign_to_key "#68" "c_n_D")
(assign_to_key "#101" "c_n_E")
(assign_to_key "#69" "c_n_E")
(assign_to_key "#102" "c_n_F")
(assign_to_key "#70" "c_n_F")
(assign_to_key "%#46" "c_clr_ent")
(assign_to_key "%#30" "c_clr_acc")
(assign_to_key "#13" "c_equals")
(assign_to_key "%#48" "c_to_bin")
(assign_to_key "%#32" "c_to_dec")
(assign_to_key "%#35" "c_to_hex")
(assign_to_key "#43" "c_plus")
(assign_to_key "#42" "c_times")
(assign_to_key "#45" "c_minus")
(assign_to_key "#47" "c_div")
(assign_to_key "#37" "c_mod")
(assign_to_key "#35" "c_plus_minus")
(assign_to_key "%#59" "c_help")
(assign_to_key "%#20" "c_tape")
(assign_to_key "%#25" "c_print")
(= c_acc 0)
(= c_number_in 0) ;;; initialize
(= c_tape_on 0)
(= c_base 10)
(= c_line 1)
(= c_digits 0)
(c_print_base)
(move_abs c_line 16)
(= c_op 0) ;;; no operation at present
(= c_first_digit 0) ;;; first digit not yet typed
(= c_stage 1) ;;; entering first number
(= c_display 1) ;;; displaying c_number_in
(process)
(keyboard_pop)
(delete_window)
(delete_buffer c_ans_buff)
(set_buffer c_orig_buffer)
)
)
(macro _num
(
(string digit)
(int d)
(get_parm 0 digit)
(get_parm 1 d)
(if (== c_number_in 0)
(
(move_abs c_line 19)
(delete_char)
(insert " ")
(= c_digits 0)
)
)
(if (== c_first_digit 0) ;;; first digit of new num
(
(= c_number_in 0)
(c_print_base)
(= c_first_digit 1)
(= c_digits 0)
)
)
(= c_digits (+ c_digits 1))
(if (|| (&& (== c_base 2) (<= c_digits 16))
(|| (&& (== c_base 10) (<= c_digits 5))
(&& (== c_base 16) (<= c_digits 4))))
(
(if (== c_stage 3)
(c_clr_acc)
)
(move_abs c_line 3)
(delete_char)
(move_abs c_line 19)
(= c_display 1)
(insert digit)
(move_abs c_line 19)
(= c_number_in (+ (* c_number_in c_base) d))
)
;else
(beep)
)
)
)
(macro c_n_0
(
(_num "0" 0)
)
)
(macro c_n_1
(
(_num "1" 1)
)
)
(macro c_n_2
(
(if (> c_base 2)
(_num "2" 2)
;else
(beep)
)
)
)
(macro c_n_3
(
(if (> c_base 2)
(_num "3" 3)
;else
(beep)
)
)
)
(macro c_n_4
(
(if (> c_base 2)
(_num "4" 4)
;else
(beep)
)
)
)
(macro c_n_5
(
(if (> c_base 2)
(_num "5" 5)
;else
(beep)
)
)
)
(macro c_n_6
(
(if (> c_base 2)
(_num "6" 6)
;else
(beep)
)
)
)
(macro c_n_7
(
(if (> c_base 2)
(_num "7" 7)
;else
(beep)
)
)
)
(macro c_n_8
(
(if (> c_base 2)
(_num "8" 8)
;else
(beep)
)
)
)
(macro c_n_9
(
(if (> c_base 2)
(_num "9" 9)
;else
(beep)
)
)
)
(macro c_n_A
(
(if (> c_base 10)
(_num "A" 10)
;else
(beep)
)
)
)
(macro c_n_B
(
(if (> c_base 10)
(_num "B" 11)
;else
(beep)
)
)
)
(macro c_n_C
(
(if (> c_base 10)
(_num "C" 12)
;else
(beep)
)
)
)
(macro c_n_D
(
(if (> c_base 10)
(_num "D" 13)
;else
(beep)
)
)
)
(macro c_n_E
(
(if (> c_base 10)
(_num "E" 14)
;else
(beep)
)
)
)
(macro c_n_F
(
(if (> c_base 10)
(_num "F" 15)
;else
(beep)
)
)
)
(macro c_clr_ent
(
(move_abs c_line 1)
(delete_line)
(= c_number_in 0)
(c_print_base)
(= c_digits 0)
(move_abs c_line 19)
)
)
(macro c_clr_acc
(
(= c_acc 0)
(c_clr_ent)
(= c_stage 1)
(= c_op 0)
(move_abs 1 1)
(drop_anchor)
(end_of_buffer)
(delete_block)
(= c_line 1)
(c_print_base)
(move_abs c_line 19)
)
)
(macro c_print_result
(
(string num)
(get_parm 0 num)
(move_abs c_line 3)
(delete_to_eol)
(if (< (strlen num) 20)
(move_abs c_line (- 20 (strlen num)))
;else
(
(move_abs c_line 5)
(= num "- Error -")
(beep)
)
)
(insert num)
(move_abs c_line 19)
)
)
(macro c_to_bin
(
(= c_line (+ c_line 1))
(message "Converting...")
(if (== c_display 1)
(= c_number_out (c_dtob c_number_in))
;else
(= c_number_out (c_dtob c_acc))
)
(= c_base 2)
(message "")
(= c_digits (strlen c_number_out))
(c_print_result c_number_out)
(c_print_base)
(move_abs c_line 19)
)
)
(macro c_to_dec
(
(= c_line (+ c_line 1))
(message "Converting...")
(if (== c_display 1)
(sprintf c_number_out "%d" c_number_in)
;else
(sprintf c_number_out "%d" c_acc)
)
(= c_base 10)
(message "")
(= c_digits (strlen c_number_out))
(c_print_result c_number_out)
(c_print_base)
(move_abs c_line 19)
)
)
(macro c_to_hex
(
(= c_line (+ c_line 1))
(message "Converting...")
(if (== c_display 1)
(= c_number_out (c_dtoh c_number_in))
;else
(= c_number_out (c_dtoh c_acc))
)
(= c_base 16)
(message "")
(= c_digits (strlen c_number_out))
(c_print_result c_number_out)
(c_print_base)
(move_abs c_line 19)
)
)
(macro c_print_base
(
(move_abs c_line 21)
(delete_char)
(delete_char)
(delete_char)
(if (== c_base 2)
(insert "Bin")
;else
(if (== c_base 10)
(insert "Dec")
;else
(insert "Hex")
)
)
(move_abs c_line 19)
(refresh)
)
)
(macro c_print_acc
(
(= c_display 2) ;;; displaying accumulator
(if (!= c_base 10)
(
(if (== c_base 2)
(= c_number_out (c_dtob c_acc))
;else
(= c_number_out (c_dtoh c_acc))
)
)
;else
(
(sprintf c_number_out "%d" c_acc)
)
)
(c_print_result c_number_out)
)
)
(macro c_print_number_in
(
(if (!= c_base 10)
(
(if (== c_base 2)
(= c_number_out (c_dtob c_number_in))
;else
(= c_number_out (c_dtoh c_number_in))
)
)
;else
(
(sprintf c_number_out "%d" c_number_in)
)
)
(c_print_result c_number_out)
)
)
(macro c_print_ans
(
(if (== c_op 1)
(= c_acc (+ c_acc c_number_in))
)
(if (== c_op 2)
(= c_acc (- c_acc c_number_in))
)
(if (== c_op 3)
(= c_acc (* c_acc c_number_in))
)
(if (== c_op 4)
(if (!= c_number_in 0)
(= c_acc (/ c_acc c_number_in))
;else
(
(message "Attempting to div by 0!")
(beep)
(c_clr_acc)
)
)
)
(if (== c_op 5)
(if (!= c_number_in 0)
(= c_acc (% c_acc c_number_in))
;else
(
(message "Attempting to div by 0!")
(beep)
(c_clr_acc)
)
)
)
(= c_number_in 0)
(c_print_acc)
(c_print_base)
(message "")
)
)
(macro c_equals
(
(= c_line (+ c_line 1))
(move_abs c_line 2)
(delete_char)
(insert "=")
(c_print_ans)
(= c_stage 3) ;;; signals that already calculated
(= c_first_digit 0)
)
)
(macro c_plus
(
(if (== c_stage 2)
(c_equals)
)
(= c_line (+ c_line 1))
(move_abs c_line 2)
(delete_char)
(insert "+")
(if (== c_stage 1)
(= c_acc c_number_in)
)
(= c_op 1) ;;; next operation is addition
(= c_stage 2)
(= c_first_digit 0)
)
)
(macro c_times
(
(if (== c_stage 2)
(c_equals)
)
(= c_line (+ c_line 1))
(move_abs c_line 2)
(delete_char)
(insert "*")
(if (== c_stage 2)
(c_print_ans)
)
(if (== c_stage 1)
(= c_acc c_number_in)
)
(= c_op 3) ;;; next operation is multiplication
(= c_stage 2)
(= c_first_digit 0)
)
)
(macro c_minus
(
(if (== c_stage 2)
(c_equals)
)
(= c_line (+ c_line 1))
(move_abs c_line 2)
(delete_char)
(insert "-")
(if (== c_stage 2)
(c_print_ans)
)
(if (== c_stage 1)
(= c_acc c_number_in)
)
(= c_op 2) ;;; next operation is subtraction
(= c_stage 2)
(= c_first_digit 0)
)
)
(macro c_div
(
(if (== c_stage 2)
(c_equals)
)
(= c_line (+ c_line 1))
(move_abs c_line 2)
(delete_char)
(insert "/")
(if (== c_stage 2)
(c_print_ans)
)
(if (== c_stage 1)
(= c_acc c_number_in)
)
(= c_op 4) ;;; next operation is division
(= c_stage 2)
(= c_first_digit 0)
)
)
(macro c_mod
(
(if (== c_stage 2)
(c_equals)
)
(= c_line (+ c_line 1))
(move_abs c_line 2)
(delete_char)
(insert "%")
(if (== c_stage 2)
(c_print_ans)
)
(if (== c_stage 1)
(= c_acc c_number_in)
)
(= c_op 5) ;;; next operation is modulo
(= c_stage 2)
(= c_first_digit 0)
)
)
(macro c_dtoh
(
(int n)
(get_parm 0 n)
(string num)
(= num (c_dtob n)) ;;; first convert to binary string
(= num (c_btoh num)) ;;; then convert to hex string
(returns num)
)
)
(macro c_dtob
(
(string r remain)
(int i n rmdr neg)
(get_parm 0 n)
(= r "")
(= neg 0) ;;; set neg flag off
(if (< n 0)
(
(= n (+ n 1)) ;;; adjust for twos complement
(= neg 1) ;;; signal that negative number
(= n (* n -1))
)
)
(= rmdr 0)
(= i 0)
(while (!= n 0)
(
(= i (+ i 1))
(message "Binary digit %d" i)
(= rmdr (% n 2))
(= n (/ n 2))
(sprintf remain "%d" rmdr)
(= r (+ remain r))
)
)
(if (== neg 1)
(= r (ones_complement r))
)
(if (== r "")
(= r "0")
)
(returns r)
)
)
(macro c_btoh ;;; binary to hex, using strings
(
(string r n t)
(int i len j nn)
(get_parm 0 n)
(= len (strlen n))
(= j (% len 4))
(if (> j 0) (= n (+ (substr "000" j) n))) ;;; make even packets
(= len (strlen n))
(= i 1)
(while (<= i len)
(
(= t (substr n i 4)) ;;; pick up hex packet
(= nn 0)
(= j 1)
(while (<= j 4)
(
(= nn (* nn 2))
(if (== "1" (substr t j 1)) (= nn (+ nn 1)))
(= j (+ j 1))
)
)
(= r (+ r (substr "0123456789ABCDEF" (+ nn 1) 1)))
(= i (+ i 4))
)
)
(returns r)
)
)
(macro ones_complement
(
(string n t)
(int i len)
(get_parm 0 n)
(= n (+ "0" n))
(= len (strlen n))
(= t "")
(= i 1)
(while (<= i len) ;;; ones complement
(
(if (== "0" (substr n i 1))
(= t (+ t "1"))
;else
(= t (+ t "0"))
)
(= i (+ i 1))
)
)
(while (< len MAXSTRING) ;;; fill out to MAXSTRING digits
(
(= t (+ "1" t))
(= len (+ len 1))
)
)
(returns t)
)
)
(macro c_plus_minus
(
(= c_line (+ c_line 1))
(move_abs c_line 2)
(delete_char)
(insert "#")
(if (== c_display 1)
(
(= c_number_in (* c_number_in -1))
(c_print_number_in)
)
;else
(
(= c_acc (* c_acc -1))
(c_print_acc)
)
)
(c_print_base)
)
)
(macro c_help
(
(int c_help_buf
c_calc_buf
)
(= c_help_buf (create_buffer "Help" "$h$.tmp" 1))
(= c_calc_buf (inq_buffer))
(set_buffer c_help_buf)
(create_window 2 16 50 1 "ESC to exit from Help")
(attach_buffer c_help_buf)
(refresh)
(keyboard_push)
(assign_to_key "#27" "exit")
(move_abs 1 1)
(insert " 16 Bit Calculator: range 32767 to -32768\n\n")
(insert " NumLck must be on for Number Pad to work\n")
(insert " Operations\n")
(insert " + plus, - minus, * times, / divide\n")
(insert " % modulo, # changes sign\n")
(insert " ALT-C Clear Entry ALT-A clear Accumulator\n")
(insert " ALT-T toggle Tape ALT-P Print tape\n")
(insert " Changing Base\n")
(insert " ALT-D Decimal [Digits 0..9]\n")
(insert " ALT-B Binary [Digits 0..1]\n")
(insert " ALT-H Hex [Digits 0..9, A..F]\n\n")
(insert " ESC to exit from Calculator")
(refresh)
(process)
(keyboard_pop)
(delete_window)
(delete_buffer c_help_buf)
(set_buffer c_calc_buf)
)
)
(macro c_tape
(
(if (== c_tape_on 0)
(
(delete_window)
(create_window 52 21 77 2 "F1 for Help")
(attach_buffer c_ans_buff)
(refresh)
(= c_tape_on 1)
;(change_window 2) ;;; correct direction??
)
; else
(
;(change_window 0) ;;; correct direction??
(delete_window)
(= c_tape_on 0)
(create_window 52 21 77 19 "F1 for Help")
(attach_buffer c_ans_buff)
)
)
)
)
(macro c_print
(
(int x y)
(inq_position y x)
(move_abs 1 1)
(drop_anchor)
(end_of_buffer)
(print)
(move_abs y x)
)
)