src/mrgmac.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 mrgmac macro)
  14
  15 (defun define-macro (name lambda-exp)
  16   (cond ((symbolp lambda-exp)
  17          (setq lambda-exp (symbol-function lambda-exp))))
  18   (setf (macro-function name) lambda-exp))
  19
  20 (declare-top (special name bas selector))
  21
  22 (defvar *mobjects* nil)
  23
  24 (defprop mode (c-mode s-mode a-mode) mode)
  25
  26 (defmacro c-mode (&rest l)
  27   `(list ,@l))
  28
  29 (defmacro s-mode (&rest x)
  30   (push 's-mode x)
  31   (cond ((eq 'c (third x)) `(first ,(second x)))
  32         ((eq 'sel (third x)) `(second ,(second x)))
  33         ((eq 'push+sto (third x)) `(third ,(second x)))))
  34
  35 (defmacro a-mode (&rest x)
  36   (push 'a-mode x)
  37   (cond ((eq 'c (third x)) `(rplaca (second x) ,(fourth x)))
  38         ((eq 'sel (third x)) `(rplaca (cdr ,(second x)) ,(fourth x)))
  39         ((eq 'push+sto (third x)) `(rplaca (cddr ,(second x)) ,(fourth x)))))
  40
  41 (defmacro defmode (&rest x)
  42   (push 'defmode x)
  43   (let ((selector (member 'selector (cddddr x) :test #'eq)))
  44     (define-mode (second x) (fourth x))
  45     (mapc 'eval (cddddr x))
  46     `',(second x)))
  47
  48 (defun define-mode (name desc)
  49   (let ((c (intern (format nil "C-~A" name)))
  50         (s (intern (format nil "S-~A" name)))
  51         (a (intern (format nil "A-~A" name))))
  52     (define-macro c (defc desc))
  53     (define-macro s (defs desc))
  54     (define-macro a (defa desc))
  55     (putprop name (c-mode c s a) 'mode)))
  56
  57 (defun defc (desc)
  58   (let ((bas 'x))
  59     (coerce `(lambda (x &optional env)
  60               (declare (ignore env))
  61               ,(defc1 desc))
  62             'function)))
  63
  64 (defun defc1 (desc)
  65   (cond ((atom desc) (list 'quote desc))
  66         ((eq 'selector (car desc))
  67          (cond ((not (null (cdddr desc))) (list 'quote (fourth desc)))
  68                (t (setq bas (list 'cdr bas))
  69                   (list 'car bas))))
  70         ((eq (quote atom) (car desc))
  71          `(list 'c-atom '',(mapcar 'second (cdr desc)) (cons (quote list) (cdr x))))
  72         ((eq 'cons (car desc)) `(list 'cons ,(defc1 (second desc)) ,(defc1 (third desc))))
  73         ((eq (quote list) (car desc))
  74          (do ((l (cdr desc) (cdr l)) (nl))
  75              ((null l) `(list (quote list) ,@(nreverse nl)))
  76            (push (defc1 (car l)) nl)))
  77         ((eq 'struct (car desc)) (defc1 (cons (quote list) (cdr desc))))
  78         (t (list 'quote desc))))
  79
  80
  81 (defun defs (desc)
  82   (coerce `(lambda (x &optional env)
  83             (declare (ignore env))
  84             (cond ,@(nreverse (defs1 desc '(second x) nil))))
  85           'function ))
  86
  87 (defun defs1 (desc bas result)
  88   (cond ((atom desc) result)
  89         ((eq 'selector (car desc))
  90          (putprop (second desc)
  91               (cons (cons name (third desc)) (zl-get (second desc) 'modes))
  92               'modes)
  93          (putprop name
  94               (cons (cons (second desc) (third desc)) (zl-get name 'sels))
  95               'sels)
  96          (if selector (define-macro (second desc) 'selector))
  97          (cons `((eq ',(second desc) (third x)) ,bas) result))
  98         ((eq (quote atom) (car desc))
  99          (do ((l (cdr desc) (cdr l))) ((null l))
 100            (putprop (cadar l) (cons (cons name (caddar l))
 101                                 (zl-get (cadar l) 'modes)) 'modes)
 102            (putprop name (cons (cons (cadar l) (caddar l))
 103                            (zl-get name 'sels)) 'sels)
 104            (if selector (define-macro (cadar l) 'selector)))
 105          (cons `((member (third x) ',(mapcar 'second (cdr desc)) :test #'eq)
 106                  (list 'zl-get ,bas (list 'quote (third x))))
 107                result))
 108         ((eq 'cons (car desc))
 109          (setq result (defs1 (second desc) `(list 'car ,bas) result))
 110          (defs1 (third desc) `(list 'cdr ,bas) result))
 111         ((eq (quote list) (car desc))
 112          (do ((l (cdr desc) (cdr l))) ((null l))
 113            (setq result (defs1 (car l) `(list 'car ,bas) result)
 114                  bas `(list 'cdr ,bas)))
 115          result)
 116         ((eq 'struct (car desc)) (defs1 (cons (quote list) (cdr desc)) bas result))
 117         (t result)))
 118
 119 (defun defa (desc)
 120   (coerce `(lambda (x &optional env)
 121             (declare (ignore env))
 122             (cond ,@(nreverse (defa1 desc '(second x) nil nil))))
 123           'function))
 124
 125 (defun defa1 (desc bas cdr result)
 126   (cond ((atom desc) result)
 127         ((eq 'selector (car desc))
 128          (setq bas (cond ((not cdr) `(list 'car (list 'rplaca ,(third bas) (fourth x))))
 129                          (t `(list 'cdr (list 'rplacd ,(third bas) (fourth x))))))
 130          (cons `((eq ',(second desc) (third x)) ,bas) result))
 131         ((eq  (quote atom) (car desc))
 132          (list `(t (list 'cput (second x) (fourth x) (list 'quote (third x))))))
 133         ((eq 'cons (car desc))
 134          (setq result (defa1 (second desc) `(list 'car ,bas) nil result))
 135          (defa1 (third desc) `(list 'cdr ,bas) t result))
 136         ((eq (quote list) (car desc))
 137          (do ((l (cdr desc) (cdr l))) ((null l))
 138            (setq result (defa1 (car l) `(list 'car ,bas) nil result)
 139                  bas `(list 'cdr ,bas)))
 140          result)
 141         ((eq 'struct (car desc)) (defa1 (cons (quote list) (cdr desc)) bas cdr result))
 142         (t result)))
 143
 144
 145 (defun mode (x)
 146   (cdr (assoc x *mobjects* :test #'equal)))
 147
 148 (defmacro modedeclare (&rest l)
 149   `(modeclare-internal ',l))
 150
 151 (defun modedeclare-internal (x)
 152   (mapc #'(lambda (l)
 153             (mapc #'(lambda (v) (push (cons v (car l)) *mobjects*))
 154                   (cdr l)))
 155         x))
 156
 157 (defmacro sel (&rest x)
 158   (push 'sel x )
 159   (let ((s (fsel (mode (second x)) (cddr x))))
 160     (cond ((null s) (merror "SEL: ~a ~a" (second x) (cddr x)))
 161           (t (setq x (second x))
 162              (do ()
 163                  ((null (cdr s)) x)
 164                (setq x (cons (second (zl-get (car s) 'mode)) (rplaca s x))
 165                      s (cddr s))
 166                (rplacd (cddr x) nil))))))
 167
 168 (defun fsel (m sels) ;;This has a bug in it.
 169   (cond ((null sels) (list m))
 170         ((null m)
 171          (do ((l (zl-get (car sels) 'modes) (cdr l)))
 172              ((null l))
 173            (if (setq m (fsel (cdar l) (cdr sels)))
 174                (return (cons (caar l) (cons (car sels) m))))))
 175         ((let (dum)
 176            (if (setq dum (assoc (car sels) (zl-get m 'sels) :test #'eq))
 177                (cons m (cons (car sels) (fsel (cdr dum) (cdr sels)))))))
 178         (t (do ((l (zl-get m 'sels) (cdr l)) (dum))
 179                ((null l))
 180              (if (setq dum (fsel (cdar l) sels))
 181                  (return (cons m (cons (caar l) dum))))))))
 182
 183 (defun selector (x env)
 184   (declare (ignore env))
 185   (if (null (cddr x))
 186       `(sel ,(second x) ,(car x))
 187       `(push+sto (sel ,(second x) ,(car x)) ,(third x))))
 188
 189 (defmacro push+sto (&rest x)
 190   (push 'push+sto x )
 191   `(sto ,@(cdr x)))
 192
 193 (defmacro sto (&rest x)
 194   (push ' sto x )
 195   (do ((l (cdr x) (cddr l))
 196        (s)
 197        (nl))
 198       ((null l) `(progn ,@(nreverse nl)))
 199     (cond ((atom (car l))
 200            (push `(setq ,(first l) ,(second l)) nl))
 201           ((and (eq 'sel (caar l)) (setq s (fsel (mode (cadar l)) (cddar l))))
 202            (setq x (cadar l))
 203            (do ((l (cddr s) (cddr l)))
 204                ((null (cdr l)))
 205              (setq x (cons (second (zl-get (first l) 'mode)) (rplaca l x)))
 206              (rplacd (cddr x) nil))
 207            (push (list (third (zl-get (first s) 'mode)) x (second s) (second l)) nl))
 208           (t (merror "STO: ~a" (car l))))))
 209
 210 ;;; Remove both of these once we're sure all uses of cons-exp have
 211 ;;; been replaced by ftake*.
 212 #+nil
 213 (defmacro cons-exp (op &rest args)
 214   `(simplify (list (list ,op) ,@args)))
 215
 216 #+nil
 217 (defmacro cons-exp (op &rest args)
 218   `(ftake* ,op ,@args))
 219
 220 ;; Local Modes:
 221 ;; Mode: LISP
 222 ;; Comment Col: 40
 223 ;; End: