New declarations (TYPE-CHECKS), (RANGE-CHECKS), (NO-TYPE-CHECKS),

(NO-RANGE-CHECKS) for local scopes.  I wrote a much longer
description, but it was eaten by CVS, which left no trace of it, and
I am now disinclined to rewrite it.

diff --git a/v7/src/compiler/base/blocks.scm b/v7/src/compiler/base/blocks.scm
index 20994bf692ad143da626acfda71d6d2c799bc721..4f642871fc4f29cf23958b7576ab78a758a1db06 100644 (file)
--- a/v7/src/compiler/base/blocks.scm
+++ b/v7/src/compiler/base/blocks.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: blocks.scm,v 4.19 2007/01/05 21:19:20 cph Exp $
+$Id: blocks.scm,v 4.20 2007/04/14 22:00:09 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -91,6 +91,8 @@ from the continuation, and then "glued" into place afterwards.
                        ;analysis not to alter this block's layout
                        ;(i.e., don't make any of the block's
                        ;procedure's parameters be passed by register)
+  type-checks          ;true, false, or a list (<default> <check>
+  range-checks         ;  <no-check>)
   )
 
 (define *blocks*)
@@ -99,12 +101,18 @@ from the continuation, and then "glued" into place afterwards.
   (let ((block
         (make-rvalue block-tag (enumeration/name->index block-types type)
                      parent '() '() #f #f '()'() '() '() '() '() '()
-                     #f #f 'UNKNOWN 'UNKNOWN 'UNKNOWN #f)))
+                     #f #f 'UNKNOWN 'UNKNOWN 'UNKNOWN #f
+                     (if parent
+                         (block-type-checks parent)
+                         compiler:generate-type-checks?)
+                     (if parent
+                         (block-range-checks parent)
+                         compiler:generate-range-checks?))))
     (if parent
        (set-block-children! parent (cons block (block-children parent))))
     (set! *blocks* (cons block *blocks*))
     block))
-
+\f
 (define-vector-tag-unparser block-tag
   (lambda (state block)
     ((standard-unparser
@@ -139,6 +147,27 @@ from the continuation, and then "glued" into place afterwards.
 
 (define block-passed-out?
   rvalue-%passed-out?)
+
+(define (block/generate-type-checks? block primitive)
+  (block/generate-checks? block primitive block-type-checks))
+
+(define (block/generate-range-checks? block primitive)
+  (block/generate-checks? block primitive block-range-checks))
+
+(define (block/generate-checks? block primitive block-checks)
+  (let ((checks (block-checks block)))
+    (if (boolean? checks)
+       checks
+       (let ((primitive
+              (if (primitive-procedure? primitive)
+                  (primitive-procedure-name primitive)
+                  primitive))
+             (default (car checks))
+             (do-check (cadr checks))
+             (dont-check (caddr checks)))
+         (cond ((memq primitive do-check) #t)
+               ((memq primitive dont-check) #f)
+               (else default))))))
 \f
 ;;;; Block Type
 

diff --git a/v7/src/compiler/fggen/declar.scm b/v7/src/compiler/fggen/declar.scm
index ade8b5ddfdbc63cafed91e030c9f9cb8b7625ef0..9130f94d5d670871a1c667bfe35c1ea8b305433d 100644 (file)
--- a/v7/src/compiler/fggen/declar.scm
+++ b/v7/src/compiler/fggen/declar.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: declar.scm,v 1.10 2007/01/05 21:19:20 cph Exp $
+$Id: declar.scm,v 1.11 2007/04/14 22:00:09 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -29,7 +29,14 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define (process-top-level-declarations! block declarations)
+;;; A block's declarations are processed in two phases: before and
+;;; after the flow graph is generated for the block's children.  See
+;;; GENERATE/BODY in fggen/fggen.scm.  Some declarations need to refer
+;;; to information about variables bound by the block, so they use
+;;; post-declarations; others need to establish information that the
+;;; children can inherit from, so they use pre-declarations.
+
+(define (process-top-level-declarations! block declarations handlers)
   (process-declarations!
    block
    (let loop
@@ -40,30 +47,63 @@ USA.
         (loop (if (assq (caar defaults) declarations)
                   declarations
                   (cons (car defaults) declarations))
-              (cdr defaults))))))
+              (cdr defaults))))
+   handlers))
 
-(define (process-declarations! block declarations)
+(define (process-declarations! block declarations handlers)
   (for-each (lambda (declaration)
-             (process-declaration! block declaration))
+             (process-declaration! block declaration handlers))
            declarations))
 
-(define (process-declaration! block declaration)
-  (let ((entry (assq (car declaration) known-declarations)))
+(define (process-declaration! block declaration handlers)
+  (let ((entry (assq (car declaration) handlers)))
     (if entry
        ((cdr entry) block (car declaration) (cdr declaration))
        (warn "Unknown declaration name" (car declaration)))))
 
-(define known-declarations
-  '())
-
-(define (define-declaration keyword handler)
-  (let ((entry (assq keyword known-declarations)))
-    (if entry
-       (set-cdr! entry handler)
-       (set! known-declarations
-             (cons (cons keyword handler)
-                   known-declarations))))
-  keyword)
+(define (declaration-processor get-handlers)
+  (lambda (block declarations)
+    (process-top-level-declarations! block declarations (get-handlers))))
+
+(define (declaration-definer get-handlers set-handlers!)
+  (lambda (keyword handler)
+    (let ((handlers (get-handlers)))
+      (cond ((assq keyword handlers)
+            => (lambda (entry)
+                 (set-cdr! entry handler)))
+           (else
+            (set-handlers! (cons (cons keyword handler) handlers)))))
+    keyword))
+
+(define pre-declarations '())
+(define post-declarations '())
+
+(define process-pre-declarations!
+  (declaration-processor (lambda () pre-declarations)))
+
+(define process-post-declarations!
+  (declaration-processor (lambda () post-declarations)))
+
+(define define-pre-declaration
+  (declaration-definer (lambda () pre-declarations)
+                      (lambda (handlers) (set! pre-declarations handlers))))
+
+(define define-post-declaration
+  (declaration-definer (lambda () post-declarations)
+                      (lambda (handlers) (set! post-declarations handlers))))
+
+(define (define-pre-only-declaration keyword handler)
+  (define-pre-declaration keyword handler)
+  (define-post-declaration keyword ignored-declaration))
+
+(define (define-post-only-declaration keyword handler)
+  (define-pre-declaration keyword ignored-declaration)
+  (define-post-declaration keyword handler))
+
+(define ignored-declaration
+  (lambda (block keyword parameters)
+    block keyword parameters           ;ignore
+    unspecific))
 \f
 (package (boolean-variable-property)
 
@@ -129,10 +169,48 @@ USA.
 
 )
 
-(define-declaration 'UUO-LINK boolean-variable-property)
-(define-declaration 'CONSTANT boolean-variable-property)
-(define-declaration 'IGNORE-REFERENCE-TRAPS boolean-variable-property)
-(define-declaration 'IGNORE-ASSIGNMENT-TRAPS boolean-variable-property)
-(define-declaration 'USUAL-DEFINITION boolean-variable-property)
-(define-declaration 'SIDE-EFFECT-FREE boolean-variable-property)
-(define-declaration 'PURE-FUNCTION boolean-variable-property)
\ No newline at end of file
+(define-post-only-declaration 'UUO-LINK boolean-variable-property)
+(define-post-only-declaration 'CONSTANT boolean-variable-property)
+(define-post-only-declaration 'IGNORE-REFERENCE-TRAPS
+  boolean-variable-property)
+(define-post-only-declaration 'IGNORE-ASSIGNMENT-TRAPS
+  boolean-variable-property)
+(define-post-only-declaration 'USUAL-DEFINITION boolean-variable-property)
+(define-post-only-declaration 'SIDE-EFFECT-FREE boolean-variable-property)
+(define-post-only-declaration 'PURE-FUNCTION boolean-variable-property)
+\f
+;;;; Safety Check Declarations
+
+(let ()
+  (define (check-property block-checks set-block-checks! enable?)
+    (lambda (block keyword primitives)
+      keyword                          ;ignore
+      (set-block-checks!
+       block
+       (let ((checks (block-checks block)))
+        (if (null? primitives)
+            enable?
+            (if (boolean? checks)
+                (if (eqv? checks enable?)
+                    checks
+                    (if enable?
+                        (list checks primitives '())
+                        (list checks '() primitives)))
+                (let ((default (car checks))
+                      (do-check (cadr checks))
+                      (dont-check (caddr checks)))
+                  (if enable?
+                      (list default
+                            (eq-set-adjoin primitives do-check)
+                            dont-check)
+                      (list default
+                            do-check
+                            (eq-set-adjoin primitives dont-check))))))))))
+  (define-pre-only-declaration 'TYPE-CHECKS
+    (check-property block-type-checks set-block-type-checks! #t))
+  (define-pre-only-declaration 'NO-TYPE-CHECKS
+    (check-property block-type-checks set-block-type-checks! #f))
+  (define-pre-only-declaration 'RANGE-CHECKS
+    (check-property block-range-checks set-block-range-checks! #t))
+  (define-pre-only-declaration 'NO-RANGE-CHECKS
+    (check-property block-range-checks set-block-range-checks! #f)))

diff --git a/v7/src/compiler/fggen/fggen.scm b/v7/src/compiler/fggen/fggen.scm
index 1c649f8b27b3d2158bab6b6b25a2e3127dc3e3ff..011214a0c1d3e5a65eda0eed8053a775490387db 100644 (file)
--- a/v7/src/compiler/fggen/fggen.scm
+++ b/v7/src/compiler/fggen/fggen.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: fggen.scm,v 4.42 2007/01/05 21:19:20 cph Exp $
+$Id: fggen.scm,v 4.43 2007/04/14 22:00:09 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -97,11 +97,9 @@ USA.
   (map (lambda (name) (make-variable block name)) names))
 
 (define (generate/body block continuation context declarations expression)
-  ;; The call to `process-declarations!' must come after the
-  ;; expression is generated because it can refer to the set of free
-  ;; variables in the expression.
+  (process-pre-declarations! block declarations)
   (let ((scfg (generate/expression block continuation context expression)))
-    (process-top-level-declarations! block declarations)
+    (process-post-declarations! block declarations)
     scfg))
 \f
 ;;;; Continuations

diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm
index ec3fd2a6d2fff5c33c40b38b999f717a3aec6bd8..d670bc2714de1982444a94dcb2433c8e767dac53 100644 (file)
--- a/v7/src/compiler/rtlgen/opncod.scm
+++ b/v7/src/compiler/rtlgen/opncod.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: opncod.scm,v 4.79 2007/03/28 02:29:24 riastradh Exp $
+$Id: opncod.scm,v 4.80 2007/04/14 22:00:09 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -76,15 +76,19 @@ USA.
 (define (try-handler combination primitive entry)
   (let ((operands (combination/operands combination)))
     (and (primitive-arity-correct? primitive (length operands))
-        (with-values (lambda () ((vector-ref entry 0) operands))
-          (lambda (generator indices internal-close-coding?)
-            (and generator
-                 (make-inliner entry
-                               generator
-                               indices
-                               (if (boolean? internal-close-coding?)
-                                   internal-close-coding?
-                                   (internal-close-coding?)))))))))
+        (receive (generator indices internal-close-coding?)
+            ((vector-ref entry 0) operands
+                                  primitive
+                                  (combination/block combination))
+          (and generator
+               (make-inliner entry
+                             generator
+                             indices
+                             (if (boolean? internal-close-coding?)
+                                 internal-close-coding?
+                                 (internal-close-coding?
+                                  primitive
+                                  (combination/block combination)))))))))
 \f
 ;;;; Code Generator
 
@@ -249,19 +253,20 @@ USA.
 ;;;; Operand Filters
 
 (define (simple-open-coder generator operand-indices internal-close-coding?)
-  (lambda (operands)
-    operands
+  (lambda (operands primitive block)
+    operands primitive block
     (values generator operand-indices internal-close-coding?)))
 
 (define (conditional-open-coder predicate open-coder)
-  (lambda (operands)
-    (if (predicate operands)
-       (open-coder operands)
+  (lambda (operands primitive block)
+    (if (predicate operands primitive block)
+       (open-coder operands primitive block)
        (values false '() false))))
 
 (define (constant-filter predicate)
   (lambda (generator constant-index operand-indices internal-close-coding?)
-    (lambda (operands)
+    (lambda (operands primitive block)
+      primitive block                  ;ignore
       (let ((operand (rvalue-known-value (list-ref operands constant-index))))
        (if (and operand
                 (rvalue/constant? operand)
@@ -280,15 +285,15 @@ USA.
      (and (exact-nonnegative-integer? operand)
          (back-end:< operand scheme-type-limit)))))
 
-(define (internal-close-coding-for-type-checks)
-  compiler:generate-type-checks?)
+(define (internal-close-coding-for-type-checks primitive block)
+  (block/generate-type-checks? block primitive))
 
-(define (internal-close-coding-for-range-checks)
-  compiler:generate-range-checks?)
+(define (internal-close-coding-for-range-checks primitive block)
+  (block/generate-range-checks? block primitive))
 
-(define (internal-close-coding-for-type-or-range-checks)
-  (or compiler:generate-type-checks?
-      compiler:generate-range-checks?))
+(define (internal-close-coding-for-type-or-range-checks primitive block)
+  (or (block/generate-type-checks? block primitive)
+      (block/generate-range-checks? block primitive)))
 \f
 ;;;; Constraint Checkers
 
@@ -370,8 +375,9 @@ USA.
       continuation-label
       primitive))))
 \f
-(define (open-code:type-check expression type)
-  (if (and type compiler:generate-type-checks?)
+(define (open-code:type-check expression type primitive block)
+  (if (and type
+          (block/generate-type-checks? block primitive))
       (generate-type-test type
                          expression
                          make-false-pcfg
@@ -410,8 +416,9 @@ USA.
 ;; This is not reasonable since the port may not include such open codings.
 
 #|
-(define (open-code:range-check index-expression limit-locative)
-  (cond ((and limit-locative compiler:generate-range-checks?)
+(define (open-code:range-check index-expression limit-locative
+                              primitive block)
+  (cond ((and limit-locative (block/generate-range-checks? block primitive))
         (pcfg/prefer-consequent!
           (rtl:make-fixnum-pred-2-args
            'UNSIGNED-LESS-THAN-FIXNUM?
@@ -421,25 +428,28 @@ USA.
         (make-true-pcfg))))
 |#
 
-(define (open-code:index-check index-expression limit-locative)
+(define (open-code:index-check index-expression limit-locative
+                              primitive block)
   (cond ((not limit-locative)
-        (open-code:index-fixnum-check index-expression))
-       (compiler:generate-range-checks?
+        (open-code:index-fixnum-check index-expression primitive block))
+       ((block/generate-range-checks? block primitive)
         (pcfg*pcfg->pcfg!
-         (open-code:type-check index-expression (ucode-type fixnum))
+         (open-code:type-check index-expression (ucode-type fixnum)
+                               primitive block)
          (pcfg/prefer-consequent!
           (rtl:make-fixnum-pred-2-args
            'UNSIGNED-LESS-THAN-FIXNUM?
            (rtl:make-object->fixnum index-expression)
            (rtl:make-object->fixnum limit-locative)))
          (make-false-pcfg)))
-       (compiler:generate-type-checks?
-        (open-code:type-check index-expression (ucode-type fixnum)))
+       ((block/generate-type-checks? block primitive)
+        (open-code:type-check index-expression (ucode-type fixnum)
+                              primitive block))
        (else
         (make-true-pcfg))))
 
-(define (open-code:nonnegative-check expression)
-  (if compiler:generate-range-checks?
+(define (open-code:nonnegative-check expression primitive block)
+  (if (block/generate-range-checks? block primitive)
       (generate-nonnegative-check expression)
       (make-true-pcfg)))
 
@@ -455,9 +465,9 @@ USA.
         'NEGATIVE-FIXNUM?
         (rtl:make-object->fixnum expression))))))
 
-(define (open-code:index-fixnum-check expression)
-  (if (or compiler:generate-range-checks?
-         compiler:generate-type-checks?)
+(define (open-code:index-fixnum-check expression primitive block)
+  (if (or (block/generate-range-checks? block primitive)
+         (block/generate-type-checks? block primitive))
       (generate-index-fixnum-check expression)
       (make-true-pcfg)))
 
@@ -482,12 +492,16 @@ USA.
            (index (cadr expressions)))
        (open-code:with-checks
         combination
-        (cons*
-         (open-code:type-check object base-type)
-         (open-code:index-check index (length-expression object))
-         (if value-type
-             (list (open-code:type-check (caddr expressions) value-type))
-             '()))
+        (let ((block (combination/block combination)))
+          (cons*
+           (open-code:type-check object base-type name block)
+           (open-code:index-check index (length-expression object) name block)
+           (if value-type
+               (list (open-code:type-check (caddr expressions)
+                                           value-type
+                                           name
+                                           block))
+               '())))
         (index-locative object index
           (lambda (locative)
             (generator locative expressions finish)))
@@ -707,7 +721,8 @@ USA.
    false))
 \f
 (define-open-coder/predicate 'OBJECT-TYPE?
-  (lambda (operands)
+  (lambda (operands primitive block)
+    primitive block                    ;ignore
     (let ((operand (rvalue-known-value (car operands))))
       (if (and operand
               (rvalue/constant? operand)
@@ -728,10 +743,11 @@ USA.
                          (object (cadr expressions)))
                      (open-code:with-checks
                       combination
-                      (list
-                       (open-code:index-check type
-                                              (rtl:make-constant
-                                               scheme-type-limit)))
+                      (list (open-code:index-check
+                             type
+                             (rtl:make-constant scheme-type-limit)
+                             'OBJECT-TYPE?
+                             (combination/block combination)))
                       (finish
                        (rtl:make-eq-test (rtl:make-object->datum type)
                                          (rtl:make-object->type object)))
@@ -788,7 +804,10 @@ USA.
      (let ((mask (car expressions)))
        (open-code:with-checks
        combination
-       (list (open-code:type-check mask (ucode-type fixnum)))
+       (list (open-code:type-check mask
+                                   (ucode-type fixnum)
+                                   'SET-INTERRUPT-ENABLES!
+                                   (combination/block combination)))
        (let ((assignment
               (rtl:make-assignment register:int-mask
                                    (rtl:make-object->datum mask))))
@@ -824,7 +843,9 @@ USA.
      (let ((length (car expressions)))
        (open-code:with-checks
        combination
-       (list (open-code:index-fixnum-check length))
+       (list (open-code:index-fixnum-check length
+                                           'PRIMITIVE-INCREMENT-FREE
+                                           (combination/block combination)))
        (let ((assignment
               ((index-locative-generator rtl:locative-object-offset
                                          rtl:locative-object-index
@@ -851,7 +872,9 @@ USA.
      (let ((length (car expressions)))
        (open-code:with-checks
        combination
-       (list (open-code:index-fixnum-check length))
+       (list (open-code:index-fixnum-check length
+                                           'HEAP-AVAILABLE?
+                                           (combination/block combination)))
        ((index-locative-generator rtl:locative-object-offset
                                   rtl:locative-object-index
                                   0
@@ -888,7 +911,8 @@ USA.
     (filter/type-code open-code/pair-cons 0 '(1 2) false)))
 
 (define-open-coder/value 'VECTOR
-  (lambda (operands)
+  (lambda (operands primitive block)
+    primitive block                    ;ignore
     (if (< (length operands) 32)
        (values (lambda (combination expressions finish)
                  combination
@@ -901,7 +925,8 @@ USA.
        (values false false false))))
 
 (define-open-coder/value '%RECORD
-  (lambda (operands)
+  (lambda (operands primitive block)
+    primitive block                    ;ignore
     (if (< 1 (length operands) 32)
        (values (lambda (combination expressions finish)
                  combination
@@ -933,7 +958,9 @@ USA.
      (let ((length (car expressions)))
        (open-code:with-checks
        combination
-       (list (open-code:nonnegative-check length))
+       (list (open-code:nonnegative-check length
+                                          'STRING-ALLOCATE
+                                          (combination/block combination)))
        (scfg*scfg->scfg!
         (finish
          (rtl:make-typed-cons:string
@@ -957,7 +984,9 @@ USA.
        (let ((length (car expressions)))
         (open-code:with-checks
          combination
-         (list (open-code:index-fixnum-check length)
+         (list (open-code:index-fixnum-check length
+                                             name
+                                             (combination/block combination))
                (make-false-pcfg))
          (make-null-cfg)
          finish
@@ -978,7 +1007,10 @@ USA.
              (let ((expression (car expressions)))
                (open-code:with-checks
                 combination
-                (list (open-code:type-check expression type))
+                (list (open-code:type-check expression
+                                            type
+                                            name
+                                            (combination/block combination)))
                 (finish (make-fetch (rtl:locative-offset expression index)))
                 finish
                 name
@@ -1044,7 +1076,10 @@ USA.
              (let ((object (car expressions)))
                (open-code:with-checks
                 combination
-                (list (open-code:type-check object type))
+                (list (open-code:type-check object
+                                            type
+                                            name
+                                            (combination/block combination)))
                 (finish-vector-assignment (rtl:locative-offset object index)
                                           (cadr expressions)
                                           finish)
@@ -1063,8 +1098,10 @@ USA.
           (length (cadr expressions)))
        (open-code:with-checks
        combination
-       (list (open-code:type-check object (ucode-type string))
-             (open-code:index-fixnum-check length))
+       (let ((name 'SET-STRING-LENGTH!)
+             (block (combination/block combination)))
+         (list (open-code:type-check object (ucode-type string) name block)
+               (open-code:index-fixnum-check length name block)))
        (finish-vector-assignment (rtl:locative-offset object 1)
                                  (rtl:make-object->datum length)
                                  finish)
@@ -1102,15 +1139,18 @@ USA.
 
 (define-open-coder/value 'INTEGER->CHAR
   (conditional-open-coder
-   (lambda (operands)
+   (lambda (operands primitive block)
      operands
-     (not compiler:generate-range-checks?))
+     (not (block/generate-range-checks? block primitive)))
    (simple-open-coder
     (lambda (combination expressions finish)
       (let ((arg (car expressions)))
        (open-code:with-checks
         combination
-        (list (open-code:type-check arg (ucode-type fixnum)))
+        (list (open-code:type-check arg
+                                    (ucode-type fixnum)
+                                    'INTEGER->CHAR
+                                    (combination/block combination)))
         (finish
          (rtl:make-cons-non-pointer
           (rtl:make-machine-constant (ucode-type character))
@@ -1127,7 +1167,10 @@ USA.
      (let ((char (car expressions)))
        (open-code:with-checks
        combination
-       (list (open-code:type-check char (ucode-type character)))
+       (list (open-code:type-check char
+                                   (ucode-type character)
+                                   'CHAR->INTEGER
+                                   (combination/block combination)))
        (finish
         (rtl:make-cons-non-pointer
          (rtl:make-machine-constant (ucode-type fixnum))
@@ -1337,8 +1380,8 @@ USA.
 
 (define (floating-point-open-coder generator indices internal-close-coding?)
   (conditional-open-coder
-   (lambda (operands)
-     operands                          ; ignored
+   (lambda (operands primitive block)
+     operands primitive block          ; ignored
      compiler:open-code-floating-point-arithmetic?)
    (simple-open-coder generator indices internal-close-coding?)))
 
@@ -1350,7 +1393,10 @@ USA.
        (let ((argument (car expressions)))
          (open-code:with-checks
           combination
-          (list (open-code:type-check argument (ucode-type flonum)))
+          (list (open-code:type-check argument
+                                      (ucode-type flonum)
+                                      flonum-operator
+                                      (combination/block combination)))
           (finish (rtl:make-float->object
                    (rtl:make-flonum-1-arg
                     flonum-operator
@@ -1374,8 +1420,10 @@ USA.
              (arg2 (cadr expressions)))
          (open-code:with-checks
           combination
-          (list (open-code:type-check arg1 (ucode-type flonum))
-                (open-code:type-check arg2 (ucode-type flonum)))
+          (let ((name flonum-operator)
+                (block (combination/block combination)))
+            (list (open-code:type-check arg1 (ucode-type flonum) name block)
+                  (open-code:type-check arg2 (ucode-type flonum) name block)))
           (finish
            (rtl:make-float->object
             (rtl:make-flonum-2-args
@@ -1398,7 +1446,10 @@ USA.
        (let ((argument (car expressions)))
          (open-code:with-checks
           combination
-          (list (open-code:type-check argument (ucode-type flonum)))
+          (list (open-code:type-check argument
+                                      (ucode-type flonum)
+                                      flonum-pred
+                                      (combination/block combination)))
           (finish
            (rtl:make-flonum-pred-1-arg
             flonum-pred
@@ -1420,8 +1471,10 @@ USA.
              (arg2 (cadr expressions)))
          (open-code:with-checks
           combination
-          (list (open-code:type-check arg1 (ucode-type flonum))
-                (open-code:type-check arg2 (ucode-type flonum)))
+          (let ((name flonum-pred)
+                (block (combination/block combination)))
+            (list (open-code:type-check arg1 (ucode-type flonum) name block)
+                  (open-code:type-check arg2 (ucode-type flonum) name block)))
           (finish (rtl:make-flonum-pred-2-args
                    flonum-pred
                    (rtl:make-object->float arg1)

diff --git a/v7/src/runtime/syntax-output.scm b/v7/src/runtime/syntax-output.scm
index 3d426f35ac211e99b23510356f6327027c021c9a..e03080e1a36020f0fac9ca2b674eb8ad3f065bf0 100644 (file)
--- a/v7/src/runtime/syntax-output.scm
+++ b/v7/src/runtime/syntax-output.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: syntax-output.scm,v 14.13 2007/01/05 21:19:28 cph Exp $
+$Id: syntax-output.scm,v 14.14 2007/04/14 22:00:09 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -200,11 +200,17 @@ USA.
                                  (cdr declaration)
                                  (selector/add-cdr selector))))))
          ;; The names in USUAL-INTEGRATIONS are always global.
-         '(USUAL-INTEGRATIONS
+         '(
+           USUAL-INTEGRATIONS
            INTEGRATE
            INTEGRATE-OPERATOR
            INTEGRATE-SAFELY
-           IGNORE))
+           IGNORE
+           TYPE-CHECKS
+           NO-TYPE-CHECKS
+           RANGE-CHECKS
+           NO-RANGE-CHECKS
+           ))
 
 (define-declaration 'INTEGRATE-EXTERNAL
   `(* ,(lambda (object)

diff --git a/v7/src/sf/cgen.scm b/v7/src/sf/cgen.scm
index 3c9bdb1eab079e65eb8540b04c12365d5cdbb892..e181c3e0deea770662b8209e533fc12213559d6b 100644 (file)
--- a/v7/src/sf/cgen.scm
+++ b/v7/src/sf/cgen.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: cgen.scm,v 4.9 2007/01/05 21:19:29 cph Exp $
+$Id: cgen.scm,v 4.10 2007/04/14 22:00:09 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -86,7 +86,14 @@ USA.
 (define *known-compiler-declarations*
   ;; Declarations which are not handled by SF but are known to be handled
   ;; by the compiler so SF ignores then silently.
-  '(IGNORE-REFERENCE-TRAPS IGNORE-ASSIGNMENT-TRAPS))
+  '(
+    IGNORE-REFERENCE-TRAPS
+    IGNORE-ASSIGNMENT-TRAPS
+    TYPE-CHECKS
+    NO-TYPE-CHECKS
+    RANGE-CHECKS
+    NO-RANGE-CHECKS
+    ))
 
 (define (known-compiler-declaration? declaration)
   (memq (car declaration) *known-compiler-declarations*))