src/defcal.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 1980 Massachusetts Institute of Technology         ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package :maxima)
  12
  13 (macsyma-module defcal macro)
  14
  15 ;; Compile-time support for defining things which dispatch
  16 ;; off the property list. The Macsyma parser uses this.
  17
  18 (defun make-parser-fun-def (op p bvl body)
  19   ;; Used by the Parser at compile time.
  20   (if (not (consp op))
  21       `(,(symbolconc 'def- p '-fun) ,op ,bvl
  22         ,(car bvl)
  23         ;; so compiler won't warn about
  24         ;; unused lambda variable.
  25         . ,body)
  26       `(progn
  27         ,(make-parser-fun-def (car op) p bvl body)
  28         ,@(mapcar #'(lambda (x)
  29                       `(inherit-propl ',x ',(car op) (,(symbolconc p '-propl))))
  30                   (cdr op)))))
  31
  32 ;;; The tokenizer use the famous CSTR to represent the possible extended token
  33 ;;; symbols. The derivation of the name and implementation is obscure, but I've
  34 ;;; heard it has something to do with an early Fortran compiler written in Lisp.
  35 ;;;  -GJC
  36
  37 ;;; (CSTRSETUP <description>)
  38 ;;;
  39 ;;;  <description> ::= (<descriptor> <descriptor> ...)
  40 ;;;  <descriptor>  ::= <name> ! (<name> <translation>)
  41 ;;;
  42 ;;;  If no translation is supplied, $<name> is the default.
  43 ;;;
  44 ;;;  Sets up a CSTR [Command STRucture] object which may be used
  45 ;;;  in conjunction with the CEQ predicate to determine if the
  46 ;;;  LINBUF cursor is currently pointing at any keyword in that
  47 ;;;  structure.
  48 ;;;
  49 ;;;  Note: Names containing shorter names as initial segments
  50 ;;;        must follow the shorter names in arg to CSTRSETUP.
  51
  52 (defvar symbols-defined () "For safe keeping.")
  53 (defvar macsyma-operators ())
  54
  55 (eval-when (:execute :compile-toplevel :load-toplevel)
  56   (defun *define-initial-symbols (l)
  57     (setq symbols-defined
  58           (sort (copy-list l) #'(lambda (x y) (< (flatc x) (flatc y)))))
  59     (setq macsyma-operators (cstrsetup symbols-defined))))
  60
  61 (defmacro define-initial-symbols (&rest l)
  62   (let ((symbols-defined ())
  63         (macsyma-operators ()))
  64     (*define-initial-symbols l)
  65     `(progn
  66       (declare-top (special symbols-defined macsyma-operators))
  67       (setq symbols-defined (copy-list ',symbols-defined))
  68       (setq macsyma-operators (subst () () ',macsyma-operators)))))
  69
  70 (defun undefine-symbol (opr)
  71   (*define-initial-symbols (delete opr symbols-defined :test #'equal)))
  72
  73 (defun define-symbol (x)
  74   (*define-initial-symbols (cons x symbols-defined))
  75   (symbolconc '$ (maybe-invert-string-case x)))
  76
  77 (defun cstrsetup (arg)
  78   (do ((arg arg (cdr arg))
  79        (tree nil))
  80       ((null arg) (list* () '(ans ()) tree))
  81     (if (atom (car arg))
  82         (setq tree (add2cstr (car arg)
  83                          tree
  84                          (symbolconc '$
  85                                      (if (stringp (car arg))
  86                                        (maybe-invert-string-case (car arg))
  87                                        (car arg)))))
  88         (setq tree (add2cstr (caar arg) tree (cadar arg))))))
  89
  90 ;;; (ADD2CSTR <name> <tree> <translation>)
  91 ;;;
  92 ;;;  Adds the information <name> -> <translation> to a
  93 ;;;  CSTR-style <tree>.
  94
  95 (defun add2cstr (x tree ans)
  96   (add2cstr1 (nconc (exploden x) (ncons (list 'ans ans))) tree))
  97
  98 ;;; (ADD2CSTR1 <translation-info> <tree>)
  99 ;;;
 100 ;;;  Helping function for ADD2CSTR. Puts information about a
 101 ;;;  keyword into the <tree>
 102
 103 (defun add2cstr1 (x tree)
 104   (cond ((null tree) x)
 105         ((atom (car tree))
 106          (cond ((equal (car tree) (car x))
 107                 (rplacd tree (add2cstr1 (cdr x) (cdr tree))))
 108                (t (list tree (cond ((atom (car x)) x)
 109                                    ((equal (caar x) 'ans) (car x))
 110                                    (t x))))))
 111         ((equal (caar tree) (car x))
 112          (rplacd (car tree) (add2cstr1 (cdr x) (cdar tree)))
 113          tree)
 114         ((null (cdr tree))
 115          (rplacd tree (list x))
 116          tree)
 117         (t (rplacd tree (add2cstr1 x (cdr tree)))
 118            tree)))