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 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)))
119