From: Stephen Adams Date: Wed, 15 Oct 1997 03:25:55 +0000 (+0000) Subject: Moved open-coding of VECTOR?, %RECORD? and CHAR? from SF to X-Git-Tag: 20090517-FFI~4994 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f6ac78a356717413255ca374875675b12bd30e67;p=mit-scheme.git Moved open-coding of VECTOR?, %RECORD? and CHAR? from SF to open-coders in compiler. --- diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm index 683996229..dde167b05 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.65 1997/10/14 14:20:05 adams Exp $ +$Id: opncod.scm,v 4.66 1997/10/15 03:25:55 adams Exp $ Copyright (c) 1988-97 Massachusetts Institute of Technology @@ -620,8 +620,14 @@ MIT in each case. |# (lambda (name type) (define-open-coder/predicate name (simple-open-coder (open-code/type-test type) '(0) false))))) - (simple-type-test 'PAIR? (ucode-type pair)) - (simple-type-test 'STRING? (ucode-type string)) + (simple-type-test 'CHAR? (ucode-type character)) + (simple-type-test 'CELL? (ucode-type cell)) + (simple-type-test 'PAIR? (ucode-type pair)) + (simple-type-test 'STRING? (ucode-type string)) + (simple-type-test 'VECTOR? (ucode-type vector)) + (simple-type-test '%RECORD? (ucode-type record)) + (simple-type-test 'FIXNUM? (ucode-type fixnum)) + (simple-type-test 'FLONUM? (ucode-type flonum)) (simple-type-test 'BIT-STRING? (ucode-type vector-1b)))) (define-open-coder/predicate 'EQ? @@ -632,6 +638,22 @@ MIT in each case. |# '(0 1) false)) +(define-open-coder/predicate 'EQUAL-FIXNUM? + (simple-open-coder + (lambda (combination expressions finish) + combination + (finish (rtl:make-eq-test (car expressions) (cadr expressions)))) + '(0 1) + false)) + +(define-open-coder/predicate 'ZERO-FIXNUM? + (simple-open-coder + (lambda (combination expressions finish) + combination + (finish (rtl:make-eq-test (car expressions) (rtl:make-constant 0)))) + '(0) + false)) + (define-open-coder/predicate 'INDEX-FIXNUM? (simple-open-coder (lambda (combination expressions finish) diff --git a/v7/src/runtime/char.scm b/v7/src/runtime/char.scm index d2dc7eb20..b107b972c 100644 --- a/v7/src/runtime/char.scm +++ b/v7/src/runtime/char.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: char.scm,v 14.6 1997/04/20 05:10:43 cph Exp $ +$Id: char.scm,v 14.7 1997/10/15 03:20:42 adams Exp $ Copyright (c) 1988-97 Massachusetts Institute of Technology @@ -38,12 +38,9 @@ MIT in each case. |# (declare (usual-integrations)) (define-primitives - make-char char-code char-bits char->integer integer->char char->ascii + char? make-char char-code char-bits char->integer integer->char char->ascii char-ascii? ascii->char char-upcase char-downcase) -(define-integrable (char? object) - (object-type? (ucode-type character) object)) - (define-integrable char-code-limit #x80) (define-integrable char-bits-limit #x20) (define-integrable char-integer-limit #x1000) diff --git a/v7/src/runtime/record.scm b/v7/src/runtime/record.scm index efc06b001..28b2c0aea 100644 --- a/v7/src/runtime/record.scm +++ b/v7/src/runtime/record.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: record.scm,v 1.26 1997/06/25 03:27:54 cph Exp $ +$Id: record.scm,v 1.27 1997/10/15 03:21:02 adams Exp $ Copyright (c) 1989-97 Massachusetts Institute of Technology @@ -41,6 +41,7 @@ MIT in each case. |# (declare (usual-integrations)) (define-primitives + (%record? 1) (%record -1) (%record-length 1) (%record-ref 2) @@ -49,9 +50,6 @@ MIT in each case. |# (primitive-object-set! 3) (primitive-object-set-type 2)) -(define-integrable (%record? object) - (object-type? (ucode-type record) object)) - (define (%make-record length #!optional object) (if (not (exact-integer? length)) (error:wrong-type-argument length "exact integer" '%MAKE-RECORD)) diff --git a/v7/src/runtime/vector.scm b/v7/src/runtime/vector.scm index 7836a30e2..71e52a2de 100644 --- a/v7/src/runtime/vector.scm +++ b/v7/src/runtime/vector.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: vector.scm,v 14.10 1997/02/23 06:16:12 cph Exp $ +$Id: vector.scm,v 14.11 1997/10/15 03:20:51 adams Exp $ Copyright (c) 1988-97 Massachusetts Institute of Technology @@ -38,7 +38,7 @@ MIT in each case. |# (declare (usual-integrations)) (define-primitives - vector-length vector-ref vector-set! + vector? vector-length vector-ref vector-set! list->vector vector subvector->list subvector-move-right! subvector-move-left! subvector-fill!) @@ -57,9 +57,6 @@ MIT in each case. |# (if (not (fix:<= end (vector-length vector))) (error:bad-range-argument end procedure))) -(define-integrable (vector? object) - (object-type? (ucode-type vector) object)) - (define (make-vector size #!optional fill) (if (not (index-fixnum? size)) (error:wrong-type-argument size "valid vector index" 'MAKE-VECTOR)) diff --git a/v7/src/sf/gconst.scm b/v7/src/sf/gconst.scm index e9569d058..ecab223ea 100644 --- a/v7/src/sf/gconst.scm +++ b/v7/src/sf/gconst.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: gconst.scm,v 4.21 1997/07/15 16:05:10 adams Exp $ +$Id: gconst.scm,v 4.22 1997/10/15 03:22:10 adams Exp $ Copyright (c) 1987-1994 Massachusetts Institute of Technology @@ -47,6 +47,7 @@ MIT in each case. |# %RECORD-LENGTH %RECORD-REF %RECORD-SET! + %RECORD? *THE-NON-PRINTING-OBJECT* ASCII->CHAR BIT-STRING->UNSIGNED-INTEGER @@ -70,6 +71,7 @@ MIT in each case. |# CAR CDR CELL-CONTENTS + CELL? CHAR->ASCII CHAR->INTEGER CHAR-ASCII? @@ -81,6 +83,7 @@ MIT in each case. |# CHAR-INTEGER-LIMIT CHAR-UPCASE CHAR:NEWLINE + CHAR? COMPILED-CODE-ADDRESS->BLOCK COMPILED-CODE-ADDRESS->OFFSET CONS @@ -95,11 +98,12 @@ MIT in each case. |# FIX:-1+ FIX:1+ FIX:< - ;; FIX:= handled by expanding it to EQ? + FIX:= FIX:> FIX:AND FIX:ANDC FIX:DIVIDE + FIX:FIXNUM? FIX:GCD FIX:LSH FIX:NEGATIVE? @@ -109,7 +113,7 @@ MIT in each case. |# FIX:QUOTIENT FIX:REMAINDER FIX:XOR - ;; FIX:ZERO? handled by expanding it to (EQ? x 0) + FIX:ZERO? FLO:* FLO:+ FLO:- @@ -127,6 +131,7 @@ MIT in each case. |# FLO:COS FLO:EXP FLO:EXPT + FLO:FLONUM? FLO:FLOOR FLO:FLOOR->EXACT FLO:LOG @@ -280,6 +285,7 @@ MIT in each case. |# VECTOR-LENGTH VECTOR-REF VECTOR-SET! + VECTOR? WITH-HISTORY-DISABLED WITH-INTERRUPT-MASK WRITE-BITS! diff --git a/v7/src/sf/usiexp.scm b/v7/src/sf/usiexp.scm index 66c60d7df..34488c143 100644 --- a/v7/src/sf/usiexp.scm +++ b/v7/src/sf/usiexp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: usiexp.scm,v 4.37 1997/07/31 18:33:07 adams Exp $ +$Id: usiexp.scm,v 4.38 1997/10/15 03:22:26 adams Exp $ Copyright (c) 1988-95 Massachusetts Institute of Technology @@ -471,13 +471,7 @@ MIT in each case. |# (if-expanded (make-type-test expr block type (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))) (define (exact-integer?-expansion expr operands if-expanded if-not-expanded block) @@ -584,7 +578,6 @@ MIT in each case. |# (define usual-integrations/expansion-names '( - %record? * + - @@ -626,9 +619,7 @@ MIT in each case. |# cddddr cdddr cddr - cell? char=? - char? complex? cons* eighth @@ -640,9 +631,6 @@ MIT in each case. |# fix:<= fix:= fix:>= - fix:fixnum? - fix:zero? - flo:flonum? fourth int:->flonum int:integer? @@ -662,7 +650,6 @@ MIT in each case. |# symbol? third values - vector? weak-pair? with-values zero? @@ -670,7 +657,6 @@ MIT in each case. |# (define usual-integrations/expansion-values (list - %record?-expansion *-expansion +-expansion --expansion @@ -712,9 +698,7 @@ MIT in each case. |# cddddr-expansion cdddr-expansion cddr-expansion - cell?-expansion char=?-expansion - char?-expansion complex?-expansion cons*-expansion eighth-expansion @@ -726,9 +710,6 @@ MIT in each case. |# fix:<=-expansion fix:=-expansion fix:>=-expansion - fix:fixnum?-expansion - fix:zero?-expansion - flo:flonum?-expansion fourth-expansion int:->flonum-expansion exact-integer?-expansion @@ -748,7 +729,6 @@ MIT in each case. |# symbol?-expansion third-expansion values-expansion - vector?-expansion weak-pair?-expansion call-with-values-expansion zero?-expansion diff --git a/v8/src/compiler/midend/fakeprim.scm b/v8/src/compiler/midend/fakeprim.scm index a99a653c9..4e7300312 100644 --- a/v8/src/compiler/midend/fakeprim.scm +++ b/v8/src/compiler/midend/fakeprim.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: fakeprim.scm,v 1.29 1997/07/09 15:12:44 adams Exp $ +$Id: fakeprim.scm,v 1.30 1997/10/15 03:22:57 adams Exp $ Copyright (c) 1994-96 Massachusetts Institute of Technology @@ -1037,9 +1037,8 @@ MIT in each case. |# '(SIDE-EFFECT-FREE) '(PROPER-PREDICATE)))) (list not eq? null? false? - boolean? cell? pair? string? bit-string? - ;; these two no not exist as primitives (SF expands to OBJECT-TYPE?) - ;; vector? %record? + boolean? cell? char? pair? string? bit-string? + vector? %record? fixnum? index-fixnum? flo:flonum? object-type? fix:= fix:> fix:< fix:<= fix:>= fix:zero? fix:positive? fix:negative? diff --git a/v8/src/compiler/midend/rtlgen.scm b/v8/src/compiler/midend/rtlgen.scm index 2c33ac366..c474dc50d 100644 --- a/v8/src/compiler/midend/rtlgen.scm +++ b/v8/src/compiler/midend/rtlgen.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: rtlgen.scm,v 1.52 1997/07/09 15:12:26 adams Exp $ +$Id: rtlgen.scm,v 1.53 1997/10/15 03:23:20 adams Exp $ -Copyright (c) 1994-96 Massachusetts Institute of Technology +Copyright (c) 1994-1997 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -3259,10 +3259,10 @@ MIT in each case. |# (else (rtlgen/branch/false state))))))))) (define-simple-tag-test 'CELL? (machine-tag 'CELL)) + (define-simple-tag-test 'CHAR? (machine-tag 'CHARACTER)) (define-simple-tag-test 'PAIR? (machine-tag 'PAIR)) - ;; These two are not primitives (yet) - ;;(define-simple-tag-test 'VECTOR? (machine-tag 'VECTOR)) - ;;(define-simple-tag-test '%RECORD? (machine-tag 'RECORD)) + (define-simple-tag-test 'VECTOR? (machine-tag 'VECTOR)) + (define-simple-tag-test '%RECORD? (machine-tag 'RECORD)) (define-simple-tag-test 'STRING? (machine-tag 'STRING)) (define-simple-tag-test 'BIT-STRING? (machine-tag 'VECTOR-1B)) (define-simple-tag-test 'FLONUM? (machine-tag 'FLONUM)) diff --git a/v8/src/compiler/midend/typedb.scm b/v8/src/compiler/midend/typedb.scm index 414ea50db..54e1989e0 100644 --- a/v8/src/compiler/midend/typedb.scm +++ b/v8/src/compiler/midend/typedb.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: typedb.scm,v 1.15 1997/07/31 10:39:52 adams Exp $ +$Id: typedb.scm,v 1.16 1997/10/15 03:23:50 adams Exp $ -Copyright (c) 1996 Massachusetts Institute of Technology +Copyright (c) 1996-1997 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -386,5 +386,5 @@ MIT in each case. |# (lambda (name) (define-operator-type (make-primitive-procedure name) (primitive-procedure-type (list type:any) type:boolean 'function))) - '(BIT-STRING? CELL? FIXNUM? FLONUM? INDEX-FIXNUM? NOT NULL? - PAIR? STRING? INTEGER?)) + '(BIT-STRING? CELL? CHAR? FIXNUM? FLONUM? INDEX-FIXNUM? NOT NULL? + PAIR? STRING? INTEGER? VECTOR? %RECORD?)) diff --git a/v8/src/compiler/midend/types.scm b/v8/src/compiler/midend/types.scm index 0c87170de..bbb03ebab 100644 --- a/v8/src/compiler/midend/types.scm +++ b/v8/src/compiler/midend/types.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: types.scm,v 1.5 1996/07/27 03:31:38 adams Exp $ +$Id: types.scm,v 1.6 1997/10/15 03:24:22 adams Exp $ -Copyright (c) 1995-1996 Massachusetts Institute of Technology +Copyright (c) 1995-1997 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -442,8 +442,10 @@ MIT in each case. |# (define (def-prim name . types) (apply define-predicate-test-types (make-primitive-procedure name) types)) + (def-prim '%RECORD? type:%record) (def-prim 'BIT-STRING? type:bit-string) (def-prim 'CELL? type:cell) + (def-prim 'CHAR? type:character) (def-prim 'FIXNUM? type:fixnum) (def-prim 'FLONUM? type:flonum) (def-prim 'INDEX-FIXNUM? type:fixnum>=0) @@ -451,6 +453,7 @@ MIT in each case. |# (def-prim 'NULL? type:empty-list) (def-prim 'PAIR? type:pair) (def-prim 'STRING? type:string) + (def-prim 'VECTOR? type:vector) (def-prim 'INTEGER? type:exact-integer) (define-predicate-test-types %compiled-entry? type:compiled-entry) ) diff --git a/v8/src/sf/gconst.scm b/v8/src/sf/gconst.scm index 8dc4f7a5e..5d44c6a41 100644 --- a/v8/src/sf/gconst.scm +++ b/v8/src/sf/gconst.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: gconst.scm,v 1.4 1997/07/09 14:39:47 adams Exp $ +$Id: gconst.scm,v 1.5 1997/10/15 03:21:19 adams Exp $ Copyright (c) 1987-93 Massachusetts Institute of Technology @@ -47,6 +47,7 @@ MIT in each case. |# %RECORD-LENGTH %RECORD-REF %RECORD-SET! + %RECORD? *THE-NON-PRINTING-OBJECT* ASCII->CHAR BIT-STRING->UNSIGNED-INTEGER @@ -82,6 +83,7 @@ MIT in each case. |# CHAR-INTEGER-LIMIT CHAR-UPCASE CHAR:NEWLINE + CHAR? COMPILED-CODE-ADDRESS->BLOCK COMPILED-CODE-ADDRESS->OFFSET CONS @@ -285,6 +287,7 @@ MIT in each case. |# VECTOR-LENGTH VECTOR-REF VECTOR-SET! + VECTOR? WITH-HISTORY-DISABLED WITH-INTERRUPT-MASK WRITE-BITS! diff --git a/v8/src/sf/usiexp.scm b/v8/src/sf/usiexp.scm index 9769c6359..0903a07dc 100644 --- a/v8/src/sf/usiexp.scm +++ b/v8/src/sf/usiexp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: usiexp.scm,v 1.15 1997/07/31 18:32:58 adams Exp $ +$Id: usiexp.scm,v 1.16 1997/10/15 03:21:37 adams Exp $ Copyright (c) 1988-1995 Massachusetts Institute of Technology @@ -434,16 +434,8 @@ MIT in each case. |# get-the-types)))))) (if-not-expanded)))) - (define char?-expansion - (type-test-expansion (cross-sf/ucode-type 'character))) - (define vector?-expansion - (type-test-expansion (cross-sf/ucode-type 'vector))) - (define %record?-expansion - (type-test-expansion (cross-sf/ucode-type 'record))) (define weak-pair?-expansion (type-test-expansion (cross-sf/ucode-type 'weak-cons))) - (define flo:flonum?-expansion - (unary-arithmetic (ucode-primitive flonum?))) (define fixnum-ucode-types (let ((-ve (cross-sf/ucode-type 'negative-fixnum)) @@ -536,8 +528,7 @@ MIT in each case. |# `(,(car spec) . ,(apply global-operator spec)))) (define usual-integrations/expansion-alist - `((%record? . ,%record?-expansion) - (* . ,*-expansion) + `((* . ,*-expansion) (+ . ,+-expansion) (- . ,--expansion) (-1+ . ,-1+-expansion) @@ -579,7 +570,6 @@ MIT in each case. |# (cdddr . ,cdddr-expansion) (cddr . ,cddr-expansion) (char=? . ,char=?-expansion) - (char? . ,char?-expansion) (complex? . ,complex?-expansion) (cons* . ,cons*-expansion) (eighth . ,eighth-expansion) @@ -607,7 +597,6 @@ MIT in each case. |# (symbol? . ,symbol?-expansion) (third . ,third-expansion) (values . ,values-expansion) - (vector? . ,vector?-expansion) (weak-pair? . ,weak-pair?-expansion) (with-values . ,call-with-values-expansion) (zero? . ,zero?-expansion)