archive/src/neweval.lisp

   1
   2
   3
   4
   5 make meval1 do following
   6
   7 (cond ((atom form)
   8        (if (symbolp form) (if mrefchecking (mrefcheck form)
   9                               (if (boundp form) (symbol-value form)
  10                                 ;; unbound variable is itself.
  11                                 form))))
  12       ;; handle all the things which eval their args in this way
  13       ;; dispatching way.   This covers things like a call to
  14       ;; a lisp function.  A call to an mexpr will also pass this
  15       ;; way, since we will have at definition time done
  16       ;; (fset '$foo #'mexpr)
  17       ;; and that guy will be responsible for actually doing the call
  18       ;; he will have all he needs accessible from the *last-form*
  19       ;; and he will have his args already eval'd.
  20       ((fboundp (caar form))
  21        (let ((tem (cdr form)) a b c d)
  22          (return-from
  23           meval1
  24           (cond ((null tem)
  25                  (setq *last-form* form)
  26                  (funcall (caar form))
  27                  )
  28                 ((progn (setq a (meval1 (car tem)) tem (cdr tem))(null tem))
  29                  (setq *last-form* form)
  30                  (funcall (caar form) a))
  31                 ((progn (setq b (meval1 (car tem)) tem (cdr tem))(null tem))
  32                  (setq *last-form* form)
  33                  (funcall (caar form) a b))
  34                 ((progn (setq c (meval1 (car tem)) tem (cdr tem))(null tem))
  35                  (setq *last-form* form)
  36                  (funcall (caar form) a b c))
  37                 ((progn (setq d (meval1 (car tem)) tem (cdr tem))(null tem))
  38                  (setq *last-form* form)
  39                  (funcall (caar form) a b c d))
  40                 (t (let ((rest (mapcar 'meval1 tem)))
  41                      (setq *last-form* form)
  42                      (apply (caar form) a b c d rest)))))))
  43       ;; the special forms...
  44       ;; msetq these could be done using the symbol-value cell of
  45       ;; have a global
  46       (defvar *cdr-of-mfexpr* '(nil))
  47       ;; and  (setf mset (cons #'(lambda (x) (handle-mset x)) *cdr-of-mfexpr*))
  48             ;;
  49       ((and (boundp (caar form))
  50             (let ((tem (symbol-value (caar form))))
  51               (cond ((eq (cdr tem) *cdr-of-mfexpr*)
  52                      ;; actually maybe not necessary since
  53                      ;; the child has it and should be responsible..
  54                      ;;(setq *last-form* form)
  55                      (return-from meval1             (funcall (car tem) form))
  56                 nil)))))
  57
  58
  59
  60
  61
  62
  63