/usr/share/maxima/5.41.0/src/utils.lisp is in maxima-src 5.41.0-3.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 | ;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The data in this file contains enhancments. ;;;;;
;;; ;;;;;
;;; Copyright (c) 1984,1987 by William Schelter,University of Texas ;;;;;
;;; All rights reserved ;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package :maxima)
(macsyma-module utils)
;;; General purpose Lisp utilities. This file contains runtime functions which
;;; are simple extensions to Lisp. The functions here are not very general,
;;; but generalized forms would be useful in future Lisp implementations.
;;;
;;; No knowledge of the Macsyma system is kept here.
;;;
;;; Every function in this file is known about externally.
(defmacro while (cond &rest body)
`(do ()
((not ,cond))
,@body))
(defun maxima-getenv (envvar)
#+gcl (si::getenv envvar)
#+ecl (si::getenv envvar)
#+allegro (system:getenv envvar)
#+(or cmu scl) (cdr (assoc envvar ext:*environment-list* :test #'string=))
#+sbcl (sb-ext:posix-getenv envvar)
#+clisp (ext:getenv envvar)
#+(or openmcl mcl) (ccl::getenv envvar)
#+lispworks (hcl:getenv envvar)
#+abcl (ext:getenv envvar)
)
;; CMUCL needs because when maxima reaches EOF, it calls BYE, not $QUIT.
(defun bye ()
#+(or cmu scl clisp) (ext:quit)
#+sbcl (sb-ext:quit)
#+allegro (excl:exit 0 :quiet t)
#+(or mcl openmcl) (ccl:quit)
#+gcl (system::quit)
#+ecl (si:quit)
#+lispworks (lispworks:quit)
#+abcl (cl-user::quit)
#+kcl (lisp::bye)
)
;;; F is assumed to be a function of two arguments. It is mapped down L
;;; and applied to consequtive pairs of elements of the list.
;;; Useful for iterating over property lists.
(defmfun map2c (f l)
(do ((llt l (cddr llt)) (lans))
((null llt) lans)
(push (funcall f (car llt) (cadr llt)) lans)))
;;; Like MAPCAR, except if an application of F to any of the elements of L
;;; returns NIL, then the function returns NIL immediately.
(defmfun andmapcar (f l &aux d answer)
(do ((l l (cdr l)))
((null l) (nreverse answer))
(setq d (funcall f (car l)))
(if d (push d answer) (return nil))))
;;; Returns T if either A or B is NIL, but not both.
(defmfun xor (a b)
(or (and (not a) b) (and (not b) a)))
;;; A MEMQ which works at all levels of a piece of list structure.
;;;
;;; Note that (AMONG NIL '(A B C)) is T, however. This could cause bugs.
;;; > This is false. (AMONG NIL anything) returns NIL always. -kmp
(defmfun among (x l)
(cond ((null l) nil)
((atom l) (eq x l))
(t (or (among x (car l)) (among x (cdr l))))))
;;; Similar to AMONG, but takes a list of objects to look for. If any
;;; are found in L, returns T.
(defmfun amongl (x l)
(cond ((null l) nil)
((atom l) (member l x :test #'eq))
(t (or (amongl x (car l)) (amongl x (cdr l))))))
;;; Tests to see whether one tree is a subtree of another.
;;;
;;; Both arguments should be well-formed cons trees (so no cycles). If supplied,
;;; TEST is used as an equality predicate.
(defun subtree-p (branch tree &key (test #'eql))
(or (funcall test branch tree)
(and (not (atom tree))
(member branch tree
:test (lambda (x y) (subtree-p x y :test test))))))
;;; Takes a list in "alist" form and converts it to one in
;;; "property list" form, i.e. ((A . B) (C . D)) --> (A B C D).
;;; All elements of the list better be conses.
(defmfun dot2l (l)
(cond ((null l) nil)
(t (list* (caar l) (cdar l) (dot2l (cdr l))))))
;;; (C-PUT sym value selector)
;;;
;;; Make a symbol's property list look like a structure.
;;;
;;; If the value to be stored is NIL,
;;; then flush the property.
;;; else store the value under the appropriate property.
;;;
(defmfun cput (bas val sel)
(cond ((null val)
(zl-remprop bas sel)
nil)
(t
(putprop bas val sel))))
|