archive/src/qeval.lsp

   1
   2 (defvar *q-ops*)
   3 (setq *q-ops*'(
   4                                         ;(%ACSCH  m_ACSCH 1)
   5                ($REALPART  m_REAL 1 )
   6                ($ImagPART  m_imag 1 )
   7                ($conjugate m_conj 1)
   8                ($abs m_abs 1)
   9                (%ACSC  m_ACSC 1 )
  10                (%ACOS  m_ACOS 1 )
  11                                         ;(%SEC  m_SEC 1 )
  12                                         ;(%ACOT  m_ACOT 1 )
  13                (%TAN  m_TAN 1 )
  14                (%SIN  m_SIN 1 )
  15                                         ;(%SECH  m_SECH 1 )
  16                                         ; (%ASEC  m_ASEC 1 )
  17                (%TANH  m_TANH 1 )
  18                (%COS  m_COS 1 )
  19                                         ;(%COT  m_COT 1 )
  20                                         ;(%CSC  m_CSC 1 )
  21                (%ASIN  m_ASIN 1 )
  22                (%SINH  m_SINH 1 )
  23                (%COSH  m_COSH 1 )
  24                                         ;(%COTH  m_COTH 1 )
  25                                         ;(%CSCH  m_CSCH 1 )
  26                                         ;(%ERF  m_ERF 1 )
  27                                         ;(%ASINH  m_ASINH 1 )
  28                (%LOG  m_LOG 1 )
  29                (MFACTORIAL  m_FACTORIAL 1)
  30                                         ;(MNOT  m_NOT 1 )
  31                                         ;(RAT  m_AT 1 )
  32                (MAND  m_AND n )
  33                (MSET  m_SET 2 )
  34                (MPLUS  m_PLUS n )
  35                                         ;(MPROGN  m_PROGN n )
  36                                         ;(MQAPPLY  m_QAPPLY 1 )
  37                                         ;(MSETQ  m_SETQ 2 )
  38                                         ;(MCOND  m_COND nil)
  39                (MGREATERP  m_gt 2 )
  40                (MLESSP  m_Lt 2 )
  41                (MQUOTIENT  m_div 2 )
  42                                         ;(MDEFINE  m_DEFINE 2 )
  43                (MNOTEQUAL  m_NE 2 )
  44                (MTIMES  m_mult n )
  45                (MGEQP  m_GE 1 )
  46                (MEQUAL  m_EQ 1 )
  47                                         ;(MNCEXPT  m_NCEXPT 1 )
  48                ;;(BIGFLOAT  m_IGFLOAT 1 )
  49                (MMINUS  m_MINUS 1 )
  50                (MEXPT  m_power 2 )
  51                                         ;(MQUOTE  m_QUOTE 1 )
  52                (MLEQP  m_LE 1 )
  53                (MOR  m_OR 1 )
  54                                         ;(MNCTIMES  m_NCTIMES n )
  55                                         ;(MLIST  m_LIST 1 )
  56                                         ;(MARROW  m_ARROW 1 )
  57                (nil m_push)
  58                ;; push arg.
  59                ( m_push_0)
  60                ( m_push_1)
  61                (m_push_2)
  62                (m_push_3)
  63                (m_push_i)
  64                ( m_pushl_0)
  65                ( m_pushl_1)
  66                (m_pushl_2)
  67                (m_pushl_3)
  68                (m_pushl_i)
  69                (m_pushc_0)
  70                (m_pushc_1)
  71                (m_pushc_2)
  72                (m_pushc_3)
  73                (m_pushc_4)
  74                (m_pushc_5)
  75                (m_pushc_6)
  76                (m_pushc_7)
  77                (m_pushc_8)
  78                (m_pushc_9)
  79                (m_pushc_i)
  80
  81                (m_end)
  82                (m_reserve)
  83
  84                (m_set_sp)
  85                (m_set_sp_frame_pointer)
  86                (m_return)
  87                ))
  88 (defmacro op-number (x)
  89   (let ((tem (assoc x *q-ops*)))
  90     (or tem  (error "unrecognized op ~a" x))
  91     (position tem *q-ops*)))
  92
  93 (defun write-execute ( &aux x)
  94   (with-open-file (st "execute.c" :direction :output)
  95
  96   (progn (format st
  97                  "#include \"plot.h\"
  98 #include \"emulate.h\"
  99 #include \"const.h\"
 100 struct value_function
 101 { char * body ;
 102   struct value *constants;
 103 };
 104 extern int s_p;
 105 extern struct value stack[];
 106
 107 enum m_ops {~%")
 108          (sloop for v in *q-ops* do (format st "~(~a~),~%"  (or (second v) (car v))))
 109          (format st "};~%"))
 110   (format st "execute_fun(f,n)
 111      struct value_function *f;
 112      int n;
 113 { unsigned char *body;
 114 /* frame_pointer points just beyond  last frames valid storage */
 115   struct value *frame_pointer = &stack[s_p -(n -1)];
 116   struct value *constants = f->constants;
 117   body = f->body;
 118   switch (*body)
 119     {
 120 ")
 121   (sloop for v in *q-ops* do (setq x (or (second v) (car v)))
 122      (format st "case ~(~a~): ~(f_~a~)(); break;~%"  x
 123              (subseq (symbol-name x) 2)))
 124   (format st " default:
 125       abort();
 126     }
 127  END: s_p = frame_pointer -stack -n;
 128  pop(frame_pointer);
 129  s_p = frame_pointer -stack -1;
 130  return 1;
 131 }")))
 132
 133 (defvar *max-locals* 0)
 134 (defvar *output* nil)
 135 (defvar *constants* (make-array 4 :fill-pointer 0))
 136 (defun push-constant (x)
 137   (let ((tem (position x *constants* :test 'eql)))
 138     (unless tem (setq tem (fill-pointer *constants*))
 139             (vector-push-extend x *constants*))
 140     (cond ((<= tem 9)
 141            (q-push (+ tem (op-number m_pushc_0)) 'constant))
 142           (t
 143              (q-push  (op-number m_pushc_i) 'constant)
 144              (q-push tem 'index)
 145              ))))
 146
 147 (defun compile-expr (expr arglist recursive locals push-result &aux tem n)
 148   (let ((*output* (if recursive *output*
 149                     (cons
 150                      (make-array 10 :element-type 'fixnum
 151                                 :fill-pointer 0)
 152                      (make-array 10 :element-type 'long-float
 153                                 :fill-pointer 0)))))
 154     (cond ( (not recursive)
 155             (setq *max-locals* 0)
 156             (setf (fill-pointer *constants* ) 0))
 157           (t
 158            (setq *max-locals* (max *max-locals* (length locals)))))
 159   (cond ((atom expr)
 160          (cond (push-result
 161                 (cond
 162                  ((setq tem (position expr locals))
 163                   (setq tem (- (length locals) tem))
 164                        (cond ((<= tem 3)
 165                               (q-push
 166                                (+ tem (op-number m_pushl_0))))
 167                              (t (q-push (op-number m_pushl_i *))
 168                                 (q-push tem 'index))))
 169                  ((setq tem (position expr arglist))
 170                        (cond ((<= tem 3)
 171                               (q-push
 172                                (+ tem (op-number m_push_0))))
 173                              (t (q-push (op-number m_push_i ))
 174                                 (q-push tem 'index))))
 175
 176                  ((numberp expr)
 177                        (push-constant expr))
 178                  (t (error "unrecognized constant: ~s" expr))))))
 179         ((eq (caar expr) 'mprog)
 180          (let* ((vars (cdr (second expr)))
 181                 (offset (length locals))
 182                 new-locals)
 183            (cond ((eql offset 0)
 184                   (q-push (op-number m_set_sp_frame_pointer )))
 185                  (t
 186                   (q-push (op-number m_set_sp ))
 187                   (q-push offset'index)))
 188            (sloop for v in vars
 189               do
 190               (cond ((symbolp v) (push v new-locals)
 191                      (push-constant 0))
 192                     ((and (consp v) (eq (caar v) 'msetq)
 193                           (symbolp (second v)))
 194                      (push (second v) new-locals)
 195                      (compile-expr (third v) arglist t locals t))))
 196         (setq new-locals (append new-locals locals))
 197         (sloop for v on (cddr expr)
 198            do
 199            (compile-expr (car v) arglist t new-locals (if (cdr v) nil t)))))
 200         ((eq (caar expr) 'mprogn)
 201          (sloop for v on (cdr expr)
 202               do
 203               (compile-expr (car v) arglist t locals (if (cdr v) nil t))))
 204         ((setq tem (assoc (caar expr) *q-ops*))
 205          (setq n (position tem *q-ops*))
 206          (dolist (v (cdr expr))
 207            (compile-expr v arglist t locals t))
 208          (q-push n   'call)
 209          (cond ((cdddr expr)
 210                 (cond
 211                  ((member (caar expr) '(mtimes mplus mminus mquotient))
 212                   (dolist (v (cdddr expr))
 213                     (q-push  n   'call)))
 214                  (t (error "unknown nary op ~a ~a args"
 215                            (caar expr) (length (cdr expr)))))))))))
 216
 217 (defun q-push  (i &optional (type 'instr))
 218   (format t "~%(~a) ~a" i
 219           (ecase type
 220             (call (second (nth i *q-ops*)))
 221             (instr  (or (second (nth i *q-ops*)) (car (nth i *q-ops*))))
 222             (index 'index)
 223             (constant (list
 224                        (or (second (nth i *q-ops*)) (car (nth i *q-ops*)))
 225                        (if  (< i (op-number m_pushc_i))
 226                            (aref *constants*
 227                                  (- i (op-number m_pushc_0)))))))))
 228
 229
 230
 231
 232
 233
 234
 235