← Back to branch summary

~ubuntu-branches/debian/squeeze/maxima/squeeze

« back to all changes in this revision

Viewing changes to src/mutils.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2006-10-18 14:52:42 UTC
  • mto: (1.1.5 upstream)
  • mto: This revision was merged to the branch mainline in revision 4.
  • Revision ID: james.westby@ubuntu.com-20061018145242-vzyrm5hmxr8kiosf
Import upstream version 5.10.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/mutils.lisp
8
8
;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
9
9
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10
10
 
11
 
(in-package "MAXIMA")
 
11
(in-package :maxima)
12
12
(macsyma-module mutils)
13
13
 
14
14
;;; General purpose Macsyma utilities.  This file contains runtime functions 
27
27
;;; false.
28
28
;;; Author Dan Stanger 12/1/02
29
29
(defmfun $assoc (key ielist &optional default)
30
 
   (let ((elist (margs ielist)))
31
 
      (if (every #'(lambda (x) (= 3 (length x))) elist)
32
 
         (let ((found (find key elist :test #'alike1 :key #'second)))
33
 
            (if found (third found) default))
34
 
         (MERROR "Improper form for list:~%~M" ielist))))
35
 
 
36
 
;;; This function works like the every function in lisp.
37
 
;;; It can take a list, or a positive number of arguments returning
38
 
;;; true if all its arguments are not false.
39
 
;;; Author Dan Stanger 12/1/02
40
 
(defmfun $every (&rest args)
41
 
  (let ((n (length args)))
42
 
     (cond ((= n 0) (merror "Every must have at least 1 argument"))
43
 
           ((= n 1)
44
 
               (let ((args (first args)))
45
 
                  (if (and ($listp args) (> ($length args) 0))
46
 
                      (notany #'not (margs args))
47
 
                      (if (and ($listp args) (= ($length args) 0)) nil args))))
48
 
           (t (notany #'not args)))))
 
30
  (let ((elist (margs ielist)))
 
31
    (if (every #'(lambda (x) (= 3 (length x))) elist)
 
32
        (let ((found (find key elist :test #'alike1 :key #'second)))
 
33
          (if found (third found) default))
 
34
        (merror "Improper form for list:~%~M" ielist))))
49
35
 
50
36
;;; (ASSOL item A-list)
51
37
;;;
54
40
;;;
55
41
;;;  Meta-Synonym:      (ASS #'ALIKE1 ITEM ALIST)
56
42
 
57
 
(DEFMFUN ASSOL (ITEM ALIST)
58
 
  (DOLIST (PAIR ALIST)
59
 
          (IF (ALIKE1 ITEM (CAR PAIR)) (RETURN PAIR))))
 
43
(defmfun assol (item alist)
 
44
  (dolist (pair alist)
 
45
    (if (alike1 item (car pair)) (return pair))))
60
46
;;; 
61
47
 
62
 
(DEFMFUN ASSOLIKE (ITEM ALIST) 
63
 
  (CDR (ASSOL ITEM ALIST)))
 
48
(defmfun assolike (item alist) 
 
49
  (cdr (assol item alist)))
64
50
 
65
 
; Old ASSOLIKE definition:
66
 
;
67
 
; (defun assolike (e l) 
68
 
;        (prog nil 
69
 
;         loop (cond ((null l) (return nil))
70
 
;                    ((alike1 e (caar l)) (return (cdar l))))
71
 
;              (setq l (cdr l))
72
 
;              (go loop)))
 
51
;; Old ASSOLIKE definition:
 
52
;;
 
53
;; (defun assolike (e l) 
 
54
;;       (prog nil 
 
55
;;        loop (cond ((null l) (return nil))
 
56
;;                   ((alike1 e (caar l)) (return (cdar l))))
 
57
;;             (setq l (cdr l))
 
58
;;             (go loop)))
73
59
 
74
60
;;; (MEM #'ALIKE1 X L)
75
61
 
76
 
(DEFMFUN MEMALIKE (X L)
77
 
  (DO ((L L (CDR L))) ((NULL L))
78
 
      (COND ((ALIKE1 X (CAR L)) (RETURN L)))))
 
62
(defmfun memalike (x l)
 
63
  (do ((l l (cdr l))) ((null l))
 
64
    (cond ((alike1 x (car l)) (return l)))))
79
65
 
80
66
;;;Do we want MACROS for these on MC and on Multics?? -Jim 1/29/81
81
 
#+Multics
82
 
(PROGN 'COMPILE
83
 
  (DEFMFUN MSTRINGP (X)
84
 
    (AND (SYMBOLP X)
85
 
         (EQUAL (GETCHARN X 1) #\&)))
86
 
 
87
 
  (DEFMFUN MSTRING-TO-STRING (X)
88
 
    (SUBSTRING (STRING X) 1))
89
 
 
90
 
  (DEFMFUN STRING-TO-MSTRING (X)
91
 
    (MAKE-SYMBOL (STRING-APPEND "&" X)))
92
 
)
 
67
#+multics
 
68
(progn 'compile
 
69
       (defmfun mstringp (x)
 
70
         (and (symbolp x)
 
71
              (equal (getcharn x 1) #\&)))
 
72
 
 
73
       (defmfun mstring-to-string (x)
 
74
         (substring (string x) 1))
 
75
 
 
76
       (defmfun string-to-mstring (x)
 
77
         (make-symbol (string-append "&" x)))
 
78
       )
93
79