diff --git a/scheme/ikarus.compiler.altcogen.ss b/scheme/ikarus.compiler.altcogen.ss index 22e8fdb..a66421a 100644 --- a/scheme/ikarus.compiler.altcogen.ss +++ b/scheme/ikarus.compiler.altcogen.ss @@ -534,7 +534,7 @@ (S (cadr rands) (lambda (s) (make-asm-instr op d s))))] - [(remainder) + [(int-quotient) (S* rands (lambda (rands) (seq* @@ -542,7 +542,7 @@ (make-asm-instr 'cltd edx eax) (make-asm-instr 'idiv eax (cadr rands)) (make-set d eax))))] - [(quotient) + [(int-remainder) (S* rands (lambda (rands) (seq* @@ -2308,9 +2308,12 @@ (unless (symbol? a) (error who "invalid arg to idiv")) (cond - [(disp? b) - (error who "invalid arg to idiv" b)] - [else x])] + [(or (var? b) (symbol? b)) x] + [else + (let ([u (mku)]) + (make-seq + (E (make-asm-instr 'move u b)) + (E (make-asm-instr 'idiv a u))))])] [(sll sra srl sll/overflow) (unless (or (constant? b) (eq? b ecx)) diff --git a/scheme/ikarus.fixnums.ss b/scheme/ikarus.fixnums.ss index 9e36544..cc1ff0d 100644 --- a/scheme/ikarus.fixnums.ss +++ b/scheme/ikarus.fixnums.ss @@ -171,7 +171,11 @@ (die 'fxquotient "not a fixnum" y)) (when ($fxzero? y) (die 'fxquotient "zero dividend" y)) - ($fxquotient x y))) + (if (eq? y -1) + (if (eq? x (least-fixnum)) + (die 'fxquotient "overflow" x y) + ($fx- 0 x)) + ($fxquotient x y)))) (define fxremainder (lambda (x y) diff --git a/scheme/ikarus.intel-assembler.ss b/scheme/ikarus.intel-assembler.ss index 25bb43a..bfdfc25 100644 --- a/scheme/ikarus.intel-assembler.ss +++ b/scheme/ikarus.intel-assembler.ss @@ -682,7 +682,7 @@ [(idivl dst) (cond [(reg? dst) (CR* #xF7 '/7 dst ac)] - [(mem? dst) (CR* #xF7 '/7 dst ac)] + [(mem? dst) (CR* #xF7 '/7 dst ac)] [else (die who "invalid" instr)])] [(pushl dst) (cond diff --git a/scheme/ikarus.numerics.ss b/scheme/ikarus.numerics.ss index 87f13d3..b8ed143 100644 --- a/scheme/ikarus.numerics.ss +++ b/scheme/ikarus.numerics.ss @@ -1632,6 +1632,15 @@ (string-append ($number->string xr r) (imag xi r) "i")]))] [else (die 'number->string "not a number" x)]))) + (define do-warn + (lambda () + (set! do-warn values) + (raise-continuable + (condition + (make-warning) + (make-who-condition 'number->string) + (make-message-condition + "precision argument is not supported"))))) (define number->string (case-lambda [(x) ($number->string x 10)] @@ -1640,8 +1649,8 @@ (die 'number->string "invalid radix" r)) ($number->string x r)] [(x r precision) - (die 'number->string - "BUG: precision is not supported yet")]))) + ;(do-warn) + (number->string x r)]))) (define modulo (lambda (n m) @@ -2412,8 +2421,9 @@ [(fixnum? x) (cond [(fixnum? y) - (values (fxquotient x y) - (fxremainder x y))] + (if (eq? y -1) + (values (- x) 0) + (values (fxquotient x y) (fxremainder x y)))] [(bignum? y) (values 0 x)] [(flonum? y) (let ([v ($flonum->exact y)]) @@ -3235,6 +3245,7 @@ [(and (fixnum? n) (fixnum? m)) (cond [(eq? m 0) (error 'div "division by 0")] + [(eq? m -1) (- n)] [else (let ([d0 ($fxquotient n m)]) (if ($fx>= n ($fx* d0 m)) diff --git a/scheme/last-revision b/scheme/last-revision index 6b6c6e5..a2e0f14 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1553 +1554 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index 0daa781..794078a 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -495,6 +495,8 @@ [$fxsra $fx] [$fxquotient $fx] [$fxmodulo $fx] + [$int-quotient $fx] + [$int-remainder $fx] [$fxlogxor $fx] [$fxlogor $fx] [$fxlognot $fx] diff --git a/scheme/pass-specify-rep-primops.ss b/scheme/pass-specify-rep-primops.ss index 188b174..44b1b2a 100644 --- a/scheme/pass-specify-rep-primops.ss +++ b/scheme/pass-specify-rep-primops.ss @@ -896,18 +896,24 @@ (define-primop $fxquotient unsafe [(V a b) (with-tmp ([b (T b)]) ;;; FIXME: why is quotient called remainder? - (prm 'sll (prm 'remainder (T a) b) (K fx-shift)))] + (prm 'sll (prm 'int-quotient (T a) b) (K fx-shift)))] [(P a b) (K #t)] [(E a b) (nop)]) +(define-primop $int-quotient unsafe + [(V a b) + (prm 'sll (prm 'int-quotient (T a) (T b)) (K fx-shift))]) + +(define-primop $int-remainder unsafe + [(V a b) (prm 'int-remainder (T a))]) (define-primop $fxmodulo unsafe [(V a b) - (with-tmp ([b (T b)]) ;;; FIXME: why is modulo called quotient? + (with-tmp ([b (T b)]) (with-tmp ([c (prm 'logand b (prm 'sra (prm 'logxor b (T a)) (K (sub1 (* 8 wordsize)))))]) - (prm 'int+ c (prm 'quotient (T a) b))))] + (prm 'int+ c (prm 'int-remainder (T a) b))))] [(P a b) (K #t)] [(E a b) (nop)]) diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss index fdee4cf..6131409 100644 --- a/scheme/psyntax.expander.ss +++ b/scheme/psyntax.expander.ss @@ -1722,12 +1722,15 @@ (let-values (((lhs* rhs* q) (quasi q lev))) (if (= lev 0) (let ((g (gensym))) - (values (cons `(,g ...) lhs*) (cons p rhs*) - `(,g ... . ,q))) + (values + (cons `(,g ...) lhs*) + (cons p rhs*) + `(,g ... . ,q))) (let-values (((lhs2* rhs2* p) (quasi p (- lev 1)))) - (values (append lhs2* lhs*) - (append rhs2* rhs*) - `((unsyntax-splicing ,p) . ,q)))))) + (values + (append lhs2* lhs*) + (append rhs2* rhs*) + `((unsyntax-splicing ,p) . ,q)))))) (unsyntax-splicing (= lev 0) (stx-error p "incorrect use of unsyntax-splicing")) ((quasisyntax p) diff --git a/scheme/tests/div-and-mod.ss b/scheme/tests/div-and-mod.ss index 960e0e7..720c878 100644 --- a/scheme/tests/div-and-mod.ss +++ b/scheme/tests/div-and-mod.ss @@ -40,7 +40,10 @@ (test +3 -7/11) (test -3 -7/11) - + (test (least-fixnum) -1) + (test (least-fixnum) 1) + (test (greatest-fixnum) -1) + (test (greatest-fixnum) 1) )