mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +02:00
Code Activity

Merge remote-tracking branch 'origin/stable-2.0'

Browse source
This commit is contained in:
Mark H Weaver 2013-08-12 21:36:45 -04:00
commit 79a6c3be6a
1 changed files with 20 additions and 25 deletions
Download patch file Download diff file Expand all files Collapse all files

43
module/language/tree-il/primitives.scm
View file

@ -20,6 +20,7 @@
(define-module (language tree-il primitives) (define-module (language tree-il primitives)
#:use-module (system base pmatch) #:use-module (system base pmatch)
#:use-module (ice-9 match)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (system base syntax) #:use-module (system base syntax)
#:use-module (language tree-il) #:use-module (language tree-il)
@ -199,8 +200,7 @@
(define *negatable-primitives* (define *negatable-primitives*
'((even? . odd?) '((even? . odd?)
(exact? . inexact?) (exact? . inexact?)
(< . >=) ;; (< <= > >=) are not negatable because of NaNs.
(> . <=)
(char<? . char>=?) (char<? . char>=?)
(char>? . char<=?))) (char>? . char<=?)))
@ -351,13 +351,14 @@
(else (error "bad consequent yall" exp)))) (else (error "bad consequent yall" exp))))
`(hashq-set! *primitive-expand-table* `(hashq-set! *primitive-expand-table*
',sym ',sym
(case-lambda (match-lambda*
,@(let lp ((in clauses) (out '())) ,@(let lp ((in clauses) (out '()))
(if (null? in) (if (null? in)
(reverse (cons '(else #f) out)) (reverse (cons '(_ #f) out))
(lp (cddr in) (lp (cddr in)
(cons `((src . ,(car in)) (cons `((src . ,(car in))
,(consequent (cadr in))) out))))))) ,(consequent (cadr in)))
out)))))))
(define-primitive-expander zero? (x) (define-primitive-expander zero? (x)
(= x 0)) (= x 0))
@ -367,50 +368,44 @@
(define-primitive-expander + (define-primitive-expander +
() 0 () 0
(x) (values x) (x) (values x)
(x y) (if (and (const? y) (x y) (if (and (const? y) (eqv? (const-exp y) 1))
(let ((y (const-exp y)))
(and (number? y) (exact? y) (= y 1))))
(1+ x) (1+ x)
(if (and (const? y) (if (and (const? y) (eqv? (const-exp y) -1))
(let ((y (const-exp y)))
(and (number? y) (exact? y) (= y -1))))
(1- x) (1- x)
(if (and (const? x) (if (and (const? x) (eqv? (const-exp x) 1))
(let ((x (const-exp x)))
(and (number? x) (exact? x) (= x 1))))
(1+ y) (1+ y)
(+ x y)))) (if (and (const? x) (eqv? (const-exp x) -1))
(x y z . rest) (+ x (+ y z . rest))) (1- y)
(+ x y)))))
(x y z ... last) (+ (+ x y . z) last))
(define-primitive-expander * (define-primitive-expander *
() 1 () 1
(x) (values x) (x) (values x)
(x y z . rest) (* x (* y z . rest))) (x y z ... last) (* (* x y . z) last))
(define-primitive-expander - (define-primitive-expander -
(x) (- 0 x) (x) (- 0 x)
(x y) (if (and (const? y) (x y) (if (and (const? y) (eqv? (const-exp y) 1))
(let ((y (const-exp y)))
(and (number? y) (exact? y) (= y 1))))
(1- x) (1- x)
(- x y)) (- x y))
(x y z . rest) (- x (+ y z . rest))) (x y z ... last) (- (- x y . z) last))
(define-primitive-expander / (define-primitive-expander /
(x) (/ 1 x) (x) (/ 1 x)
(x y z . rest) (/ x (* y z . rest))) (x y z ... last) (/ (/ x y . z) last))
(define-primitive-expander logior (define-primitive-expander logior
() 0 () 0
(x) (logior x 0) (x) (logior x 0)
(x y) (logior x y) (x y) (logior x y)
(x y z . rest) (logior x (logior y z . rest))) (x y z ... last) (logior (logior x y . z) last))
(define-primitive-expander logand (define-primitive-expander logand
() -1 () -1
(x) (logand x -1) (x) (logand x -1)
(x y) (logand x y) (x y) (logand x y)
(x y z . rest) (logand x (logand y z . rest))) (x y z ... last) (logand (logand x y . z) last))
(define-primitive-expander caar (x) (car (car x))) (define-primitive-expander caar (x) (car (car x)))
(define-primitive-expander cadr (x) (car (cdr x))) (define-primitive-expander cadr (x) (car (cdr x)))