From: Chris Hanson Date: Wed, 17 Jan 2018 06:40:36 +0000 (-0800) Subject: Merge dispatch-tags and tags into a single implementation. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~353 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=735bd13f0f4baddb65f33730b7eee640835e63dc;p=mit-scheme.git Merge dispatch-tags and tags into a single implementation. --- diff --git a/src/runtime/compound-predicate.scm b/src/runtime/compound-predicate.scm index f1d0d189d..13cdd7240 100644 --- a/src/runtime/compound-predicate.scm +++ b/src/runtime/compound-predicate.scm @@ -29,16 +29,11 @@ USA. (declare (usual-integrations)) -(define compound-tag-metatag) -(define compound-tag?) -(define %make-compound-tag) -(defer-boot-action 'make-metatag - (lambda () - (set! compound-tag-metatag (make-metatag 'compound-tag)) - (set! compound-tag? (tag->predicate compound-tag-metatag)) - (set! %make-compound-tag - (metatag-constructor compound-tag-metatag 'make-compound-tag)) - unspecific)) +(define compound-tag-metatag (make-metatag 'compound-tag)) +(define compound-tag? (tag->predicate compound-tag-metatag)) + +(define %make-compound-tag + (metatag-constructor compound-tag-metatag 'make-compound-tag)) (define (make-compound-tag predicate operator operands) (%make-compound-tag (cons operator (map tag-name operands)) diff --git a/src/runtime/gencache.scm b/src/runtime/gencache.scm index 993b4e816..d3c5252e9 100644 --- a/src/runtime/gencache.scm +++ b/src/runtime/gencache.scm @@ -31,9 +31,12 @@ USA. ;;; Functional Programming. Parts of this code are based on the ;;; September 16, 1992 PCL implementation. -(declare (usual-integrations) - (integrate-external "gentag")) +(declare (usual-integrations)) +(define-integrable dispatch-tag-ref %record-ref) +(define-integrable dispatch-tag-index-start 1) +(define-integrable dispatch-tag-index-end 9) + (define-structure (cache (constructor %make-cache)) (tag-index 0) (mask 0 read-only #t) @@ -342,9 +345,8 @@ USA. (fill-cache-if-possible new-cache tags* value)))) (try-next-tag-index (lambda () - (let ((index - (next-dispatch-tag-index (cache-tag-index new-cache)))) - (and index + (let ((index (fix:+ (cache-tag-index new-cache) 1))) + (and (fix:< index dispatch-tag-index-end) (begin (set-cache-tag-index! new-cache index) (fill-lines 0))))))) diff --git a/src/runtime/gentag.scm b/src/runtime/gentag.scm index e60f9e098..149c23a39 100644 --- a/src/runtime/gentag.scm +++ b/src/runtime/gentag.scm @@ -33,43 +33,58 @@ USA. (declare (usual-integrations)) -(define (make-dispatch-tag contents) - (let ((tag (%make-record dispatch-tag-marker dispatch-tag-index-end))) - (%record-set! tag 1 contents) - (do ((i dispatch-tag-index-start (fix:+ i 1))) - ((not (fix:< i dispatch-tag-index-end))) - (%record-set! tag i (get-dispatch-tag-cache-number))) +(define (%make-tag metatag name predicate extra) + (let ((tag + (%record metatag + (get-tag-cache-number) + (get-tag-cache-number) + (get-tag-cache-number) + (get-tag-cache-number) + (get-tag-cache-number) + (get-tag-cache-number) + (get-tag-cache-number) + (get-tag-cache-number) + name + predicate + extra + (%make-weak-set)))) + (set-predicate-tag! predicate tag) tag)) -(define-integrable (dispatch-tag? object) - (and (%record? object) - (eq? dispatch-tag-marker (%record-ref object 0)))) - -(define-unparser-method dispatch-tag? - (simple-unparser-method 'dispatch-tag - (lambda (tag) - (list (dispatch-tag-contents tag))))) +(define (tag-name? object) + (or (symbol? object) + (and (pair? object) + (symbol? (car object)) + (list? (cdr object)) + (every (lambda (elt) + (or (object-non-pointer? elt) + (tag-name? elt))) + (cdr object))))) +(register-predicate! tag-name? 'tag-name) + +(define (set-predicate-tag! predicate tag) + (defer-boot-action 'set-predicate-tag! + (lambda () + (set-predicate-tag! predicate tag)))) -(define-integrable dispatch-tag-marker '|#[dispatch-tag]|) -(define-integrable dispatch-tag-index-start 2) -(define-integrable dispatch-tag-index-end 10) +(define (tag? object) + (and (%record? object) + (metatag? (%record-ref object 0)))) +(register-predicate! tag? 'tag '<= %record?) -(define-integrable (dispatch-tag-ref t i) - (%record-ref t i)) +(define-integrable (%tag-name tag) + (%record-ref tag 9)) -(define-integrable (dispatch-tag-set! t i x) - (%record-set! t i x)) +(define-integrable (%tag->predicate tag) + (%record-ref tag 10)) -(define (dispatch-tag-contents tag) - (guarantee dispatch-tag? tag 'DISPATCH-TAG-CONTENTS) - (%record-ref tag 1)) +(define-integrable (%tag-extra tag) + (%record-ref tag 11)) -(declare (integrate-operator next-dispatch-tag-index)) -(define (next-dispatch-tag-index index) - (and (fix:< (fix:+ index 1) dispatch-tag-index-end) - (fix:+ index 1))) +(define-integrable (%tag-supersets tag) + (%record-ref tag 12)) -(define-integrable dispatch-tag-cache-number-adds-ok +(define-integrable tag-cache-number-adds-ok ;; This constant controls the number of non-zero bits tag cache ;; numbers will have. ;; @@ -79,138 +94,89 @@ USA. ;; primary cache locations from multiple tags. 4) -(define-deferred get-dispatch-tag-cache-number +(define-deferred get-tag-cache-number (let ((modulus (int:quotient (let loop ((n 2)) (if (fix:fixnum? n) (loop (int:* n 2)) n)) - dispatch-tag-cache-number-adds-ok)) + tag-cache-number-adds-ok)) (state (make-random-state))) (lambda () (random modulus state)))) -;;;; Object Tags - -;;; We assume that most new data types will be constructed from records, and -;;; therefore we should optimize the path for such structures as much as -;;; possible. - -(define (dispatch-tag object) - (declare (integrate object)) - (declare (ignore-reference-traps (set microcode-type-tag-table - microcode-type-method-table))) - (cond ((and (%record? object) - (dispatch-tag? (%record-ref object 0))) - (%record-ref object 0)) - ((vector-ref microcode-type-tag-table (object-type object)) - (vector-ref microcode-type-tag-table (object-type object))) - (else - ((vector-ref microcode-type-method-table (object-type object)) - object)))) - -(define (make-built-in-tag names) - (let ((tags (map built-in-dispatch-tag names))) - (if (any (lambda (tag) tag) tags) - (let ((tag (car tags))) - (if (not (and (every (lambda (tag*) - (eq? tag* tag)) - (cdr tags)) - (let ((names* (dispatch-tag-contents tag))) - (and (every (lambda (name) - (memq name names*)) - names) - (every (lambda (name) - (memq name names)) - names*))))) - (error "Illegal built-in tag redefinition:" names)) - tag) - (let ((tag (make-dispatch-tag (list-copy names)))) - (set! built-in-tags (cons tag built-in-tags)) - tag)))) - -(define (built-in-dispatch-tags) - (list-copy built-in-tags)) - -(define (built-in-dispatch-tag name) - (find (lambda (tag) - (memq name (dispatch-tag-contents tag))) - built-in-tags)) +(define (make-metatag name) + (guarantee tag-name? name 'make-metatag) + (letrec* + ((predicate + (lambda (object) + (and (%record? object) + (eq? metatag (%record-ref object 0))))) + (metatag (%make-tag metatag-tag name predicate '#()))) + (set-tag<=! metatag metatag-tag) + metatag)) + +(define (metatag-constructor metatag #!optional caller) + (guarantee metatag? metatag 'metatag-constructor) + (lambda (name predicate . extra) + (guarantee tag-name? name caller) + (guarantee unary-procedure? predicate caller) + (if (predicate? predicate) + (error "Can't assign multiple tags to the same predicate:" name)) + (%make-tag metatag name predicate (list->vector extra)))) + +(define (metatag? object) + (and (%record? object) + (eq? metatag-tag (%record-ref object 0)))) + +(define metatag-tag) +(add-boot-init! + (lambda () + (set! metatag-tag (%make-tag #f 'metatag metatag? '#())) + (%record-set! metatag-tag 0 metatag-tag))) + +(define (set-tag<=! t1 t2) + (defer-boot-action 'predicate-relations + (lambda () + (set-tag<=! t1 t2)))) -;;;; Initialization - -(define built-in-tags) -(define microcode-type-tag-table) -(define microcode-type-method-table) - -(define (initialize-tag-tables!) - (set! built-in-tags '()) - (set! microcode-type-tag-table - (make-initialized-vector (microcode-type/code-limit) - (lambda (code) - (make-built-in-tag - (let ((names (microcode-type/code->names code))) - (if (pair? names) - names - '(object))))))) - (set! microcode-type-method-table - (make-vector (microcode-type/code-limit) #f)) - - (let ((defmethod - (lambda (name get-method) - (let ((code (microcode-type/name->code name))) - (vector-set! microcode-type-method-table code - (get-method - (vector-ref microcode-type-tag-table code))) - (vector-set! microcode-type-tag-table code #f))))) - (defmethod 'compiled-entry - (lambda (default-tag) - (let ((procedure-tag (make-built-in-tag '(compiled-procedure))) - (return-tag (make-built-in-tag '(compiled-return-address))) - (expression-tag (make-built-in-tag '(compiled-expression)))) - (lambda (object) - (case (system-hunk3-cxr0 - ((ucode-primitive compiled-entry-kind 1) object)) - ((0) procedure-tag) - ((1) return-tag) - ((2) expression-tag) - (else default-tag)))))) - (defmethod 'false - (lambda (default-tag) - (let ((boolean-tag (make-built-in-tag '(boolean)))) - (lambda (object) - (if (eq? object #f) - boolean-tag - default-tag))))) - (defmethod 'constant - (lambda (default-tag) - (let ((boolean-tag (make-built-in-tag '(boolean))) - (null-tag (make-built-in-tag '(null))) - (eof-tag (make-built-in-tag '(eof))) - (default-object-tag (make-built-in-tag '(default))) - (keyword-tag (make-built-in-tag '(lambda-keyword)))) - (lambda (object) - (if (eof-object? object) - eof-tag - (case object - ((#t) boolean-tag) - ((()) null-tag) - ((#!default) default-object-tag) - ((#!optional #!rest #!key #!aux) keyword-tag) - (else default-tag))))))) - (defmethod 'record - (lambda (default-tag) - (let ((dt-tag (make-built-in-tag '(dispatch-tag)))) - (lambda (object) - (if (eq? dispatch-tag-marker (%record-ref object 0)) - dt-tag - default-tag))))) - - ;; Flonum length can change size on different architectures, so we - ;; measure one. - (let ((flonum-length (system-vector-length microcode-id/floating-epsilon))) - (defmethod 'flonum - (lambda (default-tag) - (let ((flonum-vector-tag (make-built-in-tag '(flonum-vector)))) - (lambda (object) - (if (fix:= flonum-length (system-vector-length object)) - default-tag - flonum-vector-tag)))))))) \ No newline at end of file +(define (tag-metatag tag) + (guarantee tag? tag 'tag-metatag) + (%record-ref tag 0)) + +(define (tag-name tag) + (guarantee tag? tag 'tag-name) + (%tag-name tag)) + +(define (tag->predicate tag) + (guarantee tag? tag 'tag->predicate) + (%tag->predicate tag)) + +(define (tag-extra tag index) + (guarantee tag? tag 'tag-extra) + (vector-ref (%tag-extra tag) index)) + +(define (any-tag-superset procedure tag) + (guarantee tag? tag 'any-tag-superset) + (%weak-set-any procedure (%tag-supersets tag))) + +(define (add-tag-superset tag superset) + (guarantee tag? tag 'add-tag-superset) + (guarantee tag? superset 'add-tag-superset) + (%add-to-weak-set superset (%tag-supersets tag))) + +(defer-boot-action 'predicate-relations + (lambda () + (set-predicate<=! metatag? tag?))) + +(define-unparser-method tag? + (simple-unparser-method + (lambda (tag) + (if (metatag? tag) 'metatag 'tag)) + (lambda (tag) + (list (tag-name tag))))) + +(define-pp-describer tag? + (lambda (tag) + (list (list 'metatag (tag-metatag tag)) + (list 'name (tag-name tag)) + (list 'predicate (tag->predicate tag)) + (cons 'extra (vector->list (%tag-extra tag)))))) \ No newline at end of file diff --git a/src/runtime/infutl.scm b/src/runtime/infutl.scm index 1727522d5..3e5d3327a 100644 --- a/src/runtime/infutl.scm +++ b/src/runtime/infutl.scm @@ -27,8 +27,8 @@ USA. ;;;; Compiled Code Information: Utilities ;;; package: (runtime compiler-info) -(declare (usual-integrations)) -(declare (integrate-external "infstr" "char")) +(declare (usual-integrations) + (integrate-external "infstr")) (define (compiled-code-block/dbg-info block demand-load?) (let ((wrapper (compiled-code-block/debugging-wrapper block))) diff --git a/src/runtime/make.scm b/src/runtime/make.scm index 50ddd4cb9..8ca7a27ab 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -408,7 +408,7 @@ USA. (package-initialize '(RUNTIME RANDOM-NUMBER) #f #t) (package-initialize '(runtime tagged-dispatch) #f #t) (package-initialize '(RUNTIME POPULATION) #f #t) - (package-initialize '(RUNTIME RECORD) 'INITIALIZE-RECORD-TYPE-TYPE! #t) + (package-initialize '(runtime record) #f #t) (load-files-with-boot-inits files2) (package-initialize '(RUNTIME 1D-PROPERTY) #f #t) ;First population. @@ -488,7 +488,6 @@ USA. (RUNTIME CONTINUATION-PARSER) (RUNTIME PROGRAM-COPIER) ;; Finish records - ((runtime tagged-dispatch) initialize-tag-tables!) ((RUNTIME RECORD) INITIALIZE-RECORD-PROCEDURES!) ((PACKAGE) FINALIZE-PACKAGE-RECORD-TYPE!) ((RUNTIME RANDOM-NUMBER) FINALIZE-RANDOM-STATE-TYPE!) diff --git a/src/runtime/parametric-predicate.scm b/src/runtime/parametric-predicate.scm index 00ba3ed40..69e626548 100644 --- a/src/runtime/parametric-predicate.scm +++ b/src/runtime/parametric-predicate.scm @@ -29,16 +29,11 @@ USA. (declare (usual-integrations)) -(define parametric-tag-metatag) -(define parametric-tag?) -(define %make-parametric-tag) -(defer-boot-action 'make-metatag - (lambda () - (set! parametric-tag-metatag (make-metatag 'parametric-tag)) - (set! parametric-tag? (tag->predicate parametric-tag-metatag)) - (set! %make-parametric-tag - (metatag-constructor parametric-tag-metatag 'make-parametric-tag)) - unspecific)) +(define parametric-tag-metatag (make-metatag 'parametric-tag)) +(define parametric-tag? (tag->predicate parametric-tag-metatag)) + +(define %make-parametric-tag + (metatag-constructor parametric-tag-metatag 'make-parametric-tag)) (define (make-parametric-tag name predicate template bindings) (%make-parametric-tag name predicate template bindings)) diff --git a/src/runtime/predicate-lattice.scm b/src/runtime/predicate-lattice.scm index 9d1df8520..287e7ae2d 100644 --- a/src/runtime/predicate-lattice.scm +++ b/src/runtime/predicate-lattice.scm @@ -53,11 +53,6 @@ USA. (define (tag>= tag1 tag2) (tag<= tag2 tag1)) -(define (set-tag<=! tag superset) - (defer-boot-action 'predicate-relations - (lambda () - (set-tag<=! tag superset)))) - (define (cached-tag<= tag1 tag2) (hash-table-intern! tag<=-cache (cons tag1 tag2) diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm index 409348c06..ba95d6cf5 100644 --- a/src/runtime/predicate-metadata.scm +++ b/src/runtime/predicate-metadata.scm @@ -30,14 +30,13 @@ USA. (declare (usual-integrations)) (define get-predicate-tag) -(define set-predicate-tag!) (add-boot-init! (lambda () (let ((table (make-hashed-metadata-table))) (set! predicate? (table 'has?)) (set! get-predicate-tag (table 'get)) (set! set-predicate-tag! (table 'put!)) - unspecific))) + (run-deferred-boot-actions 'set-predicate-tag!)))) (define (predicate-name predicate) (tag-name (predicate->tag predicate 'predicate-name))) @@ -48,47 +47,10 @@ USA. (error:not-a predicate? predicate caller)) tag)) -(define (make-metatag name) - (guarantee tag-name? name 'make-metatag) - (letrec* - ((predicate - (lambda (object) - (and (%record? object) - (eq? metatag (%record-ref object 0))))) - (metatag (%make-tag metatag-tag name predicate '#()))) - (set-tag<=! metatag metatag-tag) - metatag)) - -(define (metatag-constructor metatag #!optional caller) - (guarantee metatag? metatag 'metatag-constructor) - (lambda (name predicate . extra) - (guarantee tag-name? name caller) - (guarantee unary-procedure? predicate caller) - (if (predicate? predicate) - (error "Can't assign multiple tags to the same predicate:" predicate)) - (%make-tag metatag name predicate (list->vector extra)))) - -(define (metatag? object) - (and (%record? object) - (eq? metatag-tag (%record-ref object 0)))) - -(define (tag-name? object) - (or (symbol? object) - (and (pair? object) - (symbol? (car object)) - (list? (cdr object)) - (every (lambda (elt) - (or (object-non-pointer? elt) - (tag-name? elt))) - (cdr object))))) - -(define metatag-tag) (define simple-tag-metatag) (define %make-simple-tag) (add-boot-init! (lambda () - (set! metatag-tag (%make-tag #f 'metatag metatag? '#())) - (%record-set! metatag-tag 0 metatag-tag) (set! simple-tag-metatag (make-metatag 'simple-tag)) (set! %make-simple-tag @@ -103,71 +65,12 @@ USA. (get-keyword-values keylist '<=)) tag))) unspecific)) - -(defer-boot-action 'predicate-relations - (lambda () - (set-predicate<=! metatag? tag?))) - -(define (%make-tag metatag name predicate extra) - (let ((tag (%record metatag name predicate extra (%make-weak-set)))) - (set-predicate-tag! predicate tag) - tag)) - -(define (tag? object) - (and (%record? object) - (metatag? (%record-ref object 0)))) - -(define-unparser-method tag? - (simple-unparser-method - (lambda (tag) - (if (metatag? tag) 'metatag 'tag)) - (lambda (tag) - (list (tag-name tag))))) - -(define-integrable (%tag-name tag) - (%record-ref tag 1)) - -(define-integrable (%tag->predicate tag) - (%record-ref tag 2)) - -(define-integrable (%tag-extra tag) - (%record-ref tag 3)) - -(define-integrable (%tag-supersets tag) - (%record-ref tag 4)) - -(define (tag-metatag tag) - (guarantee tag? tag 'tag-metatag) - (%record-ref tag 0)) - -(define (tag-name tag) - (guarantee tag? tag 'tag-name) - (%record-ref tag 1)) - -(define (tag->predicate tag) - (guarantee tag? tag 'tag->predicate) - (%tag->predicate tag)) - -(define (tag-extra tag index) - (guarantee tag? tag 'tag-extra) - (vector-ref (%tag-extra tag) index)) - -(define (any-tag-superset procedure tag) - (guarantee tag? tag 'any-tag-superset) - (%weak-set-any procedure (%tag-supersets tag))) - -(define (add-tag-superset tag superset) - (guarantee tag? tag 'add-tag-superset) - (guarantee tag? superset 'add-tag-superset) - (%add-to-weak-set superset (%tag-supersets tag))) (add-boot-init! (lambda () (register-predicate! %record? '%record) (register-predicate! %tagged-object? 'tagged-object) - (register-predicate! predicate? 'predicate) - (register-predicate! tag-name? 'tag-name) - (register-predicate! tag? 'tag '<= %record?))) + (register-predicate! predicate? 'predicate))) ;;; Registration of standard predicates (add-boot-init! @@ -263,7 +166,6 @@ USA. (register-predicate! compiled-code-block? 'compiled-code-block) (register-predicate! compiled-expression? 'compiled-expression) (register-predicate! compiled-return-address? 'compiled-return-address) - (register-predicate! dispatch-tag? 'dispatch-tag) (register-predicate! ephemeron? 'ephemeron) (register-predicate! environment? 'environment) (register-predicate! equality-predicate? 'equality-predicate diff --git a/src/runtime/predicate-tagging.scm b/src/runtime/predicate-tagging.scm index 129e920c5..7af96ca48 100644 --- a/src/runtime/predicate-tagging.scm +++ b/src/runtime/predicate-tagging.scm @@ -155,6 +155,6 @@ USA. (define-primitive-predicate-method 'record (let ((default-tag (predicate->tag %record?))) (lambda (object) - (if (record? object) - (%record-type-tag (%record-type-descriptor object)) + (if (tag? (%record-ref object 0)) + (%record-ref object 0) default-tag)))))) \ No newline at end of file diff --git a/src/runtime/record.scm b/src/runtime/record.scm index c86ca9018..affa2c767 100644 --- a/src/runtime/record.scm +++ b/src/runtime/record.scm @@ -50,24 +50,6 @@ USA. (%record-set! result index (%record-ref record index))) result))) -(define record-type-type-tag) - -(define (initialize-record-type-type!) - (let* ((field-names - '#(dispatch-tag name field-names default-inits tag)) - (type - (%record #f - #f - "record-type" - field-names - (vector-cons (vector-length field-names) #f) - #f))) - (set! record-type-type-tag (make-dispatch-tag type)) - (%record-set! type 0 record-type-type-tag) - (%record-set! type 1 record-type-type-tag) - (%set-record-type-predicate! type record-type?)) - (initialize-structure-type-type!)) - (define (make-record-type type-name field-names #!optional default-inits unparser-method entity-unparser-method) @@ -84,21 +66,23 @@ USA. (error:wrong-type-argument default-inits "default initializers" caller)) - (let* ((record-type - (%record record-type-type-tag - #f - (->type-name type-name) - names - (if (default-object? default-inits) - (vector-cons n #f) - (list->vector default-inits)) - #f)) - (tag (make-dispatch-tag record-type))) - (%record-set! record-type 1 tag) - (let ((predicate - (lambda (object) - (%tagged-record? tag object)))) - (%set-record-type-predicate! record-type predicate) + (let ((record-type + (%record record-type-type-tag + #f + (->type-name type-name) + names + (if (default-object? default-inits) + (vector-cons n #f) + (list->vector default-inits))))) + (letrec* + ((predicate + (lambda (object) + (%tagged-record? tag object))) + (tag + (%make-record-tag (string->symbol (%record-type-name record-type)) + predicate + record-type))) + (%record-set! record-type 1 tag) (if (and unparser-method (not (default-object? unparser-method))) (define-unparser-method predicate unparser-method))) @@ -107,25 +91,48 @@ USA. (define (%valid-default-inits? default-inits n-fields) (fix:= n-fields (length default-inits))) -(defer-boot-action 'record-procedures - (lambda () - (set! %valid-default-inits? - (named-lambda (%valid-default-inits? default-inits n-fields) - (and (fix:= n-fields (length default-inits)) - (every (lambda (init) - (or (not init) - (thunk? init))) - default-inits)))) - unspecific)) - (define (initialize-record-procedures!) - (run-deferred-boot-actions 'record-procedures)) + (set! %valid-default-inits? + (named-lambda (%valid-default-inits? default-inits n-fields) + (and (fix:= n-fields (length default-inits)) + (every (lambda (init) + (or (not init) + (thunk? init))) + default-inits)))) + unspecific) +(define record-tag-metatag) +(define record-tag?) +(define %make-record-tag) +(define record-type-type-tag) +(add-boot-init! + (lambda () + (set! record-tag-metatag (make-metatag 'record-tag)) + (set! record-tag? (tag->predicate record-tag-metatag)) + (set! %make-record-tag + (metatag-constructor record-tag-metatag 'make-record-type)) + (let* ((field-names + '#(dispatch-tag name field-names default-inits tag)) + (type + (%record #f + #f + "record-type" + field-names + (vector-cons (vector-length field-names) #f)))) + (set! record-type-type-tag + (%make-record-tag 'record-type record-type? type)) + (%record-set! type 0 record-type-type-tag) + (%record-set! type 1 record-type-type-tag)))) + +(define (record-tag->type-descriptor tag) + (guarantee record-tag? tag 'record-tag->type-descriptor) + (tag-extra tag 0)) + (define (record-type? object) (%tagged-record? record-type-type-tag object)) (define-integrable (%record-type-descriptor record) - (dispatch-tag-contents (%record-tag record))) + (tag-extra (%record-tag record) 0)) (define-integrable (%record-type-dispatch-tag record-type) (%record-ref record-type 1)) @@ -139,11 +146,8 @@ USA. (define-integrable (%record-type-default-inits record-type) (%record-ref record-type 4)) -(define-integrable (%record-type-tag record-type) - (%record-ref record-type 5)) - -(define-integrable (%set-record-type-tag! record-type tag) - (%record-set! record-type 5 tag)) +(define-integrable (%record-type-predicate record-type) + (tag->predicate (%record-type-dispatch-tag record-type))) (define-integrable (%record-type-n-fields record-type) (vector-length (%record-type-field-names record-type))) @@ -156,18 +160,16 @@ USA. (fix:- index 1))) (define (record-type-dispatch-tag record-type) - (guarantee-record-type record-type 'RECORD-TYPE-DISPATCH-TAG) + (guarantee record-type? record-type 'record-type-dispatch-tag) (%record-type-dispatch-tag record-type)) (define (record-type-name record-type) - (guarantee-record-type record-type 'RECORD-TYPE-NAME) + (guarantee record-type? record-type 'record-type-name) (%record-type-name record-type)) (define (record-type-field-names record-type) - (guarantee-record-type record-type 'RECORD-TYPE-FIELD-NAMES) - ;; Can't use VECTOR->LIST here because it isn't available at cold load. - (let ((v (%record-type-field-names record-type))) - ((ucode-primitive subvector->list) v 0 (vector-length v)))) + (guarantee record-type? record-type 'record-type-field-names) + (vector->list (%record-type-field-names record-type))) (define (record-type-default-value-by-index record-type field-index) (let ((init @@ -175,42 +177,17 @@ USA. (fix:- field-index 1)))) (and init (init)))) - -(define %record-type-predicate %record-type-tag) - -(define (%set-record-type-predicate! record-type predicate) - (defer-boot-action 'predicate-registrations - (lambda () - (%set-record-type-predicate! record-type predicate))) - (%set-record-type-tag! record-type predicate)) - -(defer-boot-action 'predicate-registrations - (lambda () - (set! %record-type-predicate - (named-lambda (%record-type-predicate record-type) - (tag->predicate (%record-type-tag record-type)))) - (set! %set-record-type-predicate! - (named-lambda (%set-record-type-predicate! record-type predicate) - (%register-record-predicate! predicate record-type) - (%set-record-type-tag! record-type (predicate->tag predicate)))) - unspecific)) - -(define (%register-record-predicate! predicate record-type) - (register-predicate! predicate - (string->symbol - (strip-angle-brackets (%record-type-name record-type))) - '<= record?)) ;;;; Constructors (define (record-constructor record-type #!optional field-names) - (guarantee-record-type record-type 'RECORD-CONSTRUCTOR) + (guarantee record-type? record-type 'record-constructor) (if (or (default-object? field-names) (equal? field-names (record-type-field-names record-type))) (%record-constructor-default-names record-type) (begin (if (not (list? field-names)) - (error:not-a list? field-names 'RECORD-CONSTRUCTOR)) + (error:not-a list? field-names 'record-constructor)) (%record-constructor-given-names record-type field-names)))) (define %record-constructor-default-names @@ -336,23 +313,22 @@ USA. (define (record? object) (and (%record? object) - (dispatch-tag? (%record-tag object)) - (record-type? (dispatch-tag-contents (%record-tag object))))) + (record-tag? (%record-tag object)))) (define (record-type-descriptor record) - (guarantee-record record 'RECORD-TYPE-DESCRIPTOR) + (guarantee record? record 'record-type-descriptor) (%record-type-descriptor record)) (define (copy-record record) - (guarantee-record record 'COPY-RECORD) + (guarantee record? record 'copy-record) (%copy-record record)) (define (record-predicate record-type) - (guarantee-record-type record-type 'RECORD-PREDICATE) + (guarantee record-type? record-type 'record-predicate) (%record-type-predicate record-type)) (define (record-accessor record-type field-name) - (guarantee-record-type record-type 'record-accessor) + (guarantee record-type? record-type 'record-accessor) (let ((tag (%record-type-dispatch-tag record-type)) (predicate (%record-type-predicate record-type)) (index (record-type-field-index record-type field-name #t))) @@ -377,7 +353,7 @@ USA. (expand-cases 16)))) (define (record-modifier record-type field-name) - (guarantee-record-type record-type 'record-modifier) + (guarantee record-type? record-type 'record-modifier) (let ((tag (%record-type-dispatch-tag record-type)) (predicate (%record-type-predicate record-type)) (index (record-type-field-index record-type field-name #t))) @@ -405,7 +381,6 @@ USA. (define record-updater record-modifier) (define (record-type-field-index record-type name error?) - ;; Can't use VECTOR->LIST here because it isn't available at cold load. (let* ((names (%record-type-field-names record-type)) (n (vector-length names))) (let loop ((i 0)) @@ -427,14 +402,7 @@ USA. (and (list-of-type? object symbol?) (let loop ((elements object)) (if (pair? elements) - ;; No memq in the cold load. - (let memq ((item (car elements)) - (tail (cdr elements))) - (cond ((pair? tail) (if (eq? item (car tail)) - #f - (memq item (cdr tail)))) - ((null? tail) (loop (cdr elements))) - (else (error "Improper list.")))) + (not (memq (car elements) (cdr elements))) #t)))) (define-guarantee record-type "record type") @@ -443,7 +411,7 @@ USA. ;;;; Printing (define-unparser-method %record? - (standard-unparser-method 'record #f)) + (standard-unparser-method '%record #f)) (define-unparser-method record? (standard-unparser-method @@ -480,42 +448,6 @@ USA. ;;;; Runtime support for DEFINE-STRUCTURE -(define (initialize-structure-type-type!) - (set! rtd:structure-type - (make-record-type "structure-type" - '(PHYSICAL-TYPE NAME FIELD-NAMES FIELD-INDEXES - DEFAULT-INITS TAG LENGTH))) - (set! make-define-structure-type - (let ((constructor (record-constructor rtd:structure-type))) - (lambda (physical-type name field-names field-indexes default-inits - unparser-method tag length) - ;; unparser-method arg should be removed after 9.3 is released. - (declare (ignore unparser-method)) - (constructor physical-type - name - field-names - field-indexes - default-inits - tag - length)))) - (set! structure-type? - (record-predicate rtd:structure-type)) - (set! structure-type/physical-type - (record-accessor rtd:structure-type 'PHYSICAL-TYPE)) - (set! structure-type/name - (record-accessor rtd:structure-type 'NAME)) - (set! structure-type/field-names - (record-accessor rtd:structure-type 'FIELD-NAMES)) - (set! structure-type/field-indexes - (record-accessor rtd:structure-type 'FIELD-INDEXES)) - (set! structure-type/default-inits - (record-accessor rtd:structure-type 'DEFAULT-INITS)) - (set! structure-type/tag - (record-accessor rtd:structure-type 'TAG)) - (set! structure-type/length - (record-accessor rtd:structure-type 'LENGTH)) - unspecific) - (define rtd:structure-type) (define make-define-structure-type) (define structure-type?) @@ -528,6 +460,42 @@ USA. (define set-structure-type/unparser-method!) (define structure-type/tag) (define structure-type/length) +(add-boot-init! + (lambda () + (set! rtd:structure-type + (make-record-type "structure-type" + '(PHYSICAL-TYPE NAME FIELD-NAMES FIELD-INDEXES + DEFAULT-INITS TAG LENGTH))) + (set! make-define-structure-type + (let ((constructor (record-constructor rtd:structure-type))) + (lambda (physical-type name field-names field-indexes default-inits + unparser-method tag length) + ;; unparser-method arg should be removed after 9.3 is released. + (declare (ignore unparser-method)) + (constructor physical-type + name + field-names + field-indexes + default-inits + tag + length)))) + (set! structure-type? + (record-predicate rtd:structure-type)) + (set! structure-type/physical-type + (record-accessor rtd:structure-type 'PHYSICAL-TYPE)) + (set! structure-type/name + (record-accessor rtd:structure-type 'NAME)) + (set! structure-type/field-names + (record-accessor rtd:structure-type 'FIELD-NAMES)) + (set! structure-type/field-indexes + (record-accessor rtd:structure-type 'FIELD-INDEXES)) + (set! structure-type/default-inits + (record-accessor rtd:structure-type 'DEFAULT-INITS)) + (set! structure-type/tag + (record-accessor rtd:structure-type 'TAG)) + (set! structure-type/length + (record-accessor rtd:structure-type 'LENGTH)) + unspecific)) (define-integrable (structure-type/field-index type field-name) (vector-ref (structure-type/field-indexes type) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index aca1ac29a..af01c32df 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1842,20 +1842,8 @@ USA. (files "predicate-metadata") (parent (runtime)) (export () - make-metatag - metatag-constructor - metatag? - predicate-name) - (export (runtime) predicate->tag - tag->predicate - tag-extra - tag-name - tag-metatag - tag?) - (export (runtime predicate-lattice) - any-tag-superset - add-tag-superset)) + predicate-name)) (define-package (runtime predicate-lattice) (files "predicate-lattice") @@ -1869,7 +1857,6 @@ USA. (export (runtime) bottom-tag define-tag<= - set-tag<=! tag-is-bottom? tag-is-top? tag<= @@ -3721,8 +3708,6 @@ USA. (export () deprecated:record set-record-type-unparser-method!) (export () - %copy-record - %record-tag condition-type:no-such-slot condition-type:slot-error condition-type:uninitialized-slot @@ -3756,10 +3741,9 @@ USA. (export (runtime) error:no-such-slot error:uninitialized-slot + record-tag->type-descriptor + record-tag? record-type-field-index) - (export (runtime predicate-tagging) - %record-type-descriptor - %record-type-tag) (initialization (initialize-package!))) (define-package (runtime reference-trap) @@ -5117,11 +5101,21 @@ USA. (files "gentag" "gencache") (parent (runtime)) (export () - built-in-dispatch-tag - dispatch-tag - dispatch-tag-contents - dispatch-tag? - make-dispatch-tag)) + make-metatag + metatag-constructor + metatag?) + (export (runtime) + set-tag<=! + tag->predicate + tag-extra + tag-metatag + tag-name + tag?) + (export (runtime predicate-lattice) + add-tag-superset + any-tag-superset) + (export (runtime predicate-metadata) + set-predicate-tag!)) (define-package (runtime crypto) (files "crypto") diff --git a/src/runtime/runtime.sf b/src/runtime/runtime.sf index 9a9a84c26..804ac3a3f 100644 --- a/src/runtime/runtime.sf +++ b/src/runtime/runtime.sf @@ -24,22 +24,15 @@ USA. |# -(load-option '*PARSER) ;for url.scm -(fluid-let ((sf/default-syntax-table (->environment '(RUNTIME)))) +(load-option '*parser) ;for url.scm +(fluid-let ((sf/default-syntax-table (->environment '(runtime)))) (load "host-adapter") - (sf-conditionally "char") - (sf-conditionally "chrset") - (sf-conditionally "gentag") (sf-conditionally "graphics") (sf-conditionally "infstr") - - (sf-conditionally "port") - (sf-conditionally "input") - (sf-conditionally "output") (sf-directory ".")) ;; Guarantee that the package modeller is loaded. load-option ensures ;; that when cross-syntaxing the cref `native' to the running system ;; is loaded. -(load-option 'CREF) -(cref/generate-constructors "runtime" 'ALL) \ No newline at end of file +(load-option 'cref) +(cref/generate-constructors "runtime" 'all) \ No newline at end of file diff --git a/src/runtime/symbol.scm b/src/runtime/symbol.scm index 34e20396c..4bc8787ef 100644 --- a/src/runtime/symbol.scm +++ b/src/runtime/symbol.scm @@ -50,7 +50,14 @@ USA. (make-unmapped-unbound-reference-trap))) (define (string->symbol string #!optional start end) - ((ucode-primitive string->symbol) (string->utf8 string start end))) + ((ucode-primitive string->symbol) + ;; Needed during cold load. + (if (and (%ustring1? string) + (ustring-ascii? string) + (default-object? start) + (default-object? end)) + (->bytes string) + (string->utf8 string start end)))) (define (symbol->string symbol) (if (not (symbol? symbol)) diff --git a/src/sos/class.scm b/src/sos/class.scm index 6698dbd39..f4af37585 100644 --- a/src/sos/class.scm +++ b/src/sos/class.scm @@ -63,18 +63,38 @@ USA. direct-slots)))) (set-class/precedence-list! class (compute-precedence-list class)) (set-class/slots! class (compute-slots class)) - (set-class/dispatch-tag! class (make-dispatch-tag class)) + (set-class/dispatch-tag! + class + (make-class-tag name + (lambda (object) + (and (instance? object) + (subclass? (instance-class object) class))) + class)) (install-slot-accessor-methods class) class)) +(define class-metatag + (make-metatag 'class-tag)) + +(define class-tag? + (tag->predicate class-metatag)) + +(define make-class-tag + (metatag-constructor class-metatag 'make-class)) + (define (make-trivial-subclass superclass . superclasses) (make-class (class-name superclass) (cons superclass superclasses) '())) (define - (let ((class (%make-class ' '() '()))) + (let ((class (%make-class ' '() '()))) (set-class/precedence-list! class (list class)) (set-class/slots! class '()) - (set-class/dispatch-tag! class (make-dispatch-tag class)) + (set-class/dispatch-tag! class + (make-class-tag ' + (lambda (object) + (declare (ignore object)) + #t) + class)) class)) (define (class-name class) @@ -283,9 +303,7 @@ USA. (define-primitive-class ) (define-primitive-class ) (define-primitive-class ) -(define-primitive-class <%record> ) -(define-primitive-class <%record>) -(define-primitive-class <%record>) +(define-primitive-class ) (define-primitive-class ) (define-primitive-class ) (define-primitive-class ) @@ -320,7 +338,7 @@ USA. (define-primitive-class ) (define (object-class object) - (dispatch-tag->class (dispatch-tag object))) + (dispatch-tag->class (object->tag object))) (define (record-type-class type) (dispatch-tag->class (record-type-dispatch-tag type))) @@ -329,14 +347,14 @@ USA. (record-type-class (record-type-descriptor record))) (define (dispatch-tag->class tag) - (let ((contents (dispatch-tag-contents tag))) - (cond ((class? contents) contents) - ((hash-table/get built-in-class-table tag #f)) - ((record-type? contents) - (let ((class (make-record-type-class contents))) - (hash-table/put! built-in-class-table tag class) - class)) - (else )))) + (cond ((class-tag? tag) (tag-extra tag 0)) + ((hash-table/get built-in-class-table tag #f)) + ((record-tag? tag) + (let ((class + (make-record-type-class (record-tag->type-descriptor tag)))) + (hash-table/put! built-in-class-table tag class) + class)) + (else ))) (define (make-record-type-class type) (let ((class @@ -361,45 +379,24 @@ USA. ;; classes anyway, which have strong references to dispatch tags, ;; so they need to be changed to hold weak references. (make-strong-eq-hash-table)) - + (let ((assign-type - (lambda (name class) + (lambda (predicate class) (hash-table/put! built-in-class-table - (or (built-in-dispatch-tag name) - (built-in-dispatch-tag - (microcode-type/code->name - (microcode-type/name->code name))) - (error "Unknown type name:" name)) + (predicate->tag predicate) class)))) - (assign-type 'BOOLEAN ) - (assign-type 'CHARACTER ) - (assign-type 'PAIR ) - (assign-type 'RECORD <%record>) - (assign-type 'DISPATCH-TAG ) - (assign-type 'STRING ) - (assign-type 'INTERNED-SYMBOL ) - (assign-type 'UNINTERNED-SYMBOL ) - (assign-type 'VECTOR ) - - (assign-type 'COMPILED-PROCEDURE ) - (assign-type 'EXTENDED-PROCEDURE ) - (assign-type 'PRIMITIVE ) - (assign-type 'PROCEDURE ) - (assign-type 'ENTITY ) - - (if (fix:= (object-type 1) (object-type -1)) - (assign-type 'FIXNUM ) - (begin - (assign-type 'POSITIVE-FIXNUM ) - (assign-type 'NEGATIVE-FIXNUM ))) - (assign-type 'BIGNUM ) - (assign-type 'RATNUM ) - (assign-type 'FLONUM ) - (assign-type 'FLONUM-VECTOR ) - (assign-type 'RECNUM )) - -(hash-table/put! built-in-class-table - standard-generic-procedure-tag - ) + (assign-type boolean? ) + (assign-type char? ) + (assign-type entity? ) + (assign-type exact-integer? ) + (assign-type exact-rational? ) + (assign-type flo:flonum? ) + (assign-type generic-procedure? ) + (assign-type number? ) + (assign-type pair? ) + (assign-type procedure? ) + (assign-type string? ) + (assign-type symbol? ) + (assign-type vector? )) (define (object-class )) \ No newline at end of file diff --git a/src/sos/generic.scm b/src/sos/generic.scm index 798f6b8a5..60099c149 100644 --- a/src/sos/generic.scm +++ b/src/sos/generic.scm @@ -37,13 +37,13 @@ USA. (generator (if (default-object? generator) #f generator))) (if (and name (not (symbol? name))) (error:wrong-type-argument name "symbol" 'MAKE-GENERIC-PROCEDURE)) - (if tag (guarantee dispatch-tag? tag 'MAKE-GENERIC-PROCEDURE)) + (if tag (guarantee tag? tag 'MAKE-GENERIC-PROCEDURE)) (guarantee procedure-arity? arity 'MAKE-GENERIC-PROCEDURE) (if (not (fix:> (procedure-arity-min arity) 0)) (error:bad-range-argument arity 'MAKE-GENERIC-PROCEDURE)) (guarantee-generator generator 'MAKE-GENERIC-PROCEDURE) (let ((record - (make-generic-record (or tag standard-generic-procedure-tag) + (make-generic-record (predicate->tag generic-procedure?) (procedure-arity-min arity) (procedure-arity-max arity) generator @@ -73,6 +73,7 @@ USA. (with-thread-mutex-lock generic-procedure-records-mutex (lambda () (if (eqht/get generic-procedure-records object #f) #t #f)))) +(register-predicate! generic-procedure? 'generic-procedure '<= procedure?) (define (generic-record/arity record) (make-procedure-arity (generic-record/arity-min record) @@ -196,7 +197,7 @@ USA. (wna args)) (loop (cdr args*) (fix:- n 1) - (cons (dispatch-tag (car args*)) tags))))))) + (cons (object->tag (car args*)) tags))))))) (wna (lambda (args) (error:wrong-number-of-arguments generic @@ -208,7 +209,7 @@ USA. (let ((record (guarantee-generic-procedure procedure 'GENERIC-PROCEDURE-APPLICABLE?)) - (tags (map dispatch-tag arguments))) + (tags (map object->tag arguments))) (let ((generator (generic-record/generator record)) (arity-min (generic-record/arity-min record)) (arity-max (generic-record/arity-max record)) @@ -223,46 +224,42 @@ USA. (define (apply-generic-1 record) (lambda (a1) - (declare (integrate-operator dispatch-tag)) (let ((procedure (probe-cache-1 (generic-record/cache record) - (dispatch-tag a1)))) + (object->tag a1)))) (if procedure (procedure a1) (compute-method-and-store record (list a1)))))) (define (apply-generic-2 record) (lambda (a1 a2) - (declare (integrate-operator dispatch-tag)) (let ((procedure (probe-cache-2 (generic-record/cache record) - (dispatch-tag a1) - (dispatch-tag a2)))) + (object->tag a1) + (object->tag a2)))) (if procedure (procedure a1 a2) (compute-method-and-store record (list a1 a2)))))) (define (apply-generic-3 record) (lambda (a1 a2 a3) - (declare (integrate-operator dispatch-tag)) (let ((procedure (probe-cache-3 (generic-record/cache record) - (dispatch-tag a1) - (dispatch-tag a2) - (dispatch-tag a3)))) + (object->tag a1) + (object->tag a2) + (object->tag a3)))) (if procedure (procedure a1 a2 a3) (compute-method-and-store record (list a1 a2 a3)))))) (define (apply-generic-4 record) (lambda (a1 a2 a3 a4) - (declare (integrate-operator dispatch-tag)) (let ((procedure (probe-cache-4 (generic-record/cache record) - (dispatch-tag a1) - (dispatch-tag a2) - (dispatch-tag a3) - (dispatch-tag a4)))) + (object->tag a1) + (object->tag a2) + (object->tag a3) + (object->tag a4)))) (if procedure (procedure a1 a2 a3 a4) (compute-method-and-store record (list a1 a2 a3 a4)))))) @@ -274,7 +271,7 @@ USA. (p p (cdr p)) (i (generic-record/arity-min record) (fix:- i 1))) ((not (fix:> i 0))) - (set-cdr! p (list (dispatch-tag (car args))))) + (set-cdr! p (list (object->tag (car args))))) (cdr p)))) (let ((procedure (let ((generator (generic-record/generator record)) @@ -288,8 +285,6 @@ USA. (fill-cache (generic-record/cache record) tags procedure)))) (apply procedure args)))) -(define standard-generic-procedure-tag - (make-dispatch-tag 'standard-generic-procedure)) (define generic-procedure-records (make-eqht)) (define generic-procedure-records-mutex (make-thread-mutex)) diff --git a/src/sos/instance.scm b/src/sos/instance.scm index dd9fa6580..583d7d202 100644 --- a/src/sos/instance.scm +++ b/src/sos/instance.scm @@ -330,10 +330,10 @@ USA. (define (instance? object) (and (tagged-vector? object) - (class? (dispatch-tag-contents (tagged-vector-tag object))))) + (class-tag? (tagged-vector-tag object)))) (define (instance-class instance) - (dispatch-tag-contents (tagged-vector-tag instance))) + (dispatch-tag->class (tagged-vector-tag instance))) (define (instance-predicate specializer) (if (not (specializer? specializer)) diff --git a/src/sos/printer.scm b/src/sos/printer.scm index ce7f326ac..1c0548402 100644 --- a/src/sos/printer.scm +++ b/src/sos/printer.scm @@ -73,8 +73,7 @@ USA. (install 'METHOD) (install 'CHAINED-METHOD) (install 'COMPUTED-METHOD) - (install 'COMPUTED-EMP) - (install <%record> '%RECORD)) + (install 'COMPUTED-EMP)) (add-method write-instance (make-method (list ) @@ -82,14 +81,6 @@ USA. (write-instance-helper (record-type-name (record-type-descriptor record)) record port #f)))) -(add-method write-instance - (make-method (list ) - (lambda (tag port) - (write-instance-helper 'DISPATCH-TAG tag port - (lambda () - (write-char #\space port) - (write (dispatch-tag-contents tag) port)))))) - (define (write-instance-helper name object port thunk) (write-string "#[" port) (display name port) diff --git a/src/sos/recslot.scm b/src/sos/recslot.scm index eb1ddb5a0..95c7216df 100644 --- a/src/sos/recslot.scm +++ b/src/sos/recslot.scm @@ -106,7 +106,7 @@ USA. (add-generic-procedure-generator %record-slot-index (lambda (generic tags) generic - (and (record-type? (dispatch-tag-contents (car tags))) + (and (record-tag? (car tags)) (lambda (record name) (record-type-field-index (record-type-descriptor record) name @@ -117,6 +117,6 @@ USA. (add-generic-procedure-generator %record-slot-names (lambda (generic tags) generic - (and (record-type? (dispatch-tag-contents (car tags))) + (and (record-tag? (car tags)) (lambda (record) (record-type-field-names (record-type-descriptor record)))))) \ No newline at end of file diff --git a/src/sos/slot.scm b/src/sos/slot.scm index 433dba657..77a776d92 100644 --- a/src/sos/slot.scm +++ b/src/sos/slot.scm @@ -71,16 +71,16 @@ USA. (add-generic-procedure-generator %record-slot-index (lambda (generic tags) generic - (and (class? (dispatch-tag-contents (car tags))) + (and (class-tag? (car tags)) (lambda (instance name) - (let ((slot (class-slot (object-class instance) name #f))) + (let ((slot (class-slot (instance-class instance) name #f))) (and slot (slot-index slot))))))) (add-generic-procedure-generator %record-slot-names (lambda (generic tags) generic - (and (class? (dispatch-tag-contents (car tags))) + (and (class-tag? (car tags)) (lambda (instance) (map slot-name (class-slots (object-class instance))))))) diff --git a/src/sos/sos.pkg b/src/sos/sos.pkg index 27c397418..d1958615a 100644 --- a/src/sos/sos.pkg +++ b/src/sos/sos.pkg @@ -52,8 +52,7 @@ USA. generic-procedure? guarantee-generic-procedure make-generic-procedure - purge-generic-procedure-cache - standard-generic-procedure-tag) + purge-generic-procedure-cache) (export (sos) condition-type:no-applicable-methods error:no-applicable-methods) @@ -144,13 +143,11 @@ USA. (files "class") (parent (sos)) (export () - <%record> - @@ -195,6 +192,8 @@ USA. record-class record-type-class subclass?) + (export (sos) + class-tag?) (import (runtime microcode-tables) microcode-type/code->name microcode-type/name->code)) diff --git a/src/sos/tvector.scm b/src/sos/tvector.scm index 2b38f5be4..e66cdd100 100644 --- a/src/sos/tvector.scm +++ b/src/sos/tvector.scm @@ -33,17 +33,17 @@ USA. ;;; calls to construct and access tagged vectors. (define (make-tagged-vector tag length) - (guarantee dispatch-tag? tag 'MAKE-TAGGED-VECTOR) + (guarantee tag? tag 'MAKE-TAGGED-VECTOR) (guarantee-index-integer length 'MAKE-TAGGED-VECTOR) (%make-record tag (fix:+ length 1) record-slot-uninitialized)) (define (tagged-vector tag . elements) - (guarantee dispatch-tag? tag 'MAKE-TAGGED-VECTOR) + (guarantee tag? tag 'MAKE-TAGGED-VECTOR) (apply %record tag elements)) (define (tagged-vector? object) (and (%record? object) - (dispatch-tag? (%record-ref object 0)))) + (tag? (%record-ref object 0)))) (define (tagged-vector-tag vector) (guarantee-tagged-vector vector 'TAGGED-VECTOR-TAG) @@ -51,7 +51,7 @@ USA. (define (set-tagged-vector-tag! vector tag) (guarantee-tagged-vector vector 'SET-TAGGED-VECTOR-TAG!) - (guarantee dispatch-tag? tag 'SET-TAGGED-VECTOR-TAG!) + (guarantee tag? tag 'SET-TAGGED-VECTOR-TAG!) (%record-set! vector 0 tag)) (define (tagged-vector-length vector) diff --git a/tests/sos/test-genmult.scm b/tests/sos/test-genmult.scm index 43762edcb..2e3d7f229 100644 --- a/tests/sos/test-genmult.scm +++ b/tests/sos/test-genmult.scm @@ -41,14 +41,14 @@ USA. ;; Add some named generators (for easier removal). (define (bool-generator p tags) p ;ignore - (if (equal? tags (list (built-in-dispatch-tag 'boolean))) + (if (equal? tags (list (predicate->tag boolean?))) (lambda (x) (cons 'boolean x)) #f)) (add-generic-procedure-generator generic bool-generator) (assert-equal (generic #t) '(boolean . #t)) (define (fixnum-generator p tags) p ;ignore - (if (equal? tags (list (built-in-dispatch-tag 'fixnum))) + (if (equal? tags (list (predicate->tag fix:fixnum?))) (lambda (x) (cons 'fixnum x)) #f)) (add-generic-procedure-generator generic fixnum-generator)