From: Joe Marshall Date: Sat, 5 Sep 2009 20:36:30 +0000 (-0700) Subject: Use DEFINE-PRIMITIVES. X-Git-Tag: 20100708-Gtk~347 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=104b9faa73b9b42e5e1d9ee21874d4c85e37f7f5;p=mit-scheme.git Use DEFINE-PRIMITIVES. --- diff --git a/src/runtime/boole.scm b/src/runtime/boole.scm index bdfb25a09..0eb87ee9f 100644 --- a/src/runtime/boole.scm +++ b/src/runtime/boole.scm @@ -28,8 +28,7 @@ USA. (declare (usual-integrations)) -(define-integrable (not object) - ((ucode-primitive not) object)) +(define-integrable not (ucode-primitive not)) (define false #f) (define true #t) diff --git a/src/runtime/char.scm b/src/runtime/char.scm index 804c53f5b..9bef80844 100644 --- a/src/runtime/char.scm +++ b/src/runtime/char.scm @@ -28,14 +28,10 @@ USA. (declare (usual-integrations)) -(define-integrable (char? object) - ((ucode-primitive char?) object)) - -(define-integrable (char->integer char) - ((ucode-primitive char->integer) char)) - -(define-integrable (integer->char int) - ((ucode-primitive integer->char) int)) +(define-primitives + (char? 1) + (char->integer 1) + (integer->char 1)) (define-integrable char-code-limit #x110000) (define-integrable char-bits-limit #x10) diff --git a/src/runtime/gentag.scm b/src/runtime/gentag.scm index 7134f9578..f734ebfbc 100644 --- a/src/runtime/gentag.scm +++ b/src/runtime/gentag.scm @@ -54,11 +54,9 @@ USA. (define-integrable dispatch-tag-index-start 2) (define-integrable dispatch-tag-index-end 10) -(define-integrable (dispatch-tag-ref t i) - (%record-ref t i)) +(define-integrable dispatch-tag-ref (ucode-primitive %record-ref)) -(define-integrable (dispatch-tag-set! t i x) - (%record-set! t i x)) +(define-integrable dispatch-tag-set! (ucode-primitive %record-set!)) (define (dispatch-tag-contents tag) (guarantee-dispatch-tag tag 'DISPATCH-TAG-CONTENTS) diff --git a/src/runtime/list.scm b/src/runtime/list.scm index a3cb276a2..197bf146b 100644 --- a/src/runtime/list.scm +++ b/src/runtime/list.scm @@ -65,29 +65,15 @@ USA. (declare (usual-integrations)) -(define-integrable (cons a b) - ((ucode-primitive cons) a b)) - -(define-integrable (pair? object) - ((ucode-primitive pair?) object)) - -(define-integrable (null? object) - ((ucode-primitive null?) object)) - -(define-integrable (car p) - ((ucode-primitive car) p)) - -(define-integrable (cdr p) - ((ucode-primitive cdr) p)) - -(define-integrable (set-car! p v) - ((ucode-primitive set-car!) p v)) - -(define-integrable (set-cdr! p v) - ((ucode-primitive set-cdr!) p v)) - -(define-integrable (general-car-cdr p i) - ((ucode-primitive general-car-cdr) p i)) +(define-primitives + (car 1) + (cdr 1) + (cons 2) + (general-car-cdr 2) + (null? 1) + (pair? 1) + (set-car! 2) + (set-cdr! 2)) (define (list . items) items) diff --git a/src/runtime/record.scm b/src/runtime/record.scm index 98217fb3e..fc9ec2f42 100644 --- a/src/runtime/record.scm +++ b/src/runtime/record.scm @@ -33,24 +33,14 @@ USA. (define-primitives (%record -1) + (%record? 1) + (%record-length 1) + (%record-ref 2) + (%record-set! 3) (primitive-object-ref 2) (primitive-object-set! 3) - (primitive-object-set-type 2)) - -(define-integrable (%record? object) - ((ucode-primitive %record?) object)) - -(define-integrable (%record-length record) - ((ucode-primitive %record-length) record)) - -(define-integrable (%record-ref record index) - ((ucode-primitive %record-ref) record index)) - -(define-integrable (%record-set! record index value) - ((ucode-primitive %record-set!) record index value)) - -(define-integrable (vector-cons length object) - ((ucode-primitive vector-cons) length object)) + (primitive-object-set-type 2) + (vector-cons 2)) (define-integrable (%make-record length object) ((ucode-primitive object-set-type) (ucode-type record) diff --git a/src/runtime/string.scm b/src/runtime/string.scm index 9114ac238..44906abad 100644 --- a/src/runtime/string.scm +++ b/src/runtime/string.scm @@ -41,65 +41,31 @@ USA. ;;;; Primitives -(define-integrable (string-allocate n) - ((ucode-primitive string-allocate) n)) - -(define-integrable (string? object) - ((ucode-primitive string?) object)) - -(define-integrable (string-length string) - ((ucode-primitive string-length) string)) - -(define-integrable (string-maximum-length string) - ((ucode-primitive string-maximum-length) string)) - -(define-integrable (set-string-length! string length) - ((ucode-primitive set-string-length!) string length)) - -(define-integrable (set-string-maximum-length! string length) - ((ucode-primitive set-string-maximum-length!) string length)) - -(define-integrable (string-ref string index) - ((ucode-primitive string-ref) string index)) - -(define-integrable (string-set! string index char) - ((ucode-primitive string-set!) string index char)) - -(define-integrable (substring-move-left! string1 start1 end1 string2 start2) - ((ucode-primitive substring-move-left!) string1 start1 end1 string2 start2)) - -(define-integrable (substring-move-right! string1 start1 end1 string2 start2) - ((ucode-primitive substring-move-right!) string1 start1 end1 string2 start2)) - -(define-integrable (vector-8b-ref vector-8b index) - ((ucode-primitive vector-8b-ref) vector-8b index)) - -(define-integrable (vector-8b-set! vector-8b index byte) - ((ucode-primitive vector-8b-set!) vector-8b index byte)) - -(define-integrable (vector-8b-fill! string start end ascii) - (substring-fill! string start end (ascii->char ascii))) - -(define-integrable (vector-8b-find-next-char string start end ascii) - (substring-find-next-char string start end (ascii->char ascii))) - -(define-integrable (vector-8b-find-previous-char string start end ascii) - (substring-find-previous-char string start end (ascii->char ascii))) - -(define-integrable (vector-8b-find-next-char-ci string start end ascii) - (substring-find-next-char-ci string start end (ascii->char ascii))) - -(define-integrable (vector-8b-find-previous-char-ci string start end ascii) - (substring-find-previous-char-ci string start end (ascii->char ascii))) +(define-primitives + (set-string-length! 2) + (set-string-maximum-length! 2) + (string-allocate 1) + (string-hash-mod 2) + (string-length 1) + (string-maximum-length 1) + (string-ref 2) + (string-set! 3) + (string? 1) + substring-move-left! + substring-move-right! + vector-8b-fill! + vector-8b-find-next-char + vector-8b-find-next-char-ci + vector-8b-find-previous-char + vector-8b-find-previous-char-ci + (vector-8b-ref 2) + (vector-8b-set! 3)) (define (string-hash key #!optional modulus) (if (default-object? modulus) ((ucode-primitive string-hash) key) ((ucode-primitive string-hash-mod) key modulus))) -(define (string-hash-mod key modulus) - ((ucode-primitive string-hash-mod) key modulus)) - (define (string-ci-hash key #!optional modulus) (string-hash (string-downcase key) modulus)) diff --git a/src/runtime/vector.scm b/src/runtime/vector.scm index 0f3f66b46..29de2058b 100644 --- a/src/runtime/vector.scm +++ b/src/runtime/vector.scm @@ -28,35 +28,17 @@ USA. (declare (usual-integrations)) -(define-integrable vector - (ucode-primitive vector)) - -(define-integrable (vector? object) - ((ucode-primitive vector?) object)) - -(define-integrable (vector-length v) - ((ucode-primitive vector-length) v)) - -(define-integrable (vector-ref v i) - ((ucode-primitive vector-ref) v i)) - -(define-integrable (vector-set! v i x) - ((ucode-primitive vector-set!) v i x)) - -(define-integrable (list->vector list) - ((ucode-primitive list->vector) list)) - -(define-integrable (subvector->list v s e) - ((ucode-primitive subvector->list) v s e)) - -(define-integrable (subvector-fill! v s e x) - ((ucode-primitive subvector-fill!) v s e x)) - -(define-integrable (subvector-move-left! v1 s1 e1 v2 s2) - ((ucode-primitive subvector-move-left!) v1 s1 e1 v2 s2)) - -(define-integrable (subvector-move-right! v1 s1 e1 v2 s2) - ((ucode-primitive subvector-move-right!) v1 s1 e1 v2 s2)) +(define-primitives + (list->vector 1) + (subvector->list 3) + (subvector-fill! 4) + (subvector-move-left! 5) + (subvector-move-right! 5) + (vector -1) + (vector-length 1) + (vector-ref 2) + (vector-set! 3) + (vector? 1)) (define-integrable (guarantee-vector object procedure) (if (not (vector? object))