emacs-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Emacs-diffs] Changes to emacs/lisp/calc/calc-map.el


From: Colin Walters
Subject: [Emacs-diffs] Changes to emacs/lisp/calc/calc-map.el
Date: Mon, 19 Nov 2001 02:36:14 -0500

Index: emacs/lisp/calc/calc-map.el
diff -u emacs/lisp/calc/calc-map.el:1.2 emacs/lisp/calc/calc-map.el:1.3
--- emacs/lisp/calc/calc-map.el:1.2     Wed Nov 14 04:05:18 2001
+++ emacs/lisp/calc/calc-map.el Mon Nov 19 02:36:14 2001
@@ -1,6 +1,9 @@
-;; Calculator for GNU Emacs, part II [calc-map.el]
+;;; calc-map.el --- higher-order functions for Calc
+
 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc.
-;; Written by Dave Gillespie, address@hidden
+
+;; Author: David Gillespie <address@hidden>
+;; Maintainer: Colin Walters <address@hidden>
 
 ;; This file is part of GNU Emacs.
 
@@ -19,7 +22,9 @@
 ;; file named COPYING.  Among other things, the copyright notice
 ;; and this notice must be preserved on all copies.
 
+;;; Commentary:
 
+;;; Code:
 
 ;; This file is autoloaded from calc-ext.el.
 (require 'calc-ext)
@@ -140,6 +145,8 @@
                                     nargs
                                     (1+ calc-dollar-used))))))))
 
+(defvar calc-verify-arglist t)
+(defvar calc-mapping-dir nil)
 (defun calc-map-stack ()
   "This is meant to be called by calc-keypad mode."
   (interactive)
@@ -191,259 +198,6 @@
                               (calc-top-list-n
                                2 (+ 1 mul-used calc-dollar-used)))))))
 
-;;; Return a list of the form (nargs func name)
-(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* ((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: ")))
-                             (setq record-entry t)
-                             (or (= (length func) 1)
-                                 (error "Bad format"))
-                             (if (> calc-dollar-used 0)
-                                 (progn
-                                   (setq has-args calc-dollar-used
-                                         arglist (calc-invent-args has-args))
-                                   (math-multi-subst (car func)
-                                                     (reverse arglist)
-                                                     arglist))
-                               (if (> calc-hashes-used 0)
-                                   (setq has-args calc-hashes-used
-                                         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
-                            arglist (sort arglist 'string-lessp))
-                      (if calc-verify-arglist
-                          (setq arglist (read-from-minibuffer
-                                         "Function argument list: "
-                                         (if arglist
-                                             (prin1-to-string arglist)
-                                           "()")
-                                         minibuffer-local-map
-                                         t)))
-                      (setq arglist (mapcar (function
-                                             (lambda (x)
-                                               (list 'var
-                                                     x
-                                                     (intern
-                                                      (concat
-                                                       "var-"
-                                                       (symbol-name x))))))
-                                            arglist))))
-                (setq oper (list "$"
-                                 (length arglist)
-                                 (append '(calcFunc-lambda) 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
-                                             (substring
-                                              (symbol-name (nth 2 oper))
-                                              9)))
-                                  '(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))))))
-(setq calc-verify-arglist t)
-(setq calc-mapping-dir nil)
-
 (defconst calc-oper-keys '( ( ( ?+ 2 calcFunc-add )
                              ( ?- 2 calcFunc-sub )
                              ( ?* 2 calcFunc-mul )
@@ -497,8 +251,8 @@
                              ( ?T 1 calcFunc-arctanh )
                              ( ?L 1 calcFunc-exp10 )
                              ( ?E 1 calcFunc-log10 )
-                             ( ?| 2 calcFunc-appendrev ) )
-))
+                             ( ?| 2 calcFunc-appendrev ) )))
+
 (defconst calc-a-oper-keys '( ( ( ?a 3 calcFunc-apart )
                                ( ?b 3 calcFunc-subst )
                                ( ?c 2 calcFunc-collect )
@@ -550,8 +304,8 @@
                                ( ?S 2 calcFunc-fsolve )
                                ( ?X 3 calcFunc-wmaximize )
                                ( ?/ 2 calcFunc-pdivide ) )
-                             ( ( ?S 2 calcFunc-ffinv ) )
-))
+                             ( ( ?S 2 calcFunc-ffinv ) )))
+
 (defconst calc-b-oper-keys '( ( ( ?a 2 calcFunc-and )
                                ( ?o 2 calcFunc-or )
                                ( ?x 2 calcFunc-xor )
@@ -587,14 +341,14 @@
                                ( ?M 3 calcFunc-pmtl )
                                ( ?P 3 calcFunc-pvl )
                                ( ?T 3 calcFunc-ratel )
-                               ( ?\# 3 calcFunc-nperl ) )
-))
+                               ( ?\# 3 calcFunc-nperl ) )))
+
 (defconst calc-c-oper-keys '( ( ( ?d 1 calcFunc-deg )
                                ( ?r 1 calcFunc-rad )
                                ( ?h 1 calcFunc-hms )
                                ( ?f 1 calcFunc-float )
-                               ( ?F 1 calcFunc-frac ) )
-))
+                               ( ?F 1 calcFunc-frac ) )))
+
 (defconst calc-f-oper-keys '( ( ( ?b 2 calcFunc-beta )
                                ( ?e 1 calcFunc-erf )
                                ( ?g 1 calcFunc-gamma )
@@ -625,8 +379,8 @@
                                ( ?L 1 calcFunc-expm1 ) )
                              ( ( ?B 3 calcFunc-betaB )
                                ( ?G 2 calcFunc-gammag) )
-                             ( ( ?G 2 calcFunc-gammaG ) )
-))
+                             ( ( ?G 2 calcFunc-gammaG ) )))
+
 (defconst calc-k-oper-keys '( ( ( ?b 1 calcFunc-bern )
                                ( ?c 2 calcFunc-choose )
                                ( ?d 1 calcFunc-dfact )
@@ -656,11 +410,11 @@
                              ( ( ?b 2 calcFunc-bern )
                                ( ?c 2 calcFunc-perm )
                                ( ?e 2 calcFunc-euler )
-                               ( ?s 2 calcFunc-stir2 ) )
-))
+                               ( ?s 2 calcFunc-stir2 ) )))
+
 (defconst calc-s-oper-keys '( ( ( ?: 2 calcFunc-assign )
-                               ( ?= 1 calcFunc-evalto ) )
-))
+                               ( ?= 1 calcFunc-evalto ) )))
+
 (defconst calc-t-oper-keys '( ( ( ?C 3 calcFunc-tzconv )
                                ( ?D 1 calcFunc-date )
                                ( ?I 2 calcFunc-incmonth )
@@ -668,8 +422,8 @@
                                ( ?M 1 calcFunc-newmonth )
                                ( ?W 1 calcFunc-newweek )
                                ( ?U 1 calcFunc-unixtime )
-                               ( ?Y 1 calcFunc-newyear ) )
-))
+                               ( ?Y 1 calcFunc-newyear ) )))
+
 (defconst calc-u-oper-keys '( ( ( ?C 2 calcFunc-vcov )
                                ( ?G 1 calcFunc-vgmean )
                                ( ?M 1 calcFunc-vmean )
@@ -684,8 +438,8 @@
                                ( ?M 1 calcFunc-vmedian )
                                ( ?S 1 calcFunc-vvar ) )
                              ( ( ?M 1 calcFunc-vhmean )
-                               ( ?S 1 calcFunc-vpvar ) )
-))
+                               ( ?S 1 calcFunc-vpvar ) )))
+
 (defconst calc-v-oper-keys '( ( ( ?a 2 calcFunc-arrange )
                                ( ?b 2 calcFunc-cvec )
                                ( ?c 2 calcFunc-mcol )
@@ -742,8 +496,259 @@
                                ( ?U 2 calcFunc-anest ) )
                              ( ( ?h 1 calcFunc-rtail )
                                ( ?R 1 calcFunc-fixp )
-                               ( ?U 1 calcFunc-afixp ) )
-))
+                               ( ?U 1 calcFunc-afixp ) )))
+
+
+;;; Return a list of the form (nargs func name)
+(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* ((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: ")))
+                             (setq record-entry t)
+                             (or (= (length func) 1)
+                                 (error "Bad format"))
+                             (if (> calc-dollar-used 0)
+                                 (progn
+                                   (setq has-args calc-dollar-used
+                                         arglist (calc-invent-args has-args))
+                                   (math-multi-subst (car func)
+                                                     (reverse arglist)
+                                                     arglist))
+                               (if (> calc-hashes-used 0)
+                                   (setq has-args calc-hashes-used
+                                         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
+                            arglist (sort arglist 'string-lessp))
+                      (if calc-verify-arglist
+                          (setq arglist (read-from-minibuffer
+                                         "Function argument list: "
+                                         (if arglist
+                                             (prin1-to-string arglist)
+                                           "()")
+                                         minibuffer-local-map
+                                         t)))
+                      (setq arglist (mapcar (function
+                                             (lambda (x)
+                                               (list 'var
+                                                     x
+                                                     (intern
+                                                      (concat
+                                                       "var-"
+                                                       (symbol-name x))))))
+                                            arglist))))
+                (setq oper (list "$"
+                                 (length arglist)
+                                 (append '(calcFunc-lambda) 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
+                                             (substring
+                                              (symbol-name (nth 2 oper))
+                                              9)))
+                                  '(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))))))
 
 
 ;;; Convert a variable name (as a formula) into a like-looking function name.



reply via email to

[Prev in Thread] Current Thread [Next in Thread]