From c553093eea37cf48057675f6a3581115741b65c3 Mon Sep 17 00:00:00 2001 From: "Taylor R. Campbell" Date: Sat, 14 Apr 2007 22:00:09 +0000 Subject: [PATCH] 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. --- v7/src/compiler/base/blocks.scm | 35 +++++- v7/src/compiler/fggen/declar.scm | 128 +++++++++++++++---- v7/src/compiler/fggen/fggen.scm | 8 +- v7/src/compiler/rtlgen/opncod.scm | 197 +++++++++++++++++++----------- v7/src/runtime/syntax-output.scm | 12 +- v7/src/sf/cgen.scm | 11 +- 6 files changed, 281 insertions(+), 110 deletions(-) diff --git a/v7/src/compiler/base/blocks.scm b/v7/src/compiler/base/blocks.scm index 20994bf69..4f642871f 100644 --- 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 ( + range-checks ; ) ) (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)) - + (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)))))) ;;;; Block Type diff --git a/v7/src/compiler/fggen/declar.scm b/v7/src/compiler/fggen/declar.scm index ade8b5ddf..9130f94d5 100644 --- 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)) -(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)) (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) + +;;;; 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 1c649f8b2..011214a0c 100644 --- 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)) ;;;; Continuations diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm index ec3fd2a6d..d670bc271 100644 --- 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))))))))) ;;;; 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))) ;;;; Constraint Checkers @@ -370,8 +375,9 @@ USA. continuation-label primitive)))) -(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)) (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 3d426f35a..e03080e1a 100644 --- 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 3c9bdb1ea..e181c3e0d 100644 --- 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*)) -- 2.25.1