Added EQUAL? and CEILING, FLOOR, ROUND, TRUNCATE to known global

operators.

Changed expansions for FIX:=, FIX:ZERO? to NOT use EQ? as this hides
type info (i.e. that argument is a fixnum) from the compiler.

Moved CELL?, FLO:FLONUM? to gconst.scm to use `native' expansion.
There is no speed benefit to interpreted code and no benefit to
compiler, so it is clearer to leave it in.  It is a pity that there is
no primitive VECTOR?

diff --git a/v8/src/sf/gconst.scm b/v8/src/sf/gconst.scm
index d3f1383428402342a4624f0894107cad711607b4..c5f020621936208c8ff601d93c8c522e8d897605 100644 (file)
--- a/v8/src/sf/gconst.scm
+++ b/v8/src/sf/gconst.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: gconst.scm,v 1.1 1995/03/07 22:13:52 adams Exp $
+$Id: gconst.scm,v 1.2 1995/11/04 11:52:28 adams Exp $
 
 Copyright (c) 1987-93 Massachusetts Institute of Technology
 
@@ -69,6 +69,7 @@ MIT in each case. |#
     BIT-SUBSTRING-MOVE-RIGHT!
     CAR
     CDR
+    CELL?
     CELL-CONTENTS
     CHAR->ASCII
     CHAR->INTEGER
@@ -95,7 +96,7 @@ MIT in each case. |#
     FIX:-1+
     FIX:1+
     FIX:<
-    ;; FIX:= handled by expanding it to EQ?
+    FIX:=              ;; no longer handled by expanding it to EQ?
     FIX:>
     FIX:AND
     FIX:ANDC
@@ -111,7 +112,7 @@ MIT in each case. |#
     FIX:REMAINDER
     FIX:XOR
     FIXNUM?
-    ;; FIX:ZERO? handled by expanding it to (EQ? x 0)
+    FIX:ZERO?          ;; no longer handled by expanding it to (EQ? x 0)
     FLO:*
     FLO:+
     FLO:-
@@ -129,6 +130,7 @@ MIT in each case. |#
     FLO:COS
     FLO:EXP
     FLO:EXPT
+    FLO:FLONUM
     FLO:FLOOR
     FLO:FLOOR->EXACT
     FLO:LOG

diff --git a/v8/src/sf/usiexp.scm b/v8/src/sf/usiexp.scm
index 1389fe60cabd13890ea6b0b8086a62296895e951..c4e3c4b25c06d142155f6d463067939ce4877c4a 100644 (file)
--- a/v8/src/sf/usiexp.scm
+++ b/v8/src/sf/usiexp.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: usiexp.scm,v 1.11 1995/10/25 18:42:05 adams Exp $
+$Id: usiexp.scm,v 1.12 1995/11/04 11:52:19 adams Exp $
 
 Copyright (c) 1988-1995 Massachusetts Institute of Technology
 
@@ -157,24 +157,6 @@ MIT in each case. |#
 \f
   ;;;; Fixnum Operations
 
-  (define (fix:zero?-expansion expr operands if-expanded if-not-expanded block)
-    (if (and (pair? operands) (null? (cdr operands)))
-       (if-expanded
-        (make-combination expr block (ucode-primitive eq?)
-                          (list (car operands) (constant/make false 0))))
-       (if-not-expanded)))
-
-  (define (fix:=-expansion expr operands if-expanded if-not-expanded block)
-    (if (and (pair? operands)
-            (pair? (cdr operands))
-            (null? (cddr operands)))
-       (if-expanded
-        (make-combination expr block (ucode-primitive eq?) operands))
-       (if-not-expanded)))
-
-  (define char=?-expansion
-    fix:=-expansion)
-
   (define (fix:<=-expansion expr operands if-expanded if-not-expanded block)
     (if (and (pair? operands)
             (pair? (cdr operands))
@@ -204,6 +186,9 @@ MIT in each case. |#
                                  (ucode-primitive less-than-fixnum?)
                                  operands))))
        (if-not-expanded)))
+
+  (define char=?-expansion
+    (binary-arithmetic (ucode-primitive eq?)))
 \f
   ;;;; N-ary Arithmetic Field Operations
 
@@ -247,60 +232,6 @@ MIT in each case. |#
      1
      (lambda (expr block x y)
        (make-combination expr block (ucode-primitive &*) (list x y)))))
-\f
-  #|
-  (define (expt-expansion expr operands if-expanded if-not-expanded block)
-    (let ((make-binder
-          (lambda (make-body)
-            (make-operand-binding expr
-                                  block
-                                  (car operands)
-                                  make-body))))
-      (cond ((not (and (pair? operands)
-                      (pair? (cdr operands))
-                      (null? (cddr operands))))
-            (if-not-expanded))
-           ;;((constant-eq? (cadr operands) 0)
-           ;; (if-expanded (constant/make (and expr (object/scode expr)) 1)))
-           ((constant-eq? (cadr operands) 1)
-            (if-expanded (car operands)))
-           ((constant-eq? (cadr operands) 2)
-            (make-binder
-             (lambda (block operand)
-               (make-combination #f
-                                 block
-                                 (ucode-primitive &*)
-                                 (list 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)))))))
-           ((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)))))))
-           (else
-            (if-not-expanded)))))
-  |#
 \f
   (define (right-accumulation-inverse identity inverse-expansion make-binary)
     (lambda (expr operands if-expanded if-not-expanded block)
@@ -505,8 +436,6 @@ MIT in each case. |#
 
   (define char?-expansion
     (type-test-expansion (cross-sf/ucode-type 'character)))
-  (define cell?-expansion
-    (type-test-expansion (cross-sf/ucode-type 'cell)))
   (define vector?-expansion
     (type-test-expansion (cross-sf/ucode-type 'vector)))
   (define %record?-expansion
@@ -514,7 +443,7 @@ MIT in each case. |#
   (define weak-pair?-expansion
     (type-test-expansion (cross-sf/ucode-type 'weak-cons)))
   (define flo:flonum?-expansion
-    (type-test-expansion (cross-sf/ucode-type 'big-flonum)))
+    (unary-arithmetic (ucode-primitive flonum?)))
 
   (define fixnum-ucode-types
     (let ((-ve  (cross-sf/ucode-type 'negative-fixnum))
@@ -523,9 +452,6 @@ MIT in each case. |#
          (list +0ve)
          (list +0ve -ve))))
 
-  (define fix:fixnum?-expansion 
-    (disjunction-type-test-expansion fixnum-ucode-types))
-
   (define exact-integer?-expansion
     (disjunction-type-test-expansion
      (append fixnum-ucode-types (list (cross-sf/ucode-type 'big-fixnum)))))
@@ -651,7 +577,6 @@ MIT in each case. |#
       (cddddr             . ,cddddr-expansion)
       (cdddr              . ,cdddr-expansion)
       (cddr               . ,cddr-expansion)
-      (cell?              . ,cell?-expansion)
       (char=?             . ,char=?-expansion)
       (char?              . ,char?-expansion)
       (complex?           . ,complex?-expansion)
@@ -662,11 +587,7 @@ MIT in each case. |#
       (fifth              . ,fifth-expansion)
       (first              . ,first-expansion)
       (fix:<=             . ,fix:<=-expansion)
-      (fix:=              . ,fix:=-expansion)
       (fix:>=             . ,fix:>=-expansion)
-      ;;(fix:fixnum?        . ,fix:fixnum?-expansion)
-      (fix:zero?          . ,fix:zero?-expansion)
-      (flo:flonum?        . ,flo:flonum?-expansion)
       (fourth             . ,fourth-expansion)
       (int:->flonum       . ,int:->flonum-expansion)
       (int:integer?       . ,exact-integer?-expansion)
@@ -709,8 +630,10 @@ MIT in each case. |#
     ACOS
     ASIN
     ATAN
+    CEILING
     CEILING->EXACT
     COS
+    EQUAL?
     EQV?
     ERROR
     ERROR:BAD-RANGE-ARGUMENT
@@ -718,17 +641,21 @@ MIT in each case. |#
     ERROR:WRONG-TYPE-DATUM
     EXP
     EXPT
+    FLOOR
     FLOOR->EXACT
     FOR-EACH
     LIST-REF
     LOG
+    MAP
     MEMQ
+    ROUND
     ROUND->EXACT
     SIN
     SQRT
     STRING->SYMBOL
     (SYMBOL-NAME 1)
     TAN
+    TRUNCATE
     TRUNCATE->EXACT
     ))
 \f