From: Chris Hanson Date: Thu, 18 Jan 2018 02:02:58 +0000 (-0800) Subject: Rename "tag" to "dispatch-tag" and move bindings to global env. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~352 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8b9a15e5048e276a7344cfd05082b7e28725f4c1;p=mit-scheme.git Rename "tag" to "dispatch-tag" and move bindings to global env. This name is at least somewhat specific, so it should be OK in global. --- diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm index eee490b91..a78024dea 100644 --- a/src/runtime/bundle.scm +++ b/src/runtime/bundle.scm @@ -57,11 +57,12 @@ USA. ((predicate (lambda (datum) (and (bundle? datum) - (tag<= (bundle-interface-tag (bundle-interface datum)) tag)))) + (dispatch-tag<= (bundle-interface-tag (bundle-interface datum)) + tag)))) (tag (begin (register-predicate! predicate name '<= bundle?) - (predicate->tag predicate)))) + (predicate->dispatch-tag predicate)))) tag)) (define (elements? object) @@ -88,7 +89,7 @@ USA. (element-properties %bundle-interface-element-properties)) (define (bundle-interface-predicate interface) - (tag->predicate (bundle-interface-tag interface))) + (dispatch-tag->predicate (bundle-interface-tag interface))) (define (bundle-interface-element-names interface) (vector->list (%bundle-interface-element-names interface))) diff --git a/src/runtime/compound-predicate.scm b/src/runtime/compound-predicate.scm index 13cdd7240..9cc5b72d5 100644 --- a/src/runtime/compound-predicate.scm +++ b/src/runtime/compound-predicate.scm @@ -29,23 +29,23 @@ USA. (declare (usual-integrations)) -(define compound-tag-metatag (make-metatag 'compound-tag)) -(define compound-tag? (tag->predicate compound-tag-metatag)) +(define compound-tag-metatag (make-dispatch-metatag 'compound-tag)) +(define compound-tag? (dispatch-tag->predicate compound-tag-metatag)) (define %make-compound-tag - (metatag-constructor compound-tag-metatag 'make-compound-tag)) + (dispatch-metatag-constructor compound-tag-metatag 'make-compound-tag)) (define (make-compound-tag predicate operator operands) - (%make-compound-tag (cons operator (map tag-name operands)) + (%make-compound-tag (cons operator (map dispatch-tag-name operands)) predicate operator operands)) (define-integrable (compound-tag-operator tag) - (tag-extra tag 0)) + (dispatch-tag-extra tag 0)) (define-integrable (compound-tag-operands tag) - (tag-extra tag 1)) + (dispatch-tag-extra tag 1)) (define (tag-is-disjoin? object) (and (compound-tag? object) @@ -58,21 +58,21 @@ USA. (add-boot-init! (lambda () - (define-tag<= tag? tag-is-disjoin? + (define-dispatch-tag<= dispatch-tag? tag-is-disjoin? (lambda (tag1 tag2) (any (lambda (component2) - (tag<= tag1 component2)) + (dispatch-tag<= tag1 component2)) (compound-tag-operands tag2)))) - (define-tag<= tag-is-conjoin? tag? + (define-dispatch-tag<= tag-is-conjoin? dispatch-tag? (lambda (tag1 tag2) (any (lambda (component1) - (tag<= component1 tag2)) + (dispatch-tag<= component1 tag2)) (compound-tag-operands tag1)))))) (define (compound-predicate? object) (and (predicate? object) - (compound-tag? (predicate->tag object)))) + (compound-tag? (predicate->dispatch-tag object)))) (add-boot-init! (lambda () @@ -80,10 +80,11 @@ USA. '<= predicate?))) (define (compound-predicate-operator predicate) - (compound-tag-operator (predicate->tag predicate))) + (compound-tag-operator (predicate->dispatch-tag predicate))) (define (compound-predicate-operands predicate) - (map tag->predicate (compound-tag-operands (predicate->tag predicate)))) + (map dispatch-tag->predicate + (compound-tag-operands (predicate->dispatch-tag predicate)))) (define (disjoin . predicates) (disjoin* predicates)) @@ -109,11 +110,11 @@ USA. (define (make-predicate datum-test operator operands) (if (every predicate? operands) - (tag->predicate + (dispatch-tag->predicate ((compound-operator-builder operator) datum-test operator - (map predicate->tag operands))) + (map predicate->dispatch-tag operands))) datum-test)) (define compound-operator-builder) @@ -153,7 +154,7 @@ USA. (memoizer datum-test operator tags))))))) (define-compound-operator 'disjoin - (make-joinish-memoizer tag-is-top?)) + (make-joinish-memoizer dispatch-tag-is-top?)) (define-compound-operator 'conjoin - (make-joinish-memoizer tag-is-bottom?)))) \ No newline at end of file + (make-joinish-memoizer dispatch-tag-is-bottom?)))) \ No newline at end of file diff --git a/src/runtime/gentag.scm b/src/runtime/gentag.scm index 149c23a39..46d41b7d5 100644 --- a/src/runtime/gentag.scm +++ b/src/runtime/gentag.scm @@ -60,25 +60,25 @@ USA. (or (object-non-pointer? elt) (tag-name? elt))) (cdr object))))) -(register-predicate! tag-name? 'tag-name) +(register-predicate! tag-name? 'dispatch-tag-name) (define (set-predicate-tag! predicate tag) (defer-boot-action 'set-predicate-tag! (lambda () (set-predicate-tag! predicate tag)))) -(define (tag? object) +(define (dispatch-tag? object) (and (%record? object) - (metatag? (%record-ref object 0)))) -(register-predicate! tag? 'tag '<= %record?) + (dispatch-metatag? (%record-ref object 0)))) +(register-predicate! dispatch-tag? 'tag '<= %record?) -(define-integrable (%tag-name tag) +(define-integrable (%dispatch-tag-name tag) (%record-ref tag 9)) -(define-integrable (%tag->predicate tag) +(define-integrable (%dispatch-tag->predicate tag) (%record-ref tag 10)) -(define-integrable (%tag-extra tag) +(define-integrable (%dispatch-tag-extra tag) (%record-ref tag 11)) (define-integrable (%tag-supersets tag) @@ -103,19 +103,19 @@ USA. (lambda () (random modulus state)))) -(define (make-metatag name) - (guarantee tag-name? name 'make-metatag) +(define (make-dispatch-metatag name) + (guarantee tag-name? name 'make-dispatch-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) + (set-dispatch-tag<=! metatag metatag-tag) metatag)) -(define (metatag-constructor metatag #!optional caller) - (guarantee metatag? metatag 'metatag-constructor) +(define (dispatch-metatag-constructor metatag #!optional caller) + (guarantee dispatch-metatag? metatag 'dispatch-metatag-constructor) (lambda (name predicate . extra) (guarantee tag-name? name caller) (guarantee unary-procedure? predicate caller) @@ -123,60 +123,60 @@ USA. (error "Can't assign multiple tags to the same predicate:" name)) (%make-tag metatag name predicate (list->vector extra)))) -(define (metatag? object) +(define (dispatch-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? '#())) + (set! metatag-tag (%make-tag #f 'metatag dispatch-metatag? '#())) (%record-set! metatag-tag 0 metatag-tag))) -(define (set-tag<=! t1 t2) +(define (set-dispatch-tag<=! t1 t2) (defer-boot-action 'predicate-relations (lambda () - (set-tag<=! t1 t2)))) + (set-dispatch-tag<=! t1 t2)))) -(define (tag-metatag tag) - (guarantee tag? tag 'tag-metatag) +(define (dispatch-tag-metatag tag) + (guarantee dispatch-tag? tag 'dispatch-tag-metatag) (%record-ref tag 0)) -(define (tag-name tag) - (guarantee tag? tag 'tag-name) - (%tag-name tag)) +(define (dispatch-tag-name tag) + (guarantee dispatch-tag? tag 'dispatch-tag-name) + (%dispatch-tag-name tag)) -(define (tag->predicate tag) - (guarantee tag? tag 'tag->predicate) - (%tag->predicate tag)) +(define (dispatch-tag->predicate tag) + (guarantee dispatch-tag? tag 'dispatch-tag->predicate) + (%dispatch-tag->predicate tag)) -(define (tag-extra tag index) - (guarantee tag? tag 'tag-extra) - (vector-ref (%tag-extra tag) index)) +(define (dispatch-tag-extra tag index) + (guarantee dispatch-tag? tag 'dispatch-tag-extra) + (vector-ref (%dispatch-tag-extra tag) index)) -(define (any-tag-superset procedure tag) - (guarantee tag? tag 'any-tag-superset) +(define (any-dispatch-tag-superset procedure tag) + (guarantee dispatch-tag? tag 'any-dispatch-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) +(define (add-dispatch-tag-superset tag superset) + (guarantee dispatch-tag? tag 'add-dispatch-tag-superset) + (guarantee dispatch-tag? superset 'add-dispatch-tag-superset) (%add-to-weak-set superset (%tag-supersets tag))) (defer-boot-action 'predicate-relations (lambda () - (set-predicate<=! metatag? tag?))) + (set-predicate<=! dispatch-metatag? dispatch-tag?))) -(define-unparser-method tag? +(define-unparser-method dispatch-tag? (simple-unparser-method (lambda (tag) - (if (metatag? tag) 'metatag 'tag)) + (if (dispatch-metatag? tag) 'metatag 'tag)) (lambda (tag) - (list (tag-name tag))))) + (list (dispatch-tag-name tag))))) -(define-pp-describer tag? +(define-pp-describer dispatch-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 + (list (list 'metatag (dispatch-tag-metatag tag)) + (list 'name (dispatch-tag-name tag)) + (list 'predicate (dispatch-tag->predicate tag)) + (cons 'extra (vector->list (%dispatch-tag-extra tag)))))) \ No newline at end of file diff --git a/src/runtime/parametric-predicate.scm b/src/runtime/parametric-predicate.scm index 69e626548..9e6fc918b 100644 --- a/src/runtime/parametric-predicate.scm +++ b/src/runtime/parametric-predicate.scm @@ -29,30 +29,30 @@ USA. (declare (usual-integrations)) -(define parametric-tag-metatag (make-metatag 'parametric-tag)) -(define parametric-tag? (tag->predicate parametric-tag-metatag)) +(define parametric-tag-metatag (make-dispatch-metatag 'parametric-tag)) +(define parametric-tag? (dispatch-tag->predicate parametric-tag-metatag)) (define %make-parametric-tag - (metatag-constructor parametric-tag-metatag 'make-parametric-tag)) + (dispatch-metatag-constructor parametric-tag-metatag 'make-parametric-tag)) (define (make-parametric-tag name predicate template bindings) (%make-parametric-tag name predicate template bindings)) (define-integrable (parametric-tag-template tag) - (tag-extra tag 0)) + (dispatch-tag-extra tag 0)) (define-integrable (parametric-tag-bindings tag) - (tag-extra tag 1)) + (dispatch-tag-extra tag 1)) (define (parametric-predicate? object) (and (predicate? object) - (parametric-tag? (predicate->tag object)))) + (parametric-tag? (predicate->dispatch-tag object)))) (define (parametric-predicate-template predicate) - (parametric-tag-template (predicate->tag predicate))) + (parametric-tag-template (predicate->dispatch-tag predicate))) (define (parametric-predicate-bindings predicate) - (parametric-tag-bindings (predicate->tag predicate))) + (parametric-tag-bindings (predicate->dispatch-tag predicate))) ;;;; Templates @@ -93,17 +93,17 @@ USA. (cons name (map-template-pattern pattern patterned-tags - tag-name + dispatch-tag-name caller)) (apply make-data-test (map-template-pattern pattern patterned-tags - tag->predicate + dispatch-tag->predicate caller)) (get-template) (match-template-pattern pattern patterned-tags - tag? + dispatch-tag? caller)))) tag))) @@ -111,10 +111,10 @@ USA. (let ((instantiator (template-instantiator template)) (pattern (predicate-template-pattern template))) (lambda patterned-predicates - (tag->predicate + (dispatch-tag->predicate (instantiator (map-template-pattern pattern patterned-predicates - predicate->tag + predicate->dispatch-tag caller) caller))))) @@ -131,15 +131,16 @@ USA. (let ((valid? (predicate-template-predicate template)) (convert (if (template-pattern-element-single-valued? elt) - tag->predicate - (lambda (tags) (map tag->predicate tags))))) + dispatch-tag->predicate + (lambda (tags) (map dispatch-tag->predicate tags))))) (lambda (predicate) (guarantee valid? predicate caller) (convert (parameter-binding-value (find (lambda (binding) (eqv? name (parameter-binding-name binding))) - (parametric-tag-bindings (predicate->tag predicate))))))))) + (parametric-tag-bindings + (predicate->dispatch-tag predicate))))))))) ;;;; Template patterns @@ -247,7 +248,7 @@ USA. (add-boot-init! (lambda () - (define-tag<= parametric-tag? parametric-tag? + (define-dispatch-tag<= parametric-tag? parametric-tag? (lambda (tag1 tag2) (and (eqv? (parametric-tag-template tag1) (parametric-tag-template tag2)) @@ -257,9 +258,9 @@ USA. (and (= (length tags1) (length tags2)) (every (case (parameter-binding-polarity bind1) - ((+) tag<=) - ((-) tag>=) - (else tag=)) + ((+) dispatch-tag<=) + ((-) dispatch-tag>=) + (else dispatch-tag=)) tags1 tags2)))) (parametric-tag-bindings tag1) diff --git a/src/runtime/predicate-dispatch.scm b/src/runtime/predicate-dispatch.scm index 8d767dc89..246bc9286 100644 --- a/src/runtime/predicate-dispatch.scm +++ b/src/runtime/predicate-dispatch.scm @@ -252,7 +252,9 @@ USA. (else (delegate operator)))))) (define (cached-most-specific-handler-set default-handler) - (cached-handler-set (most-specific-handler-set default-handler) object->tag)) + (cached-handler-set (most-specific-handler-set default-handler) + object->dispatch-tag)) (define (cached-chaining-handler-set default-handler) - (cached-handler-set (chaining-handler-set default-handler) object->tag)) \ No newline at end of file + (cached-handler-set (chaining-handler-set default-handler) + object->dispatch-tag)) \ No newline at end of file diff --git a/src/runtime/predicate-lattice.scm b/src/runtime/predicate-lattice.scm index 287e7ae2d..c38ee3a27 100644 --- a/src/runtime/predicate-lattice.scm +++ b/src/runtime/predicate-lattice.scm @@ -30,55 +30,55 @@ USA. (declare (usual-integrations)) (define (predicate<= predicate1 predicate2) - (tag<= (predicate->tag predicate1) - (predicate->tag predicate2))) + (dispatch-tag<= (predicate->dispatch-tag predicate1) + (predicate->dispatch-tag predicate2))) (define (predicate>= predicate1 predicate2) (predicate<= predicate2 predicate1)) (define (set-predicate<=! predicate superset) - (set-tag<=! (predicate->tag predicate 'set-predicate<=!) - (predicate->tag superset 'set-predicate<=!))) + (set-dispatch-tag<=! (predicate->dispatch-tag predicate 'set-predicate<=!) + (predicate->dispatch-tag superset 'set-predicate<=!))) -(define (tag= tag1 tag2) - (guarantee tag? tag1 'tag=) - (guarantee tag? tag2 'tag=) +(define (dispatch-tag= tag1 tag2) + (guarantee dispatch-tag? tag1 'dispatch-tag=) + (guarantee dispatch-tag? tag2 'dispatch-tag=) (eq? tag1 tag2)) -(define (tag<= tag1 tag2) - (guarantee tag? tag1 'tag<=) - (guarantee tag? tag2 'tag<=) - (cached-tag<= tag1 tag2)) +(define (dispatch-tag<= tag1 tag2) + (guarantee dispatch-tag? tag1 'dispatch-tag<=) + (guarantee dispatch-tag? tag2 'dispatch-tag<=) + (cached-dispatch-tag<= tag1 tag2)) -(define (tag>= tag1 tag2) - (tag<= tag2 tag1)) +(define (dispatch-tag>= tag1 tag2) + (dispatch-tag<= tag2 tag1)) -(define (cached-tag<= tag1 tag2) - (hash-table-intern! tag<=-cache +(define (cached-dispatch-tag<= tag1 tag2) + (hash-table-intern! dispatch-tag<=-cache (cons tag1 tag2) - (lambda () (uncached-tag<= tag1 tag2)))) + (lambda () (uncached-dispatch-tag<= tag1 tag2)))) -(define (uncached-tag<= tag1 tag2) +(define (uncached-dispatch-tag<= tag1 tag2) (or (eq? tag1 tag2) - (tag-is-bottom? tag1) - (tag-is-top? tag2) - (and (not (tag-is-top? tag1)) - (not (tag-is-bottom? tag2)) + (dispatch-tag-is-bottom? tag1) + (dispatch-tag-is-top? tag2) + (and (not (dispatch-tag-is-top? tag1)) + (not (dispatch-tag-is-bottom? tag2)) (let ((v (find (lambda (v) (and ((vector-ref v 0) tag1) ((vector-ref v 1) tag2))) - tag<=-overrides))) + dispatch-tag<=-overrides))) (if v ((vector-ref v 2) tag1 tag2) - (any-tag-superset (lambda (tag) - (cached-tag<= tag tag2)) - tag1)))))) + (any-dispatch-tag-superset (lambda (tag) + (cached-dispatch-tag<= tag tag2)) + tag1)))))) -(define (define-tag<= test1 test2 handler) - (set! tag<=-overrides +(define (define-dispatch-tag<= test1 test2 handler) + (set! dispatch-tag<=-overrides (cons (vector test1 test2 handler) - tag<=-overrides)) + dispatch-tag<=-overrides)) unspecific) (define (any-object? object) @@ -89,31 +89,34 @@ USA. (declare (ignore object)) #f) -(define (top-tag) the-top-tag) -(define (bottom-tag) the-bottom-tag) +(define (top-dispatch-tag) the-top-dispatch-tag) +(define (bottom-dispatch-tag) the-bottom-dispatch-tag) -(define-integrable (tag-is-top? tag) (eq? the-top-tag tag)) -(define-integrable (tag-is-bottom? tag) (eq? the-bottom-tag tag)) +(define-integrable (dispatch-tag-is-top? tag) + (eq? the-top-dispatch-tag tag)) -(define-deferred the-top-tag +(define-integrable (dispatch-tag-is-bottom? tag) + (eq? the-bottom-dispatch-tag tag)) + +(define-deferred the-top-dispatch-tag (make-compound-tag any-object? 'conjoin '())) -(define-deferred the-bottom-tag +(define-deferred the-bottom-dispatch-tag (make-compound-tag no-object? 'disjoin '())) -(define tag<=-cache) -(define tag<=-overrides) +(define dispatch-tag<=-cache) +(define dispatch-tag<=-overrides) (add-boot-init! (lambda () ;; TODO(cph): should be a weak-key table, but we don't have tables that have ;; weak compound keys. - (set! tag<=-cache (make-equal-hash-table)) - (set! tag<=-overrides '()) - (set! set-tag<=! - (named-lambda (set-tag<=! tag superset) - (if (not (add-tag-superset tag superset)) + (set! dispatch-tag<=-cache (make-equal-hash-table)) + (set! dispatch-tag<=-overrides '()) + (set! set-dispatch-tag<=! + (named-lambda (set-dispatch-tag<=! tag superset) + (if (not (add-dispatch-tag-superset tag superset)) (error "Tag already has this superset:" tag superset)) - (if (tag>= tag superset) + (if (dispatch-tag>= tag superset) (error "Not allowed to create a superset loop:" tag superset)) - (hash-table-clear! tag<=-cache))) + (hash-table-clear! dispatch-tag<=-cache))) (run-deferred-boot-actions 'predicate-relations))) \ No newline at end of file diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm index ba95d6cf5..a97e56bf5 100644 --- a/src/runtime/predicate-metadata.scm +++ b/src/runtime/predicate-metadata.scm @@ -39,9 +39,9 @@ USA. (run-deferred-boot-actions 'set-predicate-tag!)))) (define (predicate-name predicate) - (tag-name (predicate->tag predicate 'predicate-name))) + (dispatch-tag-name (predicate->dispatch-tag predicate 'predicate-name))) -(define (predicate->tag predicate #!optional caller) +(define (predicate->dispatch-tag predicate #!optional caller) (let ((tag (get-predicate-tag predicate #f))) (if (not tag) (error:not-a predicate? predicate caller)) @@ -52,16 +52,18 @@ USA. (add-boot-init! (lambda () (set! simple-tag-metatag - (make-metatag 'simple-tag)) + (make-dispatch-metatag 'simple-tag)) (set! %make-simple-tag - (metatag-constructor simple-tag-metatag 'register-predicate!)) - (run-deferred-boot-actions 'make-metatag) + (dispatch-metatag-constructor simple-tag-metatag 'register-predicate!)) + (run-deferred-boot-actions 'make-dispatch-metatag) (set! register-predicate! (named-lambda (register-predicate! predicate name . keylist) (guarantee keyword-list? keylist 'register-predicate!) (let ((tag (%make-simple-tag name predicate #f))) (for-each (lambda (superset) - (set-tag<=! tag (predicate->tag superset))) + (set-dispatch-tag<=! + tag + (predicate->dispatch-tag superset))) (get-keyword-values keylist '<=)) tag))) unspecific)) diff --git a/src/runtime/predicate-tagging.scm b/src/runtime/predicate-tagging.scm index 7af96ca48..eec437270 100644 --- a/src/runtime/predicate-tagging.scm +++ b/src/runtime/predicate-tagging.scm @@ -30,9 +30,9 @@ USA. (declare (usual-integrations)) (define (object->predicate object) - (tag->predicate (object->tag object))) + (dispatch-tag->predicate (object->dispatch-tag object))) -(define (object->tag object) +(define (object->dispatch-tag object) (let ((code (object-type object))) (or (vector-ref primitive-tags code) ((vector-ref primitive-tag-methods code) object) @@ -44,14 +44,14 @@ USA. object)) (define (predicate-tagger predicate) - (%tag-tagger (predicate->tag predicate 'predicate-tagger) predicate)) + (%tag-tagger (predicate->dispatch-tag predicate 'predicate-tagger) predicate)) -(define (tag-tagger tag) - (%tag-tagger tag (tag->predicate tag))) +(define (dispatch-tag-tagger tag) + (%tag-tagger tag (dispatch-tag->predicate tag))) (define (%tag-tagger tag predicate) (lambda (datum #!optional tagger-name) - (if (tag<= (object->tag datum) tag) + (if (dispatch-tag<= (object->dispatch-tag datum) tag) datum (begin (guarantee predicate datum tagger-name) @@ -63,7 +63,7 @@ USA. (lambda () (set! primitive-tags (make-vector (microcode-type/code-limit) - (top-tag))) + (top-dispatch-tag))) (set! primitive-tag-methods (make-vector (microcode-type/code-limit) #f)) unspecific)) @@ -73,7 +73,7 @@ USA. (define (define-primitive-predicate type-name predicate) (vector-set! primitive-tags (microcode-type/name->code type-name) - (predicate->tag predicate))) + (predicate->dispatch-tag predicate))) (define-primitive-predicate 'bignum exact-integer?) (define-primitive-predicate 'bytevector bytevector?) @@ -113,7 +113,7 @@ USA. (define-primitive-predicate-method 'constant (let* ((constant-tags (list->vector - (map predicate->tag + (map predicate->dispatch-tag (list boolean? undefined-value? undefined-value? @@ -129,21 +129,21 @@ USA. (let ((datum (object-datum object))) (if (and (fix:fixnum? datum) (fix:< datum n-tags)) (vector-ref constant-tags datum) - (top-tag)))))) + (top-dispatch-tag)))))) (define-primitive-predicate-method 'entity - (let ((apply-hook-tag (predicate->tag apply-hook?)) - (entity-tag (predicate->tag entity?))) + (let ((apply-hook-tag (predicate->dispatch-tag apply-hook?)) + (entity-tag (predicate->dispatch-tag entity?))) (lambda (object) (if (%entity-is-apply-hook? object) apply-hook-tag entity-tag)))) (define-primitive-predicate-method 'compiled-entry - (let ((procedure-tag (predicate->tag compiled-procedure?)) - (return-tag (predicate->tag compiled-return-address?)) - (expression-tag (predicate->tag compiled-expression?)) - (default-tag (predicate->tag compiled-code-address?))) + (let ((procedure-tag (predicate->dispatch-tag compiled-procedure?)) + (return-tag (predicate->dispatch-tag compiled-return-address?)) + (expression-tag (predicate->dispatch-tag compiled-expression?)) + (default-tag (predicate->dispatch-tag compiled-code-address?))) (lambda (entry) (case (system-hunk3-cxr0 ((ucode-primitive compiled-entry-kind 1) entry)) @@ -153,8 +153,8 @@ USA. (else default-tag))))) (define-primitive-predicate-method 'record - (let ((default-tag (predicate->tag %record?))) + (let ((default-tag (predicate->dispatch-tag %record?))) (lambda (object) - (if (tag? (%record-ref object 0)) + (if (dispatch-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 affa2c767..eff9a8128 100644 --- a/src/runtime/record.scm +++ b/src/runtime/record.scm @@ -107,10 +107,10 @@ USA. (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! record-tag-metatag (make-dispatch-metatag 'record-tag)) + (set! record-tag? (dispatch-tag->predicate record-tag-metatag)) (set! %make-record-tag - (metatag-constructor record-tag-metatag 'make-record-type)) + (dispatch-metatag-constructor record-tag-metatag 'make-record-type)) (let* ((field-names '#(dispatch-tag name field-names default-inits tag)) (type @@ -126,13 +126,13 @@ USA. (define (record-tag->type-descriptor tag) (guarantee record-tag? tag 'record-tag->type-descriptor) - (tag-extra tag 0)) + (dispatch-tag-extra tag 0)) (define (record-type? object) (%tagged-record? record-type-type-tag object)) (define-integrable (%record-type-descriptor record) - (tag-extra (%record-tag record) 0)) + (dispatch-tag-extra (%record-tag record) 0)) (define-integrable (%record-type-dispatch-tag record-type) (%record-ref record-type 1)) @@ -147,7 +147,7 @@ USA. (%record-ref record-type 4)) (define-integrable (%record-type-predicate record-type) - (tag->predicate (%record-type-dispatch-tag record-type))) + (dispatch-tag->predicate (%record-type-dispatch-tag record-type))) (define-integrable (%record-type-n-fields record-type) (vector-length (%record-type-field-names record-type))) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index af01c32df..1be5fcac8 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1842,7 +1842,7 @@ USA. (files "predicate-metadata") (parent (runtime)) (export () - predicate->tag + predicate->dispatch-tag predicate-name)) (define-package (runtime predicate-lattice) @@ -1850,19 +1850,19 @@ USA. (parent (runtime)) (export () any-object? + bottom-dispatch-tag + dispatch-tag-is-bottom? + dispatch-tag-is-top? + dispatch-tag<= + dispatch-tag= + dispatch-tag>= + no-object? predicate<= predicate>= - no-object? - set-predicate<=!) + set-predicate<=! + top-dispatch-tag) (export (runtime) - bottom-tag - define-tag<= - tag-is-bottom? - tag-is-top? - tag<= - tag= - tag>= - top-tag)) + define-dispatch-tag<=)) (define-package (runtime compound-predicate) (files "compound-predicate") @@ -1903,12 +1903,11 @@ USA. (files "predicate-tagging") (parent (runtime)) (export () + dispatch-tag-tagger object->datum + object->dispatch-tag object->predicate - predicate-tagger) - (export (runtime) - object->tag - tag-tagger)) + predicate-tagger)) (define-package (runtime predicate-dispatch) (files "predicate-dispatch") @@ -5101,19 +5100,18 @@ USA. (files "gentag" "gencache") (parent (runtime)) (export () - make-metatag - metatag-constructor - metatag?) - (export (runtime) - set-tag<=! - tag->predicate - tag-extra - tag-metatag - tag-name - tag?) + dispatch-metatag-constructor + dispatch-metatag? + dispatch-tag->predicate + dispatch-tag-extra + dispatch-tag-metatag + dispatch-tag-name + dispatch-tag? + make-dispatch-metatag + set-dispatch-tag<=!) (export (runtime predicate-lattice) - add-tag-superset - any-tag-superset) + add-dispatch-tag-superset + any-dispatch-tag-superset) (export (runtime predicate-metadata) set-predicate-tag!)) diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm index 3e429782b..a9d0cdd7a 100644 --- a/src/runtime/unpars.scm +++ b/src/runtime/unpars.scm @@ -891,8 +891,8 @@ USA. (*unparse-with-brackets 'tagged-object object context (lambda (context*) (*unparse-object (let ((tag (%tagged-object-tag object))) - (if (tag? tag) - (tag-name tag) + (if (dispatch-tag? tag) + (dispatch-tag-name tag) tag)) context*) (*unparse-string " " context*) diff --git a/src/sos/class.scm b/src/sos/class.scm index f4af37585..d734af1cd 100644 --- a/src/sos/class.scm +++ b/src/sos/class.scm @@ -74,13 +74,13 @@ USA. class)) (define class-metatag - (make-metatag 'class-tag)) + (make-dispatch-metatag 'class-tag)) (define class-tag? - (tag->predicate class-metatag)) + (dispatch-tag->predicate class-metatag)) (define make-class-tag - (metatag-constructor class-metatag 'make-class)) + (dispatch-metatag-constructor class-metatag 'make-class)) (define (make-trivial-subclass superclass . superclasses) (make-class (class-name superclass) (cons superclass superclasses) '())) @@ -338,7 +338,7 @@ USA. (define-primitive-class ) (define (object-class object) - (dispatch-tag->class (object->tag object))) + (dispatch-tag->class (object->dispatch-tag object))) (define (record-type-class type) (dispatch-tag->class (record-type-dispatch-tag type))) @@ -347,7 +347,7 @@ USA. (record-type-class (record-type-descriptor record))) (define (dispatch-tag->class tag) - (cond ((class-tag? tag) (tag-extra tag 0)) + (cond ((class-tag? tag) (dispatch-tag-extra tag 0)) ((hash-table/get built-in-class-table tag #f)) ((record-tag? tag) (let ((class @@ -383,7 +383,7 @@ USA. (let ((assign-type (lambda (predicate class) (hash-table/put! built-in-class-table - (predicate->tag predicate) + (predicate->dispatch-tag predicate) class)))) (assign-type boolean? ) (assign-type char? ) diff --git a/src/sos/generic.scm b/src/sos/generic.scm index 60099c149..2d0a10faa 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 tag? tag 'MAKE-GENERIC-PROCEDURE)) + (if tag (guarantee dispatch-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 (predicate->tag generic-procedure?) + (make-generic-record (predicate->dispatch-tag generic-procedure?) (procedure-arity-min arity) (procedure-arity-max arity) generator @@ -197,7 +197,7 @@ USA. (wna args)) (loop (cdr args*) (fix:- n 1) - (cons (object->tag (car args*)) tags))))))) + (cons (object->dispatch-tag (car args*)) tags))))))) (wna (lambda (args) (error:wrong-number-of-arguments generic @@ -209,7 +209,7 @@ USA. (let ((record (guarantee-generic-procedure procedure 'GENERIC-PROCEDURE-APPLICABLE?)) - (tags (map object->tag arguments))) + (tags (map object->dispatch-tag arguments))) (let ((generator (generic-record/generator record)) (arity-min (generic-record/arity-min record)) (arity-max (generic-record/arity-max record)) @@ -226,7 +226,7 @@ USA. (lambda (a1) (let ((procedure (probe-cache-1 (generic-record/cache record) - (object->tag a1)))) + (object->dispatch-tag a1)))) (if procedure (procedure a1) (compute-method-and-store record (list a1)))))) @@ -235,8 +235,8 @@ USA. (lambda (a1 a2) (let ((procedure (probe-cache-2 (generic-record/cache record) - (object->tag a1) - (object->tag a2)))) + (object->dispatch-tag a1) + (object->dispatch-tag a2)))) (if procedure (procedure a1 a2) (compute-method-and-store record (list a1 a2)))))) @@ -245,9 +245,9 @@ USA. (lambda (a1 a2 a3) (let ((procedure (probe-cache-3 (generic-record/cache record) - (object->tag a1) - (object->tag a2) - (object->tag a3)))) + (object->dispatch-tag a1) + (object->dispatch-tag a2) + (object->dispatch-tag a3)))) (if procedure (procedure a1 a2 a3) (compute-method-and-store record (list a1 a2 a3)))))) @@ -256,10 +256,10 @@ USA. (lambda (a1 a2 a3 a4) (let ((procedure (probe-cache-4 (generic-record/cache record) - (object->tag a1) - (object->tag a2) - (object->tag a3) - (object->tag a4)))) + (object->dispatch-tag a1) + (object->dispatch-tag a2) + (object->dispatch-tag a3) + (object->dispatch-tag a4)))) (if procedure (procedure a1 a2 a3 a4) (compute-method-and-store record (list a1 a2 a3 a4)))))) @@ -271,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 (object->tag (car args))))) + (set-cdr! p (list (object->dispatch-tag (car args))))) (cdr p)))) (let ((procedure (let ((generator (generic-record/generator record)) diff --git a/src/sos/tvector.scm b/src/sos/tvector.scm index e66cdd100..2b38f5be4 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 tag? tag 'MAKE-TAGGED-VECTOR) + (guarantee dispatch-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 tag? tag 'MAKE-TAGGED-VECTOR) + (guarantee dispatch-tag? tag 'MAKE-TAGGED-VECTOR) (apply %record tag elements)) (define (tagged-vector? object) (and (%record? object) - (tag? (%record-ref object 0)))) + (dispatch-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 tag? tag 'SET-TAGGED-VECTOR-TAG!) + (guarantee dispatch-tag? tag 'SET-TAGGED-VECTOR-TAG!) (%record-set! vector 0 tag)) (define (tagged-vector-length vector) diff --git a/tests/Clean.sh b/tests/Clean.sh index 3d290a22d..6d483fd1a 100755 --- a/tests/Clean.sh +++ b/tests/Clean.sh @@ -10,6 +10,6 @@ COMMAND=${1} TOPDIR=../src ../src/etc/Clean.sh ${COMMAND} -for SUBDIR in ffi microcode runtime star-parser xml; do +for SUBDIR in ffi microcode runtime sos star-parser xml; do ( cd $SUBDIR; TOPDIR=../../src ../../src/etc/Clean.sh ${COMMAND} ) done diff --git a/tests/runtime/test-parametric-predicate.scm b/tests/runtime/test-parametric-predicate.scm index 873dce8c0..092d056ad 100644 --- a/tests/runtime/test-parametric-predicate.scm +++ b/tests/runtime/test-parametric-predicate.scm @@ -238,11 +238,11 @@ USA. (define (test-predicate-operations predicate name) (assert-true (predicate? predicate)) - (let ((tag (predicate->tag predicate))) - (assert-true (tag? tag)) - (assert-eqv (tag->predicate tag) predicate) + (let ((tag (predicate->dispatch-tag predicate))) + (assert-true (dispatch-tag? tag)) + (assert-eqv (dispatch-tag->predicate tag) predicate) (assert-equal (predicate-name predicate) name) - (assert-equal (tag-name tag) name))) + (assert-equal (dispatch-tag-name tag) name))) (define (test-parametric-predicate-operations predicate template parameters) (assert-true (parametric-predicate? predicate)) diff --git a/tests/runtime/test-predicate-metadata.scm b/tests/runtime/test-predicate-metadata.scm index 8754007f4..f4b8ef4be 100644 --- a/tests/runtime/test-predicate-metadata.scm +++ b/tests/runtime/test-predicate-metadata.scm @@ -32,7 +32,7 @@ USA. (lambda () (let ((np (lambda (object) object #f))) (assert-false (predicate? np)) - (assert-type-error (lambda () (predicate->tag np))) + (assert-type-error (lambda () (predicate->dispatch-tag np))) (assert-type-error (lambda () (predicate-name np)))))) (define-test 'simple-predicate @@ -43,11 +43,11 @@ USA. (define (test-predicate-operations predicate name) (assert-true (predicate? predicate)) - (let ((tag (predicate->tag predicate))) - (assert-true (tag? tag)) - (assert-eqv (tag->predicate tag) predicate) + (let ((tag (predicate->dispatch-tag predicate))) + (assert-true (dispatch-tag? tag)) + (assert-eqv (dispatch-tag->predicate tag) predicate) (assert-equal (predicate-name predicate) name) - (assert-equal (tag-name tag) name))) + (assert-equal (dispatch-tag-name tag) name))) (define-test 'simple-predicate-tagging (lambda () diff --git a/tests/sos/test-genmult.scm b/tests/sos/test-genmult.scm index 2e3d7f229..8cc823da7 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 (predicate->tag boolean?))) + (if (equal? tags (list (predicate->dispatch-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 (predicate->tag fix:fixnum?))) + (if (equal? tags (list (predicate->dispatch-tag fix:fixnum?))) (lambda (x) (cons 'fixnum x)) #f)) (add-generic-procedure-generator generic fixnum-generator)