;;;-*- Mode:LISP; Package:NEW-MATH; Base:10; Readtable:CL -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum multiply ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun multiply-fixnum (x y) (hw::load-q-register x) (let* ((high-half (hw:signed-multiply-step y (hw:signed-multiply-step y (hw:signed-multiply-step y (hw:signed-multiply-step y (hw:signed-multiply-step y (hw:signed-multiply-step y (hw:signed-multiply-step y (hw:signed-multiply-step y (hw:signed-multiply-step y (hw:signed-multiply-step y (hw:signed-multiply-step y (hw:signed-multiply-first-step y 0))))))))))))) (low-half (hw::read-q-register-boxed)) (sign (hw::ldb low-half vinc:%%bignum-sign-high-word 0))) (if (zerop (hw:24+ high-half sign)) low-half ;; We overflowed, make a bignum (let ((bignum-high (hw:32-sign-extend (hw:32arithmetic-shift-down high-half (byte-size vinc:%%fixnum-non-data)))) (bignum-low (hw:dpb-unboxed high-half vinc:%%fixnum-non-data low-half))) (if (hw:32zerop (hw:32+ bignum-high (hw:ldb bignum-low vinc:%%bignum-sign-high-word gr:*all-zero*))) (make-bignum-32-get-neg-status bignum-low) (make-bignum-64-get-neg-status bignum-high bignum-low)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum divide ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun divide-fixnum (dividend divisor) (when (zerop divisor) (li:error "Zero divide" dividend divisor)) ;;Seems like we need to load-q-reg here. --wkf (let* ((almost-remainder (hw:signed-divide-last1 divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-step divisor (hw:signed-divide-first-step divisor (hw:24-sign-fill (hw:load-q-register dividend)) )))))))))))))))))))))))))) (cruft (hw:signed-divide-last2 divisor almost-remainder)) (remainder(hw:remainder-correct divisor almost-remainder)) (quotient (hw:quotient-correct (hw:read-q-register-boxed)))) (if (hw:alu-status-logbitp hw:%%alu-status-overflow) (values quotient remainder) (values (array:make-bignum-32 (hw:unboxed-constant #x800000)) remainder))));;answer is most-neg-fix divided by -1. --wkf (defun truncate-fixnum (dividend divisor) (divide-fixnum dividend divisor)) (defun floor-fixnum (dividend divisor) (multiple-value-bind (quotient remainder) (divide-fixnum dividend divisor) (if (or (and (minusp quotient) (not (zerop remainder))) (minusp remainder)) (values (1- quotient) (+ remainder divisor)) (values quotient remainder)))) (defun ceiling-fixnum (dividend divisor) (multiple-value-bind (quotient status remainder) (divide-fixnum dividend divisor) (if (or (and (plusp quotient) (not (zerop remainder))) (plusp remainder)) (values (1+ quotient) (- remainder divisor)) (values quotient remainder)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum add that may overflow ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun add-fixnum (x y) (let ((sum24 (hw:24+ x y)) (status (hw:read-alu-status))) (if (hw:32logbitp hw:%%alu-status-overflow status) (make-bignum-32-get-neg-status (hw:32+ (hw:32-sign-extend x) (hw:32-sign-extend y))) (values sum24 status)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum subtract that may overflow ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun subtract-fixnum (x y) (let ((diff24 (hw:24- x y)) (status (hw:read-alu-status))) (if (hw:32logbitp hw:%%alu-status-overflow status) (make-bignum-32-get-neg-status (hw:32- (hw:32-sign-extend x) (hw:32-sign-extend y))) (values diff24 status)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum compare ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compare-fixnum (x y) (values (hw:24- x y) (hw:read-alu-status))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum compare ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun test-fixnum (x) (values x (hw:read-alu-status))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum negate that may overflow ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun negate-fixnum (x) (if (= x li:most-negative-fixnum) (values (array:make-bignum-32 (hw:unboxed-constant #x800000)) hw:$$alu-status-positive)) (values (- x) (hw:read-alu-status))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum field pass ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun field-pass-fixnum (x y byte-spec ldb-p) (multiple-value-bind (hard size position) (resolve-byte-spec byte-spec ldb-p) (if hard (field-pass-bignum-internal (convert-fixnum-to-bignum x) (convert-fixnum-to-bignum y) byte-spec position size) ;; (ALU FIELD-PASS ...) ;; does dpb if (byte-position byte-spec) is positive ;; does ldb if (byte-position byte-spec) is negative ;; pfc 5/25 (values (if ldb-p (hw:ldb x byte-spec y) (hw:dpb x byte-spec y)) (hw:read-alu-status))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Resolve byte specifier ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun resolve-byte-spec-internal (bs ldb-p) (multiple-value-bind (size position) (if (vinc:fixnump bs) (let ((fsize (hw:ldb bs vinc:%%byte-size 0))) (values (if (zerop fsize) 32. fsize) (li:byte-position-fixnum bs))) (values (cons:car bs) (cons:cdr bs))) (when (< size 1) (li:error "Illegal size in byte specifier" size)) (when ldb-p (setq position (- position))) (values size position))) (defun resolve-byte-spec (bs ldb-p) (multiple-value-bind (size position) (resolve-byte-spec-internal bs ldb-p) ; fixed --pfc 4/25 (if (or (and (<= position 0) ; big ldb's are hard (<= (- size position) 24.)) ; allowed to ldb from sign bit !! (and (not (minusp position)) ; big dpb's are hard (<= (+ position size) 23.))) ; not allowed to dpb into sign bit !! (values nil size position) ; not hard (values t size position)))) ; hard (defun byte-position (bs) ;;@@@ Do we need definition other than one in arithmetic.lisp? --wkf (if (vinc:fixnump bs) (li:byte-position-fixnum bs) (cons:cdr bs))) (defun byte-size (bs) ;;@@@ Do we need definition other than one in arithmetic.lisp? --wkf (if (vinc:fixnump bs) (let ((fsize (hw:ldb bs vinc:%%byte-size 0))) (if (zerop fsize) 32. fsize)) (cons:car bs))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum ash ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ash-fixnum (i shift) (when (not (vinc:fixnump shift)) (li:error "Bad shift to ash, must be a fixnum" i shift)) (let* ((big-i (hw:32-sign-extend i))) (if (minusp shift) (let ((x-shift (if (< shift -24.) -32. shift))) (values (vinc:make-fixnum (hw:32arithmetic-shift-up big-i x-shift)) ;;negative shift is down. (hw:read-alu-status))) (let* ((raw-i (if (minusp i) (hw:ldb-not i vinc:%%fixnum-field 0) i)) (unused-bits (vinc:make-fixnum (hw:24-prioritize raw-i)))) (if (>= shift unused-bits) (ash-bignum (convert-fixnum-to-bignum i) shift) (values (vinc:make-fixnum (hw:32logical-shift-up big-i shift)) (hw:read-alu-status))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum logand ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun logand-fixnum (x y) (logand x y)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum logior ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun logior-fixnum (x y) (logior x y)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum logxor ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun logxor-fixnum (x y) (logxor x y)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum logxnor ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun logxnor-fixnum (x y) (logeqv x y)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Fixnum lognot ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun lognot-fixnum (x) (lognot x)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; For slightly large fixnums ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;********************************** ;;;* * ;;;* ALLOCATING STORAGE FOR BIGNUMS * ;;;* * ;;;********************************** (defun allocate-bignum (size) (unless (and (plusp size) (< size #x40000)) (li:error "Bad size to allocate-bignum" size)) (cons::allocate-structure 1 size $$dtp-bignum (cons:make-header $$dtp-unboxed-header size))) ;;;********************************** ;;;* * ;;;* SHRINK BIGNUM STRUCTURE * ;;;* * ;;;********************************** (defun shrink-bignum-structure (bignum-ptr) (let* ((size (hw:ldb (array:%vm-read bignum-ptr 0) vinc::%%pointer gr:*all-zero*)) (high-word (array:%vm-read32 bignum-ptr size)) (new-size size)) (labels ((reduce-bignum (new-size new-high-word) (setq new-size (hw:32-1- new-size)) (if (hw:32zerop new-size) (if (or (hw:field= new-high-word gr:*all-zero* vinc:%%fixnum-sign-and-datatype) (hw:field= new-high-word (hw:unboxed-constant #xFF800000) vinc:%%fixnum-sign-and-datatype)) (values (hw:ldb-boxed new-high-word vinc::%%fixnum-field 0) (hw:read-alu-status)) (progn (array:%vm-write32 bignum-ptr 2 (cons:make-header $$dtp-unboxed-header (- size 2))) ;;+++ Above is ready to be garbage collected. Should we have a special datatype for this? --wkf (array:%vm-write bignum-ptr (cons:make-header $$dtp-unboxed-header 1)) (values bignum-ptr (hw:dpb (hw:ldb new-high-word vinc:%%bignum-sign-high-word 0) hw:%%alu-status-negative 0)))) (let ((next-word (array:%vm-read32 bignum-ptr new-size))) (if (hw:32zerop (hw:32+ new-high-word (hw:ldb next-word vinc:%%bignum-sign-high-word gr:*all-zero*))) (reduce-bignum new-size next-word) (values bignum-ptr (hw:dpb (hw:ldb new-high-word vinc:%%bignum-sign-high-word 0) hw:%%alu-status-negative 0))))))) (reduce-bignum size high-word)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Allocate Bignums and get their status, negative or positive, don't check for zero. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun make-bignum-32-get-neg-status (bignum-word) "Does not detect zero status." (let ((ptr (cons:allocate-structure 1 1 $$dtp-bignum (cons:make-header $$dtp-unboxed-header 1)))) (%vm-write32 ptr 1 bignum-word) (values ptr (hw:dpb (hw:ldb bignum-word vinc:%%bignum-sign-high-word 0) hw:%%alu-status-negative 0)))) (defun make-bignum-64-get-neg-status (bignum-word-high bignum-word-low) "Does not detect zero status." (let ((ptr (cons:allocate-structure 1 2 $$dtp-bignum (cons:make-header $$dtp-unboxed-header 2)))) (%vm-write32 ptr 1 bignum-word-low) (%vm-write32 ptr 2 bignum-word-high) (values ptr (hw:dpb (hw:ldb bignum-word-high vinc:%%bignum-sign-high-word 0) hw:%%alu-status-negative 0))))