Function: calc-get-operator
calc-get-operator is an autoloaded and byte-compiled function defined
in calc-map.el.gz.
Signature
(calc-get-operator MSG &optional NARGS)
Source Code
;; Defined in /usr/src/emacs/lisp/calc/calc-map.el.gz
(defun calc-get-operator (msg &optional nargs)
(setq calc-aborted-prefix nil)
(let ((inv nil) (hyp nil) (prefix nil) (forcenargs nil)
done key oper (which 0)
(msgs '( "(Press ? for help)"
"+, -, *, /, ^, %, \\, :, &, !, |, Neg"
"SHIFT + Abs, conJ, arG; maX, miN; Floor, Round; sQrt"
"SHIFT + Inv, Hyp; Sin, Cos, Tan; Exp, Ln, logB"
"Algebra + Simp, Esimp, Deriv, Integ, !, =, etc."
"Binary + And, Or, Xor, Diff; l/r/t/L/R shifts; Not, Clip"
"Conversions + Deg, Rad, HMS; Float; SHIFT + Fraction"
"Functions + Re, Im; Hypot; Mant, Expon, Scale; etc."
"Kombinatorics + Dfact, Lcm, Gcd, Choose; Random; etc."
"Time/date + newYear, Incmonth, etc."
"Vectors + Length, Row, Col, Diag, Mask, etc."
"_ = mapr/reducea, : = mapc/reduced, = = reducer"
"X or Z = any function by name; ' = alg entry; $ = stack")))
(while (not done)
(message "%s%s: %s: %s%s%s"
msg
(cond ((equal calc-mapping-dir "r") " rows")
((equal calc-mapping-dir "c") " columns")
((equal calc-mapping-dir "a") " across")
((equal calc-mapping-dir "d") " down")
(t ""))
(if forcenargs
(format "(%d arg%s)"
forcenargs (if (= forcenargs 1) "" "s"))
(nth which msgs))
(if inv "Inv " "") (if hyp "Hyp " "")
(if prefix (concat (char-to-string prefix) "-") ""))
(setq key (read-char))
(if (>= key 128) (setq key (- key 128)))
(cond ((memq key '(?\C-g ?q))
(keyboard-quit))
((memq key '(?\C-u ?\e)))
((= key ??)
(setq which (% (1+ which) (length msgs))))
((and (= key ?I) (null prefix))
(setq inv (not inv)))
((and (= key ?H) (null prefix))
(setq hyp (not hyp)))
((and (eq key prefix) (not (eq key ?v)))
(setq prefix nil))
((and (memq key '(?a ?b ?c ?f ?k ?s ?t ?u ?v ?V))
(null prefix))
(setq prefix (downcase key)))
((and (eq key ?\=) (null prefix))
(if calc-mapping-dir
(setq calc-mapping-dir (if (equal calc-mapping-dir "r")
"" "r"))
(beep)))
((and (eq key ?\_) (null prefix))
(if calc-mapping-dir
(if (string-match "map$" msg)
(setq calc-mapping-dir (if (equal calc-mapping-dir "r")
"" "r"))
(setq calc-mapping-dir (if (equal calc-mapping-dir "a")
"" "a")))
(beep)))
((and (eq key ?\:) (null prefix))
(if calc-mapping-dir
(if (string-match "map$" msg)
(setq calc-mapping-dir (if (equal calc-mapping-dir "c")
"" "c"))
(setq calc-mapping-dir (if (equal calc-mapping-dir "d")
"" "d")))
(beep)))
((and (>= key ?0) (<= key ?9) (null prefix))
(setq forcenargs (if (eq forcenargs (- key ?0)) nil (- key ?0)))
(and nargs forcenargs (/= nargs forcenargs) (>= nargs 0)
(error "Must be a %d-argument operator" nargs)))
((memq key '(?\$ ?\'))
(let* ((math-arglist nil)
(has-args nil)
(record-entry nil)
(expr (if (eq key ?\$)
(progn
(setq calc-dollar-used 1)
(if calc-dollar-values
(car calc-dollar-values)
(error "Stack underflow")))
(let* ((calc-dollar-values calc-arg-values)
(calc-dollar-used 0)
(calc-hashes-used 0)
(func (calc-do-alg-entry "" "Function: " nil
'calc-get-operator-history)))
(setq record-entry t)
(or (= (length func) 1)
(error "Bad format"))
(if (> calc-dollar-used 0)
(progn
(setq has-args calc-dollar-used
math-arglist (calc-invent-args has-args))
(math-multi-subst (car func)
(reverse math-arglist)
math-arglist))
(if (> calc-hashes-used 0)
(setq has-args calc-hashes-used
math-arglist (calc-invent-args has-args)))
(car func))))))
(if (eq (car-safe expr) 'calcFunc-lambda)
(setq oper (list "$" (- (length expr) 2) expr)
done t)
(or has-args
(progn
(calc-default-formula-arglist expr)
(setq record-entry t
math-arglist (sort math-arglist 'string-lessp))
(if calc-verify-arglist
(setq math-arglist (read-from-minibuffer
"Function argument list: "
(if math-arglist
(prin1-to-string math-arglist)
"()")
minibuffer-local-map
t)))
(setq math-arglist (mapcar (lambda (x)
(list 'var
x
(intern
(concat
"var-"
(symbol-name x)))))
math-arglist))))
(setq oper (list "$"
(length math-arglist)
(append '(calcFunc-lambda) math-arglist
(list expr)))
done t))
(if record-entry
(calc-record (nth 2 oper) "oper"))))
((setq oper (assq key (nth (if inv (if hyp 3 1) (if hyp 2 0))
(if prefix
(symbol-value
(intern (format "calc-%c-oper-keys"
prefix)))
calc-oper-keys))))
(if (eq (nth 1 oper) 'user)
(let ((func (intern
(completing-read "Function name: "
obarray 'fboundp
nil "calcFunc-"))))
(if (or forcenargs nargs)
(setq oper (list "z" (or forcenargs nargs) func)
done t)
(if (fboundp func)
(let* ((defn (symbol-function func)))
(and (symbolp defn)
(setq defn (symbol-function defn)))
(if (eq (car-safe defn) 'lambda)
(let ((args (nth 1 defn))
(nargs 0))
(while (not (memq (car args) '(&optional
&rest nil)))
(setq nargs (1+ nargs)
args (cdr args)))
(setq oper (list "z" nargs func)
done t))
(error
"Function is not suitable for this operation")))
(message "Number of arguments: ")
(let ((nargs (read-char)))
(if (and (>= nargs ?0) (<= nargs ?9))
(setq oper (list "z" (- nargs ?0) func)
done t)
(beep))))))
(if (or (and (eq prefix ?v) (memq key '(?A ?I ?M ?O ?R ?U)))
(and (eq prefix ?a) (eq key ?M)))
(let* ((dir (cond ((and (equal calc-mapping-dir "")
(string-match "map$" msg))
(setq calc-mapping-dir "r")
" rows")
((equal calc-mapping-dir "r") " rows")
((equal calc-mapping-dir "c") " columns")
((equal calc-mapping-dir "a") " across")
((equal calc-mapping-dir "d") " down")
(t "")))
(calc-mapping-dir (and (memq (nth 2 oper)
'(calcFunc-map
calcFunc-reduce
calcFunc-rreduce))
""))
(oper2 (calc-get-operator
(format "%s%s, %s%s" msg dir
(substring (symbol-name (nth 2 oper))
9)
(if (eq key ?I) " (mult)" ""))
(cdr (assq (nth 2 oper)
'((calcFunc-reduce . 2)
(calcFunc-rreduce . 2)
(calcFunc-accum . 2)
(calcFunc-raccum . 2)
(calcFunc-nest . 2)
(calcFunc-anest . 2)
(calcFunc-fixp . 2)
(calcFunc-afixp . 2))))))
(oper3 (if (eq (nth 2 oper) 'calcFunc-inner)
(calc-get-operator
(format "%s%s, inner (add)" msg dir))
'(0 0 0)))
(args nil)
(nargs (if (> (nth 1 oper) 0)
(nth 1 oper)
(car oper2)))
(n nargs)
(p calc-arg-values))
(while (and p (> n 0))
(or (math-expr-contains (nth 1 oper2) (car p))
(math-expr-contains (nth 1 oper3) (car p))
(setq args (nconc args (list (car p)))
n (1- n)))
(setq p (cdr p)))
(setq oper (list "" nargs
(append
'(calcFunc-lambda)
args
(list (math-build-call
(intern
(concat
(symbol-name (nth 2 oper))
calc-mapping-dir))
(cons (math-calcFunc-to-var
(nth 1 oper2))
(if (eq key ?I)
(cons
(math-calcFunc-to-var
(nth 1 oper3))
args)
args))))))
done t))
(setq done t))))
(t (beep))))
(and nargs (>= nargs 0)
(/= nargs (nth 1 oper))
(error "Must be a %d-argument operator" nargs))
(append (if forcenargs
(cons forcenargs (cdr (cdr oper)))
(cdr oper))
(list
(let ((name (concat (if inv "I" "") (if hyp "H" "")
(if prefix (char-to-string prefix) "")
(char-to-string key))))
(if (> (length name) 3)
(substring name 0 3)
name))))))