archive/src/rat3f.lisp

   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 (import '(compiler::inline-unsafe compiler::inline-always compiler::boolean
  13     compiler::definline ) 'cl-maxima)
  14 (macsyma-module rat3f)
  15
  16 (clines "#include \"rat3f-hc.c\"")
  17
  18
  19 ;;plan make file crat.c to include in the macsyma build
  20 ;;it will have the necessary primitives, and we will then
  21 ;;put inline things for ctimes,...
  22 ;;the symbol-value cell of modulus will be snarfed, and
  23 ;;consulted by the ctimes and friends.
  24 ;; make #ifdef MC68020 for the ftimes and dblrem stuff,
  25 ;; but add defs that will work on the vax.
  26 ;;kclrat.lisp file to be loaded before compiling rat3a
  27 ;;cplus,etc commented out for kcl
  28
  29
  30 (eval-when (compile)
  31   (setf (get 'cload-time 'compiler::t1) #'(lambda (&rest l)
  32                                            (push (list 'load-time (car l))
  33                                                  compiler::*top-level-forms*)))
  34   (setf (get 'cload-time 'compiler::t2) #'(lambda (&rest l)
  35                                             (apply 'compiler::wt-nl (car l)))))
  36
  37
  38
  39
  40 (defmacro definline
  41     (property return-type side-effect-p new-object-p name arg-types
  42             body)
  43  `(push
  44          '(,arg-types ,return-type ,side-effect-p ,new-object-p ,body)
  45         (get ',name ',property)))
  46
  47
  48
  49 ;;the bignum mod does not work.
  50 ;(defentry fplus  (object object) (object fplus))
  51 (defentry fplus  (int int) (object fplus))
  52 (defentry my-mcmod  (object object) (object mcmod))
  53 (defentry myctimes  (object object object) (object ctimes))
  54 (defentry mycplus  (object object object) (object cplus))
  55 (defentry mycdifference  (object object object) (object cdifference))
  56 (defentry my-doublerem (int int int) (int dblrem))
  57 (defentry plusrem (int int int) (int plusrem))
  58 (defentry subrem (int int int) (int subrem))
  59
  60 (defun new-ctimes (x y)
  61    (myctimes x y modulus))
  62
  63 (defun new-cplus (x y)
  64    (mycplus x y modulus))
  65
  66 (defun new-cdifference (x y)
  67    (mycdifference x y modulus))
  68
  69 (defun cdiff (x y)
  70   (let ((res (mod (- x y) modulus)))
  71     (cond ((> res (floor modulus 2))
  72            (- (mod res modulus) modulus))
  73           (t res))))
  74
  75
  76 #+debug
  77 (defun comp (modulus &aux (bi most-positive-fixnum) (li most-negative-fixnum)
  78                ( lis (list bi bi li (+ bi 1) (- li 3) )))
  79   (sloop for u in lis
  80          do (sloop for w in lis
  81                    when (not (equal (new-cplus u w) (cplus u w)))
  82                    do (print (list 'bad (list u w (fixnump u)(fixnump w)))))))
  83
  84 #+debug
  85 (defun comp (modulus &aux (bi most-positive-fixnum) (li most-negative-fixnum)
  86                ( lis (list 7 8 bi bi li (+ bi 1) (- li 3) )))
  87   (sloop for u in lis
  88          do (sloop for w in lis with nans and ans
  89                    when (not (equal (setq nans (new-cdifference u w))
  90                                     (setq ans(cdiff u w))))
  91                    do (print (list 'bad nans ans (list u w (fixnump u)(fixnump w)))))))
  92 ;(BAD (2147483647 -2147483648 T T))
  93
  94 #+debug
  95 (defun te (x n)
  96   (let ((a (my-mcmod x n))
  97         (b (let ((modulus n)) (mcmod x n))))
  98     (list (- a b) a b)))
  99
 100
 101 #+debug
 102 (defun te (x n)
 103   (let ((a (+ x n))
 104         (b (fplus x n)))
 105     (list (- a b) a b)))
 106
 107 #+debug
 108 (progn
 109  (setf (symbol-function 'cplus) (symbol-function 'new-cplus))
 110  (setf (symbol-function 'ctimes) (symbol-function 'new-ctimes))
 111  (setf (symbol-function 'cdifference) (symbol-function 'new-cdifference)))
 112
 113
 114 (progn
 115 (proclaim '(function ptimes (t t) t))
 116 (proclaim '(function ptimes1 (t t) t))
 117 (proclaim '(function pctimes (t t) t))
 118 (proclaim '(function pctimes1 (t t) t))
 119
 120 (proclaim '(function pplus (t t) t))
 121 (proclaim '(function ptptplus (t t) t))
 122 (proclaim '(function pcplus (t t) t))
 123 (proclaim '(function pcplus1 (t t) t))
 124
 125 (proclaim '(function pdifference (t t) t))
 126 (proclaim '(function ptptdiffer (t t) t))
 127 (proclaim '(function pcdiffer (t t) t))
 128 (proclaim '(function ptcdiffer (t t) t))
 129
 130
 131 (proclaim '(function psimp1 (t t) t))
 132 (proclaim '(function palgsimp (t t t) t))
 133 (proclaim '(function alg (t) t))
 134
 135 (definline inline-always boolean nil nil pointergp (t t)
 136            "((fix((#0)->s.s_dbind)) > fix(((#1)->s.s_dbind)))")
 137
 138
 139 (definline inline-always boolean nil nil pzerop (t )
 140   "(type_of(#0)==t_fixnum ?  (fix(#0)==0)
 141        :type_of(#0)==t_shortfloat ? (sf(#0)==0.0)
 142        :(type_of(#0)==t_longfloat && (lf(#0)==0.0)))")
 143
 144
 145 )
 146
 147 ;;fix pzerop to maybe assume fixnum or bignum entry??
 148 ;;thus just == will work!!
 149
 150
 151
 152
 153 #+debug
 154 (defun comp (
 155   &aux (bi most-positive-fixnum) (li most-negative-fixnum)
 156                ( lis (list bi bi li (+ bi 1) (- li 3) ))
 157                (moduli (list nil 23 47 bi (+ bi 10)))
 158                (funs '(new-cdifference cdifference new-ctimes
 159                                        ctimes new-cplus cplus)))
 160   (sloop for (fun1 fun2) on funs by 'cddr
 161          do
 162   (sloop for m in moduli
 163           do
 164           (let ((modulus m))
 165   (sloop for u in lis
 166          do (sloop for w in lis
 167                    do (setq u (cmod u) w (cmod w))
 168                    when (not (equal (setq ans1(funcall fun1 u w))
 169                                     (setq ans2(funcall fun2 u w))))
 170                    do (print
 171                        (list 'bad ans1 ans2
 172                              (list fun1 u w modulus
 173                                    (fixnump u)(fixnump w)(fixnump modulus)))
 174                        )))))))