meval

defmfun で定義されたlispの関数はmevalで評価できる。

(defmfun $test (&rest keys)
  (let ()
    (setf keys (push '$factorout keys))
    (meval keys)
    ))

maxima <=> lisp

f(s):=s^2
((MDEFINE SIMP) (($F) $S) ((MEXPT) $S 2)) 

式の展開 ratsimp ratf ratdisrep

file: rat3e.lisp
ん~ よくわからん。とりあえず、ratsimpをすればいいんだな。

(defun ratsimp (x varlist genvar) ($ratdisrep (ratf x)))

(defmfun ratf (l)
  (prog (u *withinratf*)
     (setq *withinratf* t)
     (when (eq '%% (catch 'ratf (newvar l)))
       (setq *withinratf* nil)
       (return (srf l)))
     (setq u (catch 'ratf (ratrep* l))) ; for truncation routines
     (return (or u (prog2 (setq *withinratf* nil) (srf l))))))

(defmfun ratdisrep (e) (simplifya ($ratdisrep e) nil))

depends

file: comm.lisp
eがxに依存しているか判別する。

(defun depends (e x)
  (cond ((alike1 e x) t)
 ((mnump e) nil)
 ((atom e) (mget e 'depends))
 (t (or (depends (caar e) x) (dependsl (cdr e) x)))))

addn

file: opers.lisp
渡されたlistの中身をすべて足す。

(defmfun addn (terms simp-flag)
  (cond ((null terms) 0)
         (t (simplifya `((mplus) . ,terms) simp-flag))))

nonvarcheck

file: comm.lisp

(defmfun nonvarcheck (e fn)
  (if (or (mnump e)
   (maxima-integerp e)
   (and (not (atom e)) (not (eq (caar e) 'mqapply)) (mopp1 (caar e))))
      (merror (intl:gettext "~:M: second argument must be a variable; found ~M") fn e)))

deriv

file:comm.lisp

(defun deriv (e) ;; e <- (((MEXPT SIMP) $X 2) $X 1)
  (prog (exp z count) 
           (cond ((null e) (wna-err '$diff))
    ((null (cdr e)) (return (stotaldiff (car e))))
    ((null (cddr e)) (nconc e '(1))))
     (setq exp (car e) z (setq e (copy-list e)))
     loop (if (or (null derivlist) (member (cadr z) derivlist :test #'equal)) (go doit))
     ; DERIVLIST is set by $EV
     (setq z (cdr z))
     loop2(cond ((cdr z) (go loop))
  ((null (cdr e)) (return exp))
  (t (go noun)))
     doit (cond ((nonvarcheck (cadr z) '$diff))
  ((null (cddr z)) (wna-err '$diff)) ;;(cddr z) <- (1)
  ((not (eq (ml-typep (caddr z)) 'fixnum)) (go noun)) ;;(caddr z) <- 1
  ((minusp (setq count (caddr z))) ;; count <- 1
   (merror (intl:gettext "diff: order of derivative must be a nonnegative integer; found ~M") count)))
     ;;z <-((MEXPT SIMP) $X 2)
     loop1 (cond ((zerop count) (rplacd z (cdddr z)) (go loop2))
           ;;(sdiff ((MEXPT SIMP) $X 2) $X)
           ((equal (setq exp (sdiff exp (cadr z))) 0) (return 0))))
     (setq count (1- count))
     (go loop1)
     noun (return (diff%deriv (cons exp (cdr e))))))

declare-top

file:lmdcls.lisp

(defmacro declare-top (&rest decl-specs)
  `(eval-when
    ,(cond (*macro-file*  #+gcl '(compile eval load)
     #-gcl '(:compile-toplevel :load-toplevel :execute) )
    (t #+gcl '(eval compile) #-gcl '(:compile-toplevel :execute)))
    ,@(loop for v in decl-specs
      unless (member (car v) '(special unspecial)) nconc nil
      else
      when (eql (car v) 'unspecial)
      collect `(progn
         ,@(loop for w in (cdr v)
    collect #-(or gcl scl cmu ecl)
                                       `(remprop ',w
       #-excl 'special
       #+excl 'excl::.globally-special.)
    #+(or gcl scl cmu ecl)
           `(make-unspecial ',w)))
      else collect `(proclaim ',v))))

defmode

mrgmac.lisp

(declare-top (special name bas selector))

(defmacro defmode (&rest x)
  (push 'defmode x)
  (let ((selector (member 'selector (cddddr x) :test #'eq)))
    (define-mode (second x) (fourth x))
    (mapc 'eval (cddddr x))
    `',(second x)))

context

db.lisp

(defmode context ()
  (atom (selector cmark fixnum 0) (selector subc) (selector data)))

with-new-context

;; Used to temporarily bind contexts in such a way as to not cause
;; the context garbage collector to run. Used when you don't want to
;; stash away contexts for later use, but simply want to run a piece
;; of code in a new context which will be destroyed when the code finishes.
;; Note that this code COULD use an unwind-protect to be safe but since
;; it will not cause out and out errors we leave it out.

(defmacro with-new-context (sub-context &rest forms)
  `(let ((context (context ,@sub-context)))
     (prog1 ,@forms
       (context-unwinder))))