src/utils.lisp

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