From: Stephen Adams Date: Wed, 22 Dec 1993 07:28:07 +0000 (+0000) Subject: Put ucode-type calls in procedures so that the procedures may be redefined X-Git-Tag: 20090517-FFI~7352 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a95bdd37250d14486a65bc9dc33cb7ab09e35412;p=mit-scheme.git Put ucode-type calls in procedures so that the procedures may be redefined for re-tagging --- diff --git a/v7/src/sf/usiexp.scm b/v7/src/sf/usiexp.scm index a02af7b0b..4df610da6 100644 --- a/v7/src/sf/usiexp.scm +++ b/v7/src/sf/usiexp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: usiexp.scm,v 4.21 1993/11/29 23:15:01 cph Exp $ +$Id: usiexp.scm,v 4.22 1993/12/22 07:28:07 adams Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -33,7 +33,7 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; SCode Optimizer: Usual Integrations: Combination Expansions -;;; package: (scode-optimizer expansion) +;; package: (scode-optimizer expansion) (declare (usual-integrations) (integrate-external "object")) @@ -459,20 +459,48 @@ MIT in each case. |# operands)) (if-not-expanded))) -(define (type-test-expansion type) +(define (type-test-expansion type-proc) (lambda (expr operands if-expanded if-not-expanded block) (if (and (pair? operands) (null? (cdr operands))) - (if-expanded (make-type-test expr block type (car operands))) + (if-expanded (make-type-test expr block (type-proc) (car operands))) (if-not-expanded)))) -(define char?-expansion (type-test-expansion (ucode-type character))) -(define cell?-expansion (type-test-expansion (ucode-type cell))) -(define vector?-expansion (type-test-expansion (ucode-type vector))) -(define %record?-expansion (type-test-expansion (ucode-type record))) -(define weak-pair?-expansion (type-test-expansion (ucode-type weak-cons))) -(define flo:flonum?-expansion (type-test-expansion (ucode-type big-flonum))) -(define fix:fixnum?-expansion (type-test-expansion (ucode-type fixnum))) +;; DO NOT make the following integrable! they are required to be procedures +;; for re-tagging + +(define (ucode-type/character) (ucode-type character)) +(define (ucode-type/cell) (ucode-type cell)) +(define (ucode-type/vector) (ucode-type vector)) +(define (ucode-type/record) (ucode-type record)) +(define (ucode-type/weak-cons) (ucode-type weak-cons)) +(define (ucode-type/big-flonum) (ucode-type big-flonum)) +(define (ucode-type/fixnum) (ucode-type fixnum)) +(define (ucode-type/positive-fixnum) (ucode-type positive-fixnum)) +(define (ucode-type/negative-fixnum) (ucode-type negative-fixnum)) + +(define char?-expansion (type-test-expansion ucode-type/character)) +(define cell?-expansion (type-test-expansion ucode-type/cell)) +(define vector?-expansion (type-test-expansion ucode-type/vector)) +(define %record?-expansion (type-test-expansion ucode-type/record)) +(define weak-pair?-expansion (type-test-expansion ucode-type/weak-cons)) +(define flo:flonum?-expansion (type-test-expansion ucode-type/big-flonum)) +(define fix:fixnum?-expansion (type-test-expansion ucode-type/fixnum)) + +;; for +ve & -ve fixnums? +;(define (fix:fixnum?-expansion expr operands if-expanded if-not-expanded block) +; (let ((pos-tag (ucode-type/positive-fixnum)) +; (neg-tag (ucode-type/negative-fixnum))) +; (if (and (pair? operands) +; (null? (cdr operands))) +; (if-expanded +; (if (eq? pos-tag neg-tag) +; (make-type-test false block pos-tag (car operands)) +; (make-disjunction +; expr +; (make-type-test false block pos-tag (car operands)) +; (make-type-test false block neg-tag (car operands))))) +; (if-not-expanded)))) (define (exact-integer?-expansion expr operands if-expanded if-not-expanded block) @@ -481,8 +509,8 @@ MIT in each case. |# (if-expanded (make-disjunction expr - (make-type-test false block (ucode-type fixnum) (car operands)) - (make-type-test false block (ucode-type big-fixnum) (car operands)))) + (make-type-test false block (ucode-type/fixnum) (car operands)) + (make-type-test false block (ucode-type/big-fixnum) (car operands)))) (if-not-expanded))) (define (exact-rational?-expansion expr operands if-expanded if-not-expanded @@ -492,9 +520,9 @@ MIT in each case. |# (if-expanded (make-disjunction expr - (make-type-test false block (ucode-type fixnum) (car operands)) - (make-type-test false block (ucode-type big-fixnum) (car operands)) - (make-type-test false block (ucode-type ratnum) (car operands)))) + (make-type-test false block (ucode-type/fixnum) (car operands)) + (make-type-test false block (ucode-type/big-fixnum) (car operands)) + (make-type-test false block (ucode-type/ratnum) (car operands)))) (if-not-expanded))) (define (complex?-expansion expr operands if-expanded if-not-expanded block) @@ -503,11 +531,11 @@ MIT in each case. |# (if-expanded (make-disjunction expr - (make-type-test false block (ucode-type fixnum) (car operands)) - (make-type-test false block (ucode-type big-fixnum) (car operands)) - (make-type-test false block (ucode-type ratnum) (car operands)) - (make-type-test false block (ucode-type big-flonum) (car operands)) - (make-type-test false block (ucode-type recnum) (car operands)))) + (make-type-test false block (ucode-type/fixnum) (car operands)) + (make-type-test false block (ucode-type/big-fixnum) (car operands)) + (make-type-test false block (ucode-type/ratnum) (car operands)) + (make-type-test false block (ucode-type/big-flonum) (car operands)) + (make-type-test false block (ucode-type/recnum) (car operands)))) (if-not-expanded))) (define (make-disjunction expr . clauses)