(declare (usual-integrations))
\f
-(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))
;;; Functional Programming. Parts of this code are based on the
;;; September 16, 1992 PCL implementation.
-(declare (usual-integrations)
- (integrate-external "gentag"))
+(declare (usual-integrations))
\f
+(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)
(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)))))))
(declare (usual-integrations))
\f
-(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.
;;
;; 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))))
\f
-;;;; 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))))
\f
-;;;; 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
;;;; Compiled Code Information: Utilities
;;; package: (runtime compiler-info)
-(declare (usual-integrations))
-(declare (integrate-external "infstr" "char"))
+(declare (usual-integrations)
+ (integrate-external "infstr"))
\f
(define (compiled-code-block/dbg-info block demand-load?)
(let ((wrapper (compiled-code-block/debugging-wrapper block)))
(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.
(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!)
(declare (usual-integrations))
\f
-(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))
(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)
(declare (usual-integrations))
\f
(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)))
(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)))))
-\f
-(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
(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)))
\f
(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!
(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
(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
(%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!))
-\f
(define (make-record-type type-name field-names
#!optional
default-inits unparser-method entity-unparser-method)
(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)))
(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)
\f
+(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))
(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)))
(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
(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?))
\f
;;;; 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
\f
(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)))
(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)))
(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))
(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")
;;;; Printing
(define-unparser-method %record?
- (standard-unparser-method 'record #f))
+ (standard-unparser-method '%record #f))
(define-unparser-method record?
(standard-unparser-method
\f
;;;; 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)
-\f
(define rtd:structure-type)
(define make-define-structure-type)
(define structure-type?)
(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)
(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")
(export (runtime)
bottom-tag
define-tag<=
- set-tag<=!
tag-is-bottom?
tag-is-top?
tag<=
(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
(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)
(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")
|#
-(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
(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))
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 <object>
- (let ((class (%make-class '<OBJECT> '() '())))
+ (let ((class (%make-class '<object> '() '())))
(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 '<object>
+ (lambda (object)
+ (declare (ignore object))
+ #t)
+ class))
class))
\f
(define (class-name class)
(define-primitive-class <boolean> <object>)
(define-primitive-class <char> <object>)
(define-primitive-class <pair> <object>)
-(define-primitive-class <%record> <object>)
-(define-primitive-class <record> <%record>)
-(define-primitive-class <dispatch-tag> <%record>)
+(define-primitive-class <record> <object>)
(define-primitive-class <string> <object>)
(define-primitive-class <symbol> <object>)
(define-primitive-class <vector> <object>)
(define-primitive-class <entity> <procedure>)
\f
(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)))
(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 <object>))))
+ (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 <object>)))
(define (make-record-type-class type)
(let ((class
;; classes anyway, which have strong references to dispatch tags,
;; so they need to be changed to hold weak references.
(make-strong-eq-hash-table))
-\f
+
(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 <boolean>)
- (assign-type 'CHARACTER <char>)
- (assign-type 'PAIR <pair>)
- (assign-type 'RECORD <%record>)
- (assign-type 'DISPATCH-TAG <dispatch-tag>)
- (assign-type 'STRING <string>)
- (assign-type 'INTERNED-SYMBOL <symbol>)
- (assign-type 'UNINTERNED-SYMBOL <symbol>)
- (assign-type 'VECTOR <vector>)
-
- (assign-type 'COMPILED-PROCEDURE <procedure>)
- (assign-type 'EXTENDED-PROCEDURE <procedure>)
- (assign-type 'PRIMITIVE <procedure>)
- (assign-type 'PROCEDURE <procedure>)
- (assign-type 'ENTITY <entity>)
-
- (if (fix:= (object-type 1) (object-type -1))
- (assign-type 'FIXNUM <fixnum>)
- (begin
- (assign-type 'POSITIVE-FIXNUM <fixnum>)
- (assign-type 'NEGATIVE-FIXNUM <fixnum>)))
- (assign-type 'BIGNUM <bignum>)
- (assign-type 'RATNUM <ratnum>)
- (assign-type 'FLONUM <flonum>)
- (assign-type 'FLONUM-VECTOR <flonum-vector>)
- (assign-type 'RECNUM <recnum>))
-
-(hash-table/put! built-in-class-table
- standard-generic-procedure-tag
- <generic-procedure>)
+ (assign-type boolean? <boolean>)
+ (assign-type char? <char>)
+ (assign-type entity? <entity>)
+ (assign-type exact-integer? <exact-integer>)
+ (assign-type exact-rational? <exact-rational>)
+ (assign-type flo:flonum? <inexact-rational>)
+ (assign-type generic-procedure? <generic-procedure>)
+ (assign-type number? <number>)
+ (assign-type pair? <pair>)
+ (assign-type procedure? <procedure>)
+ (assign-type string? <string>)
+ (assign-type symbol? <symbol>)
+ (assign-type vector? <vector>))
(define <class> (object-class <object>))
\ No newline at end of file
(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
(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)
(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
(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))
\f
(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))))))
(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))
(fill-cache (generic-record/cache record) tags procedure))))
(apply procedure args))))
\f
-(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))
(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))
(install <method> 'METHOD)
(install <chained-method> 'CHAINED-METHOD)
(install <computed-method> 'COMPUTED-METHOD)
- (install <computed-emp> 'COMPUTED-EMP)
- (install <%record> '%RECORD))
+ (install <computed-emp> 'COMPUTED-EMP))
(add-method write-instance
(make-method (list <record>)
(write-instance-helper (record-type-name (record-type-descriptor record))
record port #f))))
-(add-method write-instance
- (make-method (list <dispatch-tag>)
- (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)
(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
(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
(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)))))))
\f
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)
(files "class")
(parent (sos))
(export ()
- <%record>
<bignum>
<boolean>
<char>
<class>
<complex>
- <dispatch-tag>
<entity>
<exact-complex>
<exact-integer>
record-class
record-type-class
subclass?)
+ (export (sos)
+ class-tag?)
(import (runtime microcode-tables)
microcode-type/code->name
microcode-type/name->code))
;;; 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)
(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)
;; 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)
projects / mit-scheme.git / commitdiff