\f
(define (summarize-test-results results)
(let ((failing-results (filter failing-test-result? results)))
+ (for-each show-failing-result failing-results)
(if (summarize?)
(begin
(let ((failures (length failing-results))
(write failures)
(display " failure")
(if (not (= 1 failures))
- (display "s")))
- (for-each summarize-failing-result failing-results)))
+ (display "s")))))
(null? failing-results)))
(define (failing-test-result? result)
(pair? (cdr result)))
-(define (summarize-failing-result failure)
+(define (show-failing-result failure)
(newline)
(newline)
(display "evaluating ")
#include "scheme.h"
#include "prims.h"
+#include "bits.h"
#include "fixnum.h"
static long
}
}
+DEFINE_PRIMITIVE ("FXBIT-COUNT", Prim_fxbit_count, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+ FIXNUM_RESULT (ulong_bit_count ((unsigned long) (arg_fixnum(1))));
+}
+
+DEFINE_PRIMITIVE ("FXLENGTH", Prim_fxlength, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+ long n = (arg_fixnum(1));
+ FIXNUM_RESULT (ulong_length_in_bits ((unsigned long) ((n < 0) ? ~n : n)));
+}
+
+DEFINE_PRIMITIVE ("FXFIRST-SET-BIT", fxfirst_set_bit, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+ FIXNUM_RESULT (ulong_first_set_bit ((unsigned long) (arg_fixnum(1))));
+}
+
DEFINE_PRIMITIVE ("FIXNUM->FLONUM", Prim_fixnum_to_flonum, 1, 1,
"(FIXNUM)\n\
Equivalent to (INTEGER->FLONUM FIXNUM 2)")
(define-standard-library '(srfi 131)
'(define-record-type))
\f
+(define-standard-library '(srfi 143)
+ '(fixnum?
+ fx*
+ fx*/carry
+ fx+
+ fx+/carry
+ fx-
+ fx-/carry
+ fx-greatest
+ fx-least
+ fx-width
+ fx<=?
+ fx<?
+ fx=?
+ fx>=?
+ fx>?
+ fxabs
+ fxand
+ fxarithmetic-shift
+ fxarithmetic-shift-left
+ fxarithmetic-shift-right
+ fxbit-count
+ fxbit-field
+ fxbit-field-reverse
+ fxbit-field-rotate
+ fxbit-set?
+ fxcopy-bit
+ fxeven?
+ fxfirst-set-bit
+ fxif
+ fxior
+ fxlength
+ fxmax
+ fxmin
+ fxneg
+ fxnegative?
+ fxnot
+ fxodd?
+ fxpositive?
+ fxquotient
+ fxremainder
+ fxsqrt
+ fxsquare
+ fxxor
+ fxzero?))
+\f
;;;; Synthetic libraries
;;; A synthetic library is one that's derived from legacy packages, much like a
'<= exact-nonnegative-integer?)
(register-predicate! non-positive-fixnum? 'non-positive-fixnum
'<= fix:fixnum?)
- (register-predicate! radix? 'radix '<= index-fixnum?)
+ (register-predicate! radix? 'radix '<= non-negative-fixnum?)
(register-predicate! flo:flonum? 'flonum '<= real?)
(register-predicate! thread-mutex? 'thread-mutex)
(register-predicate! undefined-value? 'undefined-value)
(register-predicate! unicode-code-point? 'unicode-code-point
- '<= index-fixnum?)
+ '<= non-negative-fixnum?)
(register-predicate! unicode-scalar-value? 'unicode-scalar-value
'<= unicode-code-point?)
(register-predicate! uninterned-symbol? 'uninterned-symbol '<= symbol?)
;;;; Fixnums
(define-primitives
+ (%fx<? less-than-fixnum? 2)
+ (%fx=? equal-fixnum? 2)
+ (%fx>? greater-than-fixnum? 2)
+ (%fxand fixnum-and 2)
+ (%fxior fixnum-or 2)
+ (%fxxor fixnum-xor 2)
+ (fix:andc fixnum-andc 2)
(fix:divide divide-fixnum 2)
(fix:gcd gcd-fixnum 2)
(fixnum? fixnum? 1)
(fx* multiply-fixnum 2)
(fx+ plus-fixnum 2)
(fx- minus-fixnum 2)
- (fx<? less-than-fixnum? 2)
- (fx=? equal-fixnum? 2)
- (fx>? greater-than-fixnum? 2)
- (fxand fixnum-and 2)
- (fxandc fixnum-andc 2)
(fxarithmetic-shift fixnum-lsh 2)
+ (fxbit-count fxbit-count 1)
(fxdecr minus-one-plus-fixnum 1)
+ (fxfirst-set-bit fxfirst-set-bit 1)
(fxincr one-plus-fixnum 1)
- (fxior fixnum-or 2)
+ (fxlength fxlength 1)
(fxnegative? negative-fixnum? 1)
(fxnot fixnum-not 1)
(fxpositive? positive-fixnum? 1)
(fxquotient fixnum-quotient 2)
(fxremainder fixnum-remainder 2)
- (fxxor fixnum-xor 2)
(fxzero? zero-fixnum? 1)
(non-negative-fixnum? index-fixnum? 1))
-(define (fx<=? n m) (not (fx>? n m)))
-(define (fx>=? n m) (not (fx<? n m)))
(define (fxabs n) (if (fx<? n 0) (fx- 0 n) n))
(define (fxarithmetic-shift-right n m) (fxarithmetic-shift n (fx- 0 m)))
-(define (fxmax n m) (if (fx>? n m) n m))
-(define (fxmin n m) (if (fx<? n m) n m))
(define (fxneg n) (fx- 0 n))
(define (fxsquare n) (fx* n n))
(define (non-positive-fixnum? object)
(and (fixnum? object)
(not (fxpositive? object))))
+
+(define (fxodd? n)
+ (fix:= (fix:and n 1) 1))
+
+(define (fxeven? n)
+ (fix:= (fix:and n 1) 0))
+\f
+(define (fx<? n m . rest)
+ (let loop ((n n) (m m) (rest rest))
+ (if (pair? rest)
+ (and (%fx<? n m)
+ (loop m (car rest) (cdr rest)))
+ (%fx<? n m))))
+
+(define (fx<=? n m . rest)
+ (let loop ((n n) (m m) (rest rest))
+ (if (pair? rest)
+ (and (not (%fx>? n m))
+ (loop m (car rest) (cdr rest)))
+ (not (%fx>? n m)))))
+
+(define (fx=? n m . rest)
+ (let loop ((n n) (m m) (rest rest))
+ (if (pair? rest)
+ (and (%fx=? n m)
+ (loop m (car rest) (cdr rest)))
+ (%fx=? n m))))
+
+(define (fx>? n m . rest)
+ (let loop ((n n) (m m) (rest rest))
+ (if (pair? rest)
+ (and (%fx>? n m)
+ (loop m (car rest) (cdr rest)))
+ (%fx>? n m))))
+
+(define (fx>=? n m . rest)
+ (let loop ((n n) (m m) (rest rest))
+ (if (pair? rest)
+ (and (not (%fx<? n m))
+ (loop m (car rest) (cdr rest)))
+ (not (%fx<? n m)))))
+
+(define (fxmax n m . rest)
+ (let loop ((n n) (m m) (rest rest))
+ (if (pair? rest)
+ (loop (if (fx>? n m) n m) (car rest) (cdr rest))
+ (if (fx>? n m) n m))))
+
+(define (fxmin n m . rest)
+ (let loop ((n n) (m m) (rest rest))
+ (if (pair? rest)
+ (loop (if (fx<? n m) n m) (car rest) (cdr rest))
+ (if (fx<? n m) n m))))
+
+(define (fxand n m . rest)
+ (let loop ((n n) (m m) (rest rest))
+ (if (pair? rest)
+ (loop (%fxand n m) (car rest) (cdr rest))
+ (%fxand n m))))
+
+(define (fxior n m . rest)
+ (let loop ((n n) (m m) (rest rest))
+ (if (pair? rest)
+ (loop (%fxior n m) (car rest) (cdr rest))
+ (%fxior n m))))
+
+(define (fxxor n m . rest)
+ (let loop ((n n) (m m) (rest rest))
+ (if (pair? rest)
+ (loop (%fxxor n m) (car rest) (cdr rest))
+ (%fxxor n m))))
+\f
+(define (fx+/carry i j k)
+ (let ((sum (+ i j k)))
+ (receive (q r) (balanced/ sum unsigned-limit)
+ (values r q))))
+
+(define (fx-/carry i j k)
+ (let ((diff (- i j k)))
+ (receive (q r) (balanced/ diff unsigned-limit)
+ (values r q))))
+
+(define (fx*/carry i j k)
+ (let ((prod (+ (* i j) k)))
+ (receive (q r) (balanced/ prod unsigned-limit)
+ (values r q))))
+
+(define (balanced/ x y)
+ (receive (q r) (euclidean/ x y)
+ (cond ((< r (abs (/ y 2)))
+ (values q r))
+ ((> y 0)
+ (values (+ q 1) (- x (* (+ q 1) y))))
+ (else
+ (values (- q 1) (- x (* (- q 1) y)))))))
+
+(define (euclidean/ n d)
+ (if (and (exact-integer? n) (exact-integer? d))
+ (cond ((and (negative? n) (negative? d))
+ (ceiling-/- n d))
+ ((negative? n)
+ (floor-/+ n d))
+ ((negative? d)
+ (let ((d (- 0 d)))
+ (values (- 0 (quotient n d))
+ (remainder n d))))
+ (else
+ (values (quotient n d)
+ (remainder n d))))
+ (let ((q
+ (if (negative? d)
+ (ceiling (/ n d))
+ (floor (/ n d)))))
+ (values q (- n (* d q))))))
+
+(define (floor-/+ n d)
+ (let ((n (- 0 n)))
+ (let ((q (quotient n d))
+ (r (remainder n d)))
+ (if (zero? r)
+ (values (- 0 q) r)
+ (values (- (- 0 q) 1) (- d r))))))
+
+(define (ceiling-/- n d)
+ (let ((n (- 0 n)) (d (- 0 d)))
+ (let ((q (quotient n d))
+ (r (remainder n d)))
+ (if (zero? r)
+ (values q r)
+ (values (+ q 1) (- d r))))))
+\f
+(define (fxif mask i j)
+ (fxior (fxand mask i)
+ (fxand (fxnot mask) j)))
+
+(define (fxbit-set? index i)
+ (if (not (fx<? index fx-width))
+ (error:bad-range-argument index 'fxbit-set?))
+ (not (fxzero? (fxand (fxarithmetic-shift-left 1 index) i))))
+
+(define (fxcopy-bit index i boolean)
+ (if (not (fx<? index fx-width))
+ (error:bad-range-argument index 'fxcopy-bit))
+ (if boolean
+ (fxior i (fxarithmetic-shift-left 1 index))
+ (fxand i (fxnot (fxarithmetic-shift-left 1 index)))))
+
+(define (fxbit-field i start end)
+ (if (not (fx<=? end fx-width))
+ (error:bad-range-argument end 'fxbit-field))
+ (if (not (fx<=? start end))
+ (error:bad-range-argument start 'fxbit-field))
+ (fxand (fxnot (fxarithmetic-shift-left -1 (fx- end start)))
+ (fxarithmetic-shift i (fxneg start))))
+
+(define (fxbit-field-rotate i count start end)
+ (if (not (fx<=? end fx-width))
+ (error:bad-range-argument end 'fxbit-field))
+ (if (not (fx<=? start end))
+ (error:bad-range-argument start 'fxbit-field))
+ (let* ((field-width (fx- end start))
+ (mask (fxnot (fxarithmetic-shift -1 field-width)))
+ (field (fxand mask (fxarithmetic-shift i (fxneg start)))))
+ (fxior (fxarithmetic-shift (fxrotate field-width field mask count) start)
+ (fxand (fxnot (fxarithmetic-shift mask start)) i))))
+
+(define (fxrotate field-width field mask count)
+ (let ((count (modulo count field-width)))
+ (fxior (fxand mask (fxarithmetic-shift field count))
+ (fxarithmetic-shift field (fx- count field-width)))))
+
+(define (fxbit-field-reverse i start end)
+ (if (not (fx<=? end fx-width))
+ (error:bad-range-argument end 'fxbit-field))
+ (if (not (fx<=? start end))
+ (error:bad-range-argument start 'fxbit-field))
+ (let* ((field-width (fx- end start))
+ (mask (fxnot (fxarithmetic-shift -1 field-width)))
+ (field (fxand mask (fxarithmetic-shift i (fxneg start)))))
+ (fxior (fxarithmetic-shift (fxreverse field-width field) start)
+ (fxand (fxnot (fxarithmetic-shift mask start)) i))))
+
+(define (fxreverse field-width field)
+ (let loop ((i (fx- field-width 1)) (n field) (m 0))
+ (if (fx<? i 0)
+ m
+ (loop (fx- i 1)
+ (fxarithmetic-shift-right n 1)
+ (fxior (fxarithmetic-shift-left m 1)
+ (fxand n 1))))))
\f
(define (guarantee-limited-index-fixnum object limit #!optional caller)
(guarantee index-fixnum? object caller)
(define fx-width)
(define fx-greatest)
(define fx-least)
+(define unsigned-limit)
(add-boot-init!
(lambda ()
(let loop ((n 1) (w 1))
(if (fixnum? n)
(loop (int:* n 2) (int:+ w 1))
- (let ((n (int:- n 1)))
- (if (not (fixnum? n))
- (error "Unable to compute largest fixnum:" n))
- (set! fx-greatest n)
- (set! fx-width w))))
+ (let ((m (int:- n 1)))
+ (if (not (fixnum? m))
+ (error "Unable to compute largest fixnum:" m))
+ (set! fx-greatest m)
+ (set! fx-width w)
+ (set! unsigned-limit (int:* n 2)))))
(let loop ((n -1))
(if (fixnum? n)
(loop (int:* n 2))
(let ((j (int:quotient (int:+ i (int:quotient n i)) 2)))
(if (int:>= j i)
(values i (int:- n (int:* i i)))
+ (loop j))))))
+
+(define (fxsqrt n)
+ (guarantee non-negative-fixnum? n 'fxsqrt)
+ (if (fxzero? n)
+ (values 0 0)
+ (let loop
+ ((i
+ (fxarithmetic-shift-left 1
+ (let ((n-bits (fxlength n)))
+ (if (fxeven? n-bits)
+ (fxquotient n-bits 2)
+ (fx+ (fxquotient n-bits 2) 1))))))
+ (let ((j (fxquotient (fx+ i (fxquotient n i)) 2)))
+ (if (fx>=? j i)
+ (values i (fx- n (fx* i i)))
(loop j))))))
\ No newline at end of file
(fix:> fx>?)
(fix:>= fx>=?)
(fix:and fxand)
- (fix:andc fxandc)
- (fix:andc fxandc)
(fix:fixnum? fixnum?)
(fix:lsh fxarithmetic-shift)
(fix:max fxmax)
(index-fixnum? non-negative-fixnum?)
->flonum
exact-integer-sqrt
+ fix:andc
fix:divide
fix:end-index
fix:gcd
fix:start-index
fixnum? ;SRFI-143
fx* ;SRFI-143
+ fx*/carry ;SRFI-143
fx+ ;SRFI-143
+ fx+/carry ;SRFI-143
fx- ;SRFI-143
+ fx-/carry ;SRFI-143
fx-greatest ;SRFI-143
fx-least ;SRFI-143
fx-width ;SRFI-143
+ fx<=? ;SRFI-143
+ fx<? ;SRFI-143
+ fx=? ;SRFI-143
+ fx>=? ;SRFI-143
+ fx>? ;SRFI-143
fxabs ;SRFI-143
fxand ;SRFI-143
fxandc
fxarithmetic-shift ;SRFI-143
fxarithmetic-shift-right ;SRFI-143
+ fxbit-count ;SRFI-143
+ fxbit-field ;SRFI-143
+ fxbit-field-reverse ;SRFI-143
+ fxbit-field-rotate ;SRFI-143
+ fxbit-set? ;SRFI-143
+ fxcopy-bit ;SRFI-143
fxdecr
+ fxeven? ;SRFI-143
+ fxfirst-set-bit ;SRFI-143
+ fxif ;SRFI-143
fxincr
fxior ;SRFI-143
+ fxlength ;SRFI-143
fxmax ;SRFI-143
fxmin ;SRFI-143
fxneg ;SRFI-143
fxnegative? ;SRFI-143
fxnot ;SRFI-143
+ fxodd? ;SRFI-143
fxpositive? ;SRFI-143
fxquotient ;SRFI-143
fxremainder ;SRFI-143
+ fxsqrt ;SRFI-143
fxsquare ;SRFI-143
fxxor ;SRFI-143
fxzero? ;SRFI-143
(fx* multiply-fixnum 2)
(fx+ plus-fixnum 2)
(fx- minus-fixnum 2)
- (fx<? less-than-fixnum? 2)
- (fx=? equal-fixnum? 2)
- (fx>? greater-than-fixnum? 2)
- (fxand fixnum-and 2)
(fxandc fixnum-andc 2)
(fxarithmetic-shift fixnum-lsh 2)
(fxarithmetic-shift-left fixnum-lsh 2)
+ (fxbit-count fxbit-count 1)
(fxdecr minus-one-plus-fixnum 1)
+ (fxfirst-set-bit fxfirst-set-bit 1)
(fxincr one-plus-fixnum 1)
- (fxior fixnum-or 2)
+ (fxlength fxlength 1)
(fxnegative? negative-fixnum? 1)
(fxnot fixnum-not 1)
(fxpositive? positive-fixnum? 1)
(fxquotient fixnum-quotient 2)
(fxremainder fixnum-remainder 2)
- (fxxor fixnum-xor 2)
(fxzero? zero-fixnum? 1)
(general-car-cdr general-car-cdr)
(get-fixed-objects-vector get-fixed-objects-vector)
\f
;;;; Fixed-arity arithmetic primitives
-(define (make-combination expression block primitive operands)
- (combination/make expression
+(define (pcall expr block operator . operands)
+ (papply expr block operator operands))
+
+(define (papply expr block operator operands)
+ (combination/make expr
block
- (constant/make #f primitive)
+ (if (primitive-procedure? operator)
+ (pconst #f operator)
+ operator)
operands))
+(define (pconst expr datum)
+ (constant/make (and expr (object/scode expr)) datum))
+
+(define (pif expr p c a)
+ (conditional/make (and expr (object/scode expr)) p c a))
+
(define (make-operand-binding expression block operand make-body)
(combination/make expression
block
(lambda (expr operands block)
(if (and (pair? operands)
(null? (cdr operands)))
- (make-combination expr block primitive operands)
+ (papply expr block primitive operands)
#f)))
(define (binary-arithmetic primitive)
(if (and (pair? operands)
(pair? (cdr operands))
(null? (cddr operands)))
- (make-combination expr block primitive operands)
+ (papply expr block primitive operands)
#f)))
(define zero?-expansion
(pair? (cdr operands))
(null? (cddr operands)))
(cond ((constant-eq? (car operands) 0)
- (make-combination expr block if-left-zero
- (list (cadr operands))))
+ (pcall expr block if-left-zero (cadr operands)))
((constant-eq? (cadr operands) 0)
- (make-combination expr block if-right-zero
- (list (car operands))))
+ (pcall expr block if-right-zero (car operands)))
(else
- (make-combination expr block binary-predicate operands)))
+ (papply expr block binary-predicate operands)))
#f)))
(define =-expansion
\f
;;;; Fixnum Operations
-(define (fix:=-expansion expr operands block)
- (if (and (pair? operands)
- (pair? (cdr operands))
- (null? (cddr operands)))
- (make-combination expr block (ucode-primitive eq?) operands)
+(define (fx-compare prim)
+ (lambda (expr ops block)
+ (case (length ops)
+ ((2)
+ (pcall expr block prim (car ops) (cadr ops)))
+ ((3)
+ (pif expr
+ (pcall #f block prim (car ops) (cadr ops))
+ (pcall #f block prim (car ops) (caddr ops))
+ (pconst #f #f)))
+ ((4)
+ (pif expr
+ (pcall #f block prim (car ops) (cadr ops))
+ (pif #f
+ (pcall #f block prim (cadr ops) (caddr ops))
+ (pcall #f block prim (caddr ops) (cadddr ops))
+ (pconst #f #f))
+ (pconst #f #f)))
+ (else #f))))
+
+(define fx=?-expansion (fx-compare (ucode-primitive eq?)))
+(define fx<?-expansion (fx-compare (ucode-primitive less-than-fixnum?)))
+(define fx>?-expansion (fx-compare (ucode-primitive greater-than-fixnum?)))
+
+(define (fxnot-compare prim)
+ (lambda (expr ops block)
+
+ (define (pnot expr operand)
+ (pcall expr block (ucode-primitive not) operand))
+
+ (case (length ops)
+ ((2)
+ (pnot expr (pcall #f block prim (car ops) (cadr ops))))
+ ((3)
+ (pif expr
+ (pcall #f block prim (car ops) (cadr ops))
+ (pconst #f #f)
+ (pnot #f (pcall #f block prim (car ops) (caddr ops)))))
+ ((4)
+ (pif expr
+ (pcall #f block prim (car ops) (cadr ops))
+ (pconst #f #f)
+ (pif #f
+ (pcall #f block prim (cadr ops) (caddr ops))
+ (pconst #f #f)
+ (pnot #f (pcall #f block prim (caddr ops) (cadddr ops))))))
+ (else #f))))
+
+(define fx<=?-expansion (fxnot-compare (ucode-primitive greater-than-fixnum?)))
+(define fx>=?-expansion (fxnot-compare (ucode-primitive less-than-fixnum?)))
+
+(define (fxneg-expansion expr ops block)
+ (if (and (pair? ops)
+ (null? (cdr ops)))
+ (pcall expr block (ucode-primitive minus-fixnum) (pconst #f 0) (car ops))
#f))
-(define char=?-expansion
- fix:=-expansion)
-
-(define (fix:<=-expansion expr operands block)
- (if (and (pair? operands)
- (pair? (cdr operands))
- (null? (cddr operands)))
- (make-combination
- expr
- block
- (ucode-primitive not)
- (list (make-combination #f
- block
- (ucode-primitive greater-than-fixnum?)
- operands)))
- #f))
-
-(define (fix:>=-expansion expr operands block)
- (if (and (pair? operands)
- (pair? (cdr operands))
- (null? (cddr operands)))
- (make-combination
- expr
- block
- (ucode-primitive not)
- (list (make-combination #f
- block
- (ucode-primitive less-than-fixnum?)
- operands)))
- #f))
-
-(define (fxneg-expansion expr operands block)
- (if (and (pair? operands)
- (null? (cdr operands)))
- (make-combination expr
- block
- (ucode-primitive minus-fixnum)
- (constant/make #f 0)
- (car operands))
- #f))
-
-(define (fxarithmetic-shift-right-expansion expr operands block)
- (if (and (pair? operands)
- (pair? (cdr operands))
- (null? (cddr operands)))
- (make-combination expr
- block
- (ucode-primitive fixnum-lsh)
- (car operands)
- (make-combination #f
- block
- (ucode-primitive minus-fixnum)
- (constant/make #f 0)
- (cadr operands)))
+(define (fxarithmetic-shift-right-expansion expr ops block)
+ (if (and (pair? ops)
+ (pair? (cdr ops))
+ (null? (cddr ops)))
+ (pcall expr block (ucode-primitive fixnum-lsh)
+ (car ops)
+ (pcall #f block (ucode-primitive minus-fixnum)
+ (pconst #f 0)
+ (cadr ops)))
#f))
\f
;;;; N-ary Arithmetic Field Operations
(right-accumulation 0
(lambda (expr block x y)
(cond ((constant-eq? x 1)
- (make-combination expr block (ucode-primitive 1+) (list y)))
+ (pcall expr block (ucode-primitive 1+) y))
((constant-eq? y 1)
- (make-combination expr block (ucode-primitive 1+) (list x)))
+ (pcall expr block (ucode-primitive 1+) x))
(else
- (make-combination expr block (ucode-primitive &+) (list x y)))))))
+ (pcall expr block (ucode-primitive &+) x y))))))
(define *-expansion
(right-accumulation 1
(lambda (expr block x y)
- (make-combination expr block (ucode-primitive &*) (list x y)))))
+ (pcall expr block (ucode-primitive &*) x y))))
\f
(define (expt-expansion expr operands block)
(let ((make-binder
((constant-eq? (cadr operands) 2)
(make-binder
(lambda (block operand)
- (make-combination #f
- block
- (ucode-primitive &*)
- (list operand operand)))))
+ (pcall #f block (ucode-primitive &*) operand operand))))
((constant-eq? (cadr operands) 3)
(make-binder
(lambda (block operand)
- (make-combination
- #f
- block
- (ucode-primitive &*)
- (list operand
- (make-combination #f
- block
- (ucode-primitive &*)
- (list operand operand)))))))
+ (pcall #f
+ block
+ (ucode-primitive &*)
+ operand
+ (pcall #f block (ucode-primitive &*) operand operand)))))
((constant-eq? (cadr operands) 4)
(make-binder
(lambda (block operand)
- (make-combination
- #f
- block
- (ucode-primitive &*)
- (list (make-combination #f
- block
- (ucode-primitive &*)
- (list operand operand))
- (make-combination #f
- block
- (ucode-primitive &*)
- (list operand operand)))))))
+ (pcall #f
+ block
+ (ucode-primitive &*)
+ (pcall #f block (ucode-primitive &*) operand operand)
+ (pcall #f block (ucode-primitive &*) operand operand)))))
(else #f))))
\f
(define (right-accumulation-inverse identity inverse-expansion make-binary)
(right-accumulation-inverse 0 +-expansion
(lambda (expr block x y)
(if (constant-eq? y 1)
- (make-combination expr block (ucode-primitive -1+) (list x))
- (make-combination expr block (ucode-primitive &-) (list x y))))))
+ (pcall expr block (ucode-primitive -1+) x)
+ (pcall expr block (ucode-primitive &-) x y)))))
(define /-expansion
(right-accumulation-inverse 1 *-expansion
(lambda (expr block x y)
- (make-combination expr block (ucode-primitive &/) (list x y)))))
+ (pcall expr block (ucode-primitive &/) x y))))
\f
;;;; N-ary List Operations
(define (apply*-expansion expr operands block)
(cond ((length=? operands 2)
- (make-combination expr block (ucode-primitive apply) operands))
+ (papply expr block (ucode-primitive apply) operands))
((not (pair? operands)) #f)
((pair? (cdr operands))
(apply*-expansion
(define (cons*-expansion-loop expr block rest)
(if (null? (cdr rest))
(car rest)
- (make-combination expr
- block
- (ucode-primitive cons)
- (list (car rest)
- (cons*-expansion-loop #f block (cdr rest))))))
+ (pcall expr
+ block
+ (ucode-primitive cons)
+ (car rest)
+ (cons*-expansion-loop #f block (cdr rest)))))
(define (list-expansion expr operands block)
(list-expansion-loop expr block operands))
(define (list-expansion-loop expr block rest)
- (cond ((pair? rest) (make-combination expr block (ucode-primitive cons)
- (list (car rest)
- (list-expansion-loop #f block (cdr rest)))))
- ((null? rest) (constant/make (and expr (object/scode expr)) '()))
- (else (error "Improper list."))))
+ (cond ((pair? rest)
+ (pcall expr block (ucode-primitive cons)
+ (car rest)
+ (list-expansion-loop #f block (cdr rest))))
+ ((null? rest)
+ (constant/make (and expr (object/scode expr)) '()))
+ (else
+ (error "Improper list."))))
\f
;;;; General CAR/CDR Encodings
(let ((operand (first operands)))
(cond ((call-to-car? operand)
;; (car (car x)) => (caar x)
- (make-combination
- expr block
- (ucode-primitive general-car-cdr)
- (list (first (combination/operands operand))
- (constant/make #f #b111))))
+ (pcall expr block
+ (ucode-primitive general-car-cdr)
+ (first (combination/operands operand))
+ (constant/make #f #b111)))
;; (car (cdr x)) => (cadr x)
((call-to-cdr? operand)
- (make-combination
- expr block
- (ucode-primitive general-car-cdr)
- (list (first (combination/operands operand))
- (constant/make #f #b110))))
+ (pcall expr block
+ (ucode-primitive general-car-cdr)
+ (first (combination/operands operand))
+ (constant/make #f #b110)))
((call-to-general-car-cdr? operand)
- (make-combination
- expr block
- (ucode-primitive general-car-cdr)
- (list (first (combination/operands operand))
+ (pcall expr block
+ (ucode-primitive general-car-cdr)
+ (first (combination/operands operand))
(constant/make
#f
(encode-general-car-cdr
(cons 'car
(decode-general-car-cdr
(constant/value
- (second (combination/operands operand))))))))))
+ (second (combination/operands operand)))))))))
(else
- (make-combination expr block (ucode-primitive car) operands))))
+ (papply expr block (ucode-primitive car) operands))))
;; ill-formed call
(begin
(warn "Wrong number of arguments in call to CAR.")
(let ((operand (first operands)))
(cond ((call-to-car? operand)
;; (cdr (car x)) => (cdar x)
- (make-combination
- expr block
- (ucode-primitive general-car-cdr)
- (list (first (combination/operands operand))
- (constant/make #f #b101))))
+ (pcall expr block
+ (ucode-primitive general-car-cdr)
+ (first (combination/operands operand))
+ (constant/make #f #b101)))
;; (cdr (car x)) => (cddr x)
((call-to-cdr? operand)
- (make-combination
- expr block
- (ucode-primitive general-car-cdr)
- (list (first (combination/operands operand))
- (constant/make #f #b100))))
+ (pcall expr block
+ (ucode-primitive general-car-cdr)
+ (first (combination/operands operand))
+ (constant/make #f #b100)))
((call-to-general-car-cdr? (car operands))
- (make-combination
- expr block
- (ucode-primitive general-car-cdr)
- (list (first (combination/operands operand))
+ (pcall expr block
+ (ucode-primitive general-car-cdr)
+ (first (combination/operands operand))
(constant/make
#f
(encode-general-car-cdr
(cons 'cdr
(decode-general-car-cdr
(constant/value
- (second (combination/operands operand))))))))))
+ (second (combination/operands operand)))))))))
(else
- (make-combination expr block (ucode-primitive cdr) operands))))
+ (papply expr block (ucode-primitive cdr) operands))))
;; ill-formed call
(begin
(warn "Wrong number of arguments in call to CDR.")
(define (general-car-cdr-expansion encoding)
(lambda (expr operands block)
(if (length=? operands 1)
- (make-combination expr
- block
- (ucode-primitive general-car-cdr)
- (list (car operands)
- (constant/make #f encoding)))
+ (pcall expr
+ block
+ (ucode-primitive general-car-cdr)
+ (car operands)
+ (constant/make #f encoding))
#f)))
(define caar-expansion (general-car-cdr-expansion #b111))
(sequence/make
(and expr (object/scode expr))
(list (first operands)
- (make-combination #f block
- (ucode-primitive not) (cdr operands)))))
+ (pcall #f block (ucode-primitive not) (cadr operands)))))
((expression/always-false? (second operands))
(sequence/make
(and expr (object/scode expr))
(list (second operands)
- (make-combination #f block
- (ucode-primitive not)
- (list (car operands))))))
+ (pcall #f block (ucode-primitive not) (car operands)))))
(else
- (make-combination expr block (ucode-primitive eq?) operands)))
+ (papply expr block (ucode-primitive eq?) operands)))
+ #f))
+
+(define (char=?-expansion expr operands block)
+ (if (and (pair? operands)
+ (pair? (cdr operands))
+ (null? (cddr operands)))
+ (papply expr block (ucode-primitive eq?) operands)
#f))
(define (make-string-expansion expr operands block)
(if (and (pair? operands)
(null? (cdr operands)))
- (make-combination expr block (ucode-primitive string-allocate)
- operands)
+ (papply expr block (ucode-primitive string-allocate) operands)
#f))
(define (make-bytevector-expansion expr operands block)
(if (and (pair? operands)
(null? (cdr operands)))
- (make-combination expr block (ucode-primitive allocate-bytevector 1)
- operands)
+ (papply expr block (ucode-primitive allocate-bytevector 1) operands)
#f))
(define (not-expansion expr operands block)
((expression/never-false? (first operands))
(sequence/make (and expr (object/scode expr))
(list (first operands) (constant/make #f #f))))
- (else (make-combination expr block (ucode-primitive not) operands)))
+ (else (papply expr block (ucode-primitive not) operands)))
#f))
\f
(define (guarantee-expansion expr operands block)
(define (default-object?-expansion expr operands block)
(if (and (pair? operands)
(null? (cdr operands)))
- (make-combination expr block (ucode-primitive eq?)
- (list (car operands)
- (constant/make #f #!default)))
+ (pcall expr block (ucode-primitive eq?)
+ (car operands)
+ (constant/make #f #!default))
#f))
(define (make-disjunction expr . clauses)
(car clauses) (loop (cdr clauses))))))
(define (make-type-test expr block type operand)
- (make-combination expr block
- (ucode-primitive object-type?)
- (list (constant/make #f type) operand)))
+ (pcall expr block
+ (ucode-primitive object-type?)
+ (constant/make #f type)
+ operand))
(define (string->symbol-expansion expr operands block)
(declare (ignore block))
(define (int:->flonum-expansion expr operands block)
(if (and (pair? operands)
(null? (cdr operands)))
- (make-combination expr
- block
- (ucode-primitive integer->flonum 2)
- (list (car operands) (constant/make #f #b10)))
+ (pcall expr
+ block
+ (ucode-primitive integer->flonum 2)
+ (car operands)
+ (constant/make #f #b10))
#f))
(define (make-primitive-expander primitive)
(lambda (expr operands block)
(if (procedure-arity-valid? primitive (length operands))
- (make-combination expr block primitive operands)
+ (papply expr block primitive operands)
#f)))
\f
;;;; Tables
fix:=
fix:>=
fourth
+ fx<?
fx<=?
fx=?
+ fx>?
fx>=?
fxarithmetic-shift-right
fxneg
eq?-expansion
fifth-expansion
first-expansion
- fix:<=-expansion
- fix:=-expansion
- fix:>=-expansion
+ fx<=?-expansion
+ fx=?-expansion
+ fx>=?-expansion
fourth-expansion
- fix:<=-expansion
- fix:=-expansion
- fix:>=-expansion
+ fx<?-expansion
+ fx<=?-expansion
+ fx=?-expansion
+ fx>?-expansion
+ fx>=?-expansion
fxarithmetic-shift-right-expansion
fxneg-expansion
guarantee-expansion
"ffi/test-ffi"
"sos/test-genmult"
("libraries/test-srfi-133" inline)
+ ("libraries/test-srfi-143" inline)
))
(with-working-directory-pathname
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
(import (scheme base)
(srfi 133))
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+(import (scheme base)
+ (srfi 143))
+
+(fixnum? 32767) 'expect-true
+(fixnum? 1.1) 'expect-false
+
+(fx=? 1 1 1) 'expect-true
+(fx=? 1 2 2) 'expect-false
+(fx=? 1 1 2) 'expect-false
+(fx=? 1 2 3) 'expect-false
+
+(fx<? 1 2 3) 'expect-true
+(fx<? 1 1 2) 'expect-false
+(fx>? 3 2 1) 'expect-true
+(fx>? 2 1 1) 'expect-false
+(fx<=? 1 1 2) 'expect-true
+(fx<=? 1 2 1) 'expect-false
+(fx>=? 2 1 1) 'expect-true
+(fx>=? 1 2 1) 'expect-false
+(list (fx<=? 1 1 2) (fx<=? 2 1 3)) '(expect equal? '(#t #f))
+
+(fxzero? 0) 'expect-true
+(fxzero? 1) 'expect-false
+
+(fxpositive? 0) 'expect-false
+(fxpositive? 1) 'expect-true
+(fxpositive? -1) 'expect-false
+
+(fxnegative? 0) 'expect-false
+(fxnegative? 1) 'expect-false
+(fxnegative? -1) 'expect-true
+
+(fxodd? 0) 'expect-false
+(fxodd? 1) 'expect-true
+(fxodd? -1) 'expect-true
+(fxodd? 102) 'expect-false
+
+(fxeven? 0) 'expect-true
+(fxeven? 1) 'expect-false
+(fxeven? -2) 'expect-true
+(fxeven? 102) 'expect-true
+
+(fxmax 3 4) '(expect = 4)
+(fxmax 3 5 4) '(expect = 5)
+(fxmin 3 4) '(expect = 3)
+(fxmin 3 5 4) '(expect = 3)
+
+(fx+ 3 4) '(expect = 7)
+(fx* 4 3) '(expect = 12)
+
+(fx- 3 4) '(expect = -1)
+(fxneg 3) '(expect = -3)
+
+(fxabs -7) '(expect = 7)
+(fxabs 7) '(expect = 7)
+
+(fxsquare 42) '(expect = 1764)
+(fxsquare 2) '(expect = 4)
+
+(fxquotient 5 2) '(expect = 2)
+(fxquotient -5 2) '(expect = -2)
+(fxquotient 5 -2) '(expect = -2)
+(fxquotient -5 -2) '(expect = 2)
+
+(fxremainder 13 4) '(expect = 1)
+(fxremainder -13 4) '(expect = -1)
+(fxremainder 13 -4) '(expect = 1)
+(fxremainder -13 -4) '(expect = -1)
+
+(let*-values (((root rem) (fxsqrt 32)))
+ (* root rem))
+'(expect = 35)
+
+(fxnot 0) '(expect = -1)
+(fxand #b0 #b1) '(expect = 0)
+(fxand 14 6) '(expect = 6)
+(fxior 10 12) '(expect = 14)
+(fxxor 10 12) '(expect = 6)
+(fxnot -1) '(expect = 0)
+(fxif 3 1 8) '(expect = 9)
+(fxif 3 8 1) '(expect = 0)
+(fxbit-count 12) '(expect = 2)
+(fxlength 0) '(expect = 0)
+(fxlength 128) '(expect = 8)
+(fxlength 255) '(expect = 8)
+(fxlength 256) '(expect = 9)
+(fxfirst-set-bit 0) '(expect = -1)
+(fxfirst-set-bit 1) '(expect = 0)
+(fxfirst-set-bit 3) '(expect = 0)
+(fxfirst-set-bit 4) '(expect = 2)
+(fxfirst-set-bit 6) '(expect = 1)
+(fxfirst-set-bit -1) '(expect = 0)
+(fxfirst-set-bit -2) '(expect = 1)
+(fxfirst-set-bit -3) '(expect = 0)
+(fxfirst-set-bit -4) '(expect = 2)
+(fxbit-set? 0 1) 'expect-true
+(fxbit-set? 1 1) 'expect-false
+(fxbit-set? 1 8) 'expect-false
+(fxbit-set? fx-width 0) 'expect-error
+(fxbit-set? (- fx-width 1) 0) 'expect-false
+(fxbit-set? (- fx-width 2) 0) 'expect-false
+(fxbit-set? fx-width -1) 'expect-error
+(fxbit-set? (- fx-width 1) -1) 'expect-true
+(fxbit-set? (- fx-width 2) -1) 'expect-true
+(fxbit-set? 10000 -1) 'expect-error
+(fxbit-set? 1000 -1) 'expect-error
+(fxcopy-bit 0 0 #f) '(expect = 0)
+(fxcopy-bit 0 -1 #t) '(expect = -1)
+(fxcopy-bit 0 0 #t) '(expect = 1)
+(fxcopy-bit 8 6 #t) '(expect = #x106)
+(fxcopy-bit 8 6 #f) '(expect = 6)
+(fxcopy-bit 0 -1 #f) '(expect = -2)
+(fxbit-field 6 0 1) '(expect = 0)
+(fxbit-field 6 1 3) '(expect = 3)
+(fxarithmetic-shift 1 1) '(expect = 2)
+(fxarithmetic-shift 1 -1) '(expect = 0)
+(fxbit-field-rotate #b110 1 1 2) '(expect = #b110)
+(fxbit-field-rotate #b110 1 2 4) '(expect = #b1010)
+(fxbit-field-rotate #b0111 -1 1 4) '(expect = #b1011)
+(fxbit-field-rotate #b110 0 0 10) '(expect = #b110)
+(fxbit-field-reverse 6 1 3) '(expect = 6)
+(fxbit-field-reverse 6 1 4) '(expect = 12)
+(fxnot 10) '(expect = -11)
+(fxnot -37) '(expect = 36)
+(fxior 3 10) '(expect = 11)
+(fxand 11 26) '(expect = 10)
+(fxxor 3 10) '(expect = 9)
+(fxand 37 12) '(expect = 4)
+(fxarithmetic-shift 8 2) '(expect = 32)
+(fxarithmetic-shift 4 0) '(expect = 4)
+(fxarithmetic-shift 8 -1) '(expect = 4)
+(fxlength 0) '(expect = 0)
+(fxlength 1) '(expect = 1)
+(fxlength -1) '(expect = 0)
+(fxlength 7) '(expect = 3)
+(fxlength -7) '(expect = 3)
+(fxlength 8) '(expect = 4)
+(fxlength -8) '(expect = 3)
+(fxbit-set? 3 10) 'expect-true
+(fxbit-set? 2 6) 'expect-true
+(fxbit-set? 0 6) 'expect-false
+(fxcopy-bit 2 0 #t) '(expect = #b100)
+(fxcopy-bit 2 #b1111 #f) #b1011
+(fxfirst-set-bit 2) '(expect = 1)
+(fxfirst-set-bit 40) '(expect = 3)
+(fxfirst-set-bit -28) '(expect = 2)
+(fxand #b1 #b1) '(expect = 1)
+(fxand #b1 #b10) '(expect = 0)
+(fxand #b11 #b10) '(expect = #b10)
+(fxand #b101 #b111) '(expect = #b101)
+(fxand -1 #b111) '(expect = #b111)
+(fxand -2 #b111) '(expect = #b110)
+(fxarithmetic-shift 1 0) '(expect = 1)
+(fxarithmetic-shift 1 2) '(expect = 4)
+(fxarithmetic-shift 1 3) '(expect = 8)
+(fxarithmetic-shift 1 4) '(expect = 16)
+(fxarithmetic-shift -1 0) '(expect = -1)
+(fxarithmetic-shift -1 1) '(expect = -2)
+(fxarithmetic-shift -1 2) '(expect = -4)
+(fxarithmetic-shift -1 3) '(expect = -8)
+(fxarithmetic-shift -1 4) '(expect = -16)
+(fxbit-field #b1101101010 0 4) '(expect = #b1010)
+(fxbit-field #b1101101010 3 9) '(expect = #b101101)
+(fxbit-field #b1101101010 4 9) '(expect = #b10110)
+(fxbit-field #b1101101010 4 10) '(expect = #b110110)
+(fxif 1 1 2) '(expect = 3)
+(fxif #b00111100 #b11110000 #b00001111) '(expect = #b00110011)
+(fxcopy-bit 0 0 #t) '(expect = #b1)
projects / mit-scheme.git / commitdiff