src/utils.lisp

   1 ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;     The data in this file contains enhancments.                    ;;;;;
   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 ()
  43   #+(or cmu scl clisp) (ext:quit)
  44   #+sbcl               (sb-ext:quit)
  45   #+allegro            (excl:exit 0 :quiet t)
  46   #+(or mcl openmcl)   (ccl:quit)
  47   #+gcl                (system::quit)
  48   #+ecl                (si:quit)
  49   #+lispworks          (lispworks:quit)
  50   #+abcl               (cl-user::quit)
  51   #+kcl                (lisp::bye)
  52   )
  53
  54
  55 ;;; F is assumed to be a function of two arguments.  It is mapped down L
  56 ;;; and applied to consequtive pairs of elements of the list.
  57 ;;; Useful for iterating over property lists.
  58
  59 (defun map2c (f l)
  60   (do ((llt l (cddr llt)) (lans))
  61       ((null llt) lans)
  62     (push (funcall f (car llt) (cadr llt)) lans)))
  63
  64 ;;; Like MAPCAR, except if an application of F to any of the elements of L
  65 ;;; returns NIL, then the function returns NIL immediately.
  66
  67 (defun andmapcar (f l &aux d answer)
  68   (do ((l l (cdr l)))
  69       ((null l) (nreverse answer))
  70     (setq d (funcall f (car l)))
  71     (if d (push d answer) (return nil))))
  72
  73 ;;; Returns T if either A or B is NIL, but not both.
  74
  75 (defun xor (a b)
  76   (or (and (not a) b) (and (not b) a)))
  77
  78 ;;; A MEMQ which works at all levels of a piece of list structure.
  79 ;;;
  80 ;;; Note that (AMONG NIL '(A B C)) is T, however.  This could cause bugs.
  81 ;;; > This is false. (AMONG NIL anything) returns NIL always. -kmp
  82
  83 (defun among (x l)
  84   (cond ((null l) nil)
  85         ((atom l) (eq x l))
  86         (t (or (among x (car l)) (among x (cdr l))))))
  87
  88 ;;; Similar to AMONG, but takes a list of objects to look for.  If any
  89 ;;; are found in L, returns T.
  90
  91 (defun amongl (x l)
  92   (cond ((null l) nil)
  93         ((atom l) (member l x :test #'eq))
  94         (t (or (amongl x (car l)) (amongl x (cdr l))))))
  95
  96 ;;; Tests to see whether one tree is a subtree of another.
  97 ;;;
  98 ;;; Both arguments should be well-formed cons trees (so no cycles). If supplied,
  99 ;;; TEST is used as an equality predicate.
 100
 101 (defun subtree-p (branch tree &key (test #'eql))
 102   (or (funcall test branch tree)
 103       (and (not (atom tree))
 104            (member branch tree
 105                    :test (lambda (x y) (subtree-p x y :test test))))))
 106
 107 ;;; Takes a list in "alist" form and converts it to one in
 108 ;;; "property list" form, i.e. ((A . B) (C . D)) --> (A B C D).
 109 ;;; All elements of the list better be conses.
 110
 111 (defun dot2l (l)
 112   (cond ((null l) nil)
 113         (t (list* (caar l) (cdar l) (dot2l (cdr l))))))
 114
 115 ;;; (C-PUT  sym value    selector)
 116 ;;;
 117 ;;;  Make a symbol's property list look like a structure.
 118 ;;;
 119 ;;;  If the value to be stored is NIL,
 120 ;;;     then flush the property.
 121 ;;;     else store the value under the appropriate property.
 122 ;;;
 123
 124 (defun cput (bas val sel)
 125   (cond ((null val)
 126          (zl-remprop bas sel)
 127          nil)
 128         (t
 129          (putprop bas val sel))))