It's slated to be entirely replaced by predicate dispatchers.
("gcstat" (runtime gc-statistics))
("gdatab" (runtime global-database))
("gdbm" (runtime gdbm))
- ("gencache" (runtime generic-procedure))
- ("geneqht" (runtime generic-procedure))
- ("generic" (runtime generic-procedure))
+ ("gencache" (runtime tagged-dispatch))
("genio" (runtime generic-i/o-port))
- ("genmult" (runtime generic-procedure multiplexer))
("gensym" (runtime gensym))
- ("gentag" (runtime generic-procedure))
+ ("gentag" (runtime tagged-dispatch))
("global" (runtime miscellaneous-global))
("graphics" (runtime graphics))
("hash" (runtime hash))
("random" (runtime random-number))
("rbtree" (runtime rb-tree))
("record" (runtime record))
- ("recslot" (runtime record-slot-access))
("regexp" (runtime regular-expression))
("regsexp" (runtime regular-sexpression))
("rep" (runtime rep))
("thread-queue" (runtime thread-queue))
("tscript" (runtime transcript))
("ttyio" (runtime console-i/o-port))
- ("tvector" (runtime tagged-vector))
("udata" (runtime microcode-data))
("uenvir" (runtime environment))
("uerror" (runtime microcode-errors))
|#
-;;;; Tags for Generic Procedure Dispatch
+;;;; Tags for efficient dispatching
;;; From "Efficient Method Dispatch in PCL", Gregor Kiczales and Luis
;;; Rodriguez, Proceedings of the 1990 ACM Conference on Lisp and
;; primary cache locations from multiple tags.
4)
-(define get-dispatch-tag-cache-number)
-
-(define (initialize-tag-constants!)
- (set! get-dispatch-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))
- (state (make-random-state)))
- (lambda ()
- (random modulus state))))
- unspecific)
\ No newline at end of file
+(define-deferred get-dispatch-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))
+ (state (make-random-state)))
+ (lambda ()
+ (random modulus state))))
+\f
+;;;; Object Tags
+
+;;; We assume that most new data types will be constructed from tagged
+;;; vectors, 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)))
+ (if (and (%record? object)
+ (%record? (%record-ref object 0))
+ (eq? dispatch-tag-marker (%record-ref (%record-ref object 0) 0)))
+ (%record-ref object 0)
+ (if (vector-ref microcode-type-tag-table (object-type object))
+ (vector-ref microcode-type-tag-table (object-type object))
+ ((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))
+\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
("uproc" . (RUNTIME PROCEDURE))
("fixart" . (RUNTIME FIXNUM-ARITHMETIC))
("random" . (RUNTIME RANDOM-NUMBER))
- ("gentag" . (RUNTIME GENERIC-PROCEDURE))
+ ("gentag" . (runtime tagged-dispatch))
("thread-low" . (RUNTIME THREAD))
("poplat" . (RUNTIME POPULATION))
("record" . (RUNTIME RECORD))))
(package-initialize '(RUNTIME GC-DAEMONS) #f #t)
(package-initialize '(RUNTIME GARBAGE-COLLECTOR) #f #t)
(package-initialize '(RUNTIME RANDOM-NUMBER) #f #t)
- (package-initialize '(RUNTIME GENERIC-PROCEDURE) 'INITIALIZE-TAG-CONSTANTS!
- #t)
+ (package-initialize '(runtime tagged-dispatch) #f #t)
(package-initialize '(RUNTIME POPULATION) #f #t)
(package-initialize '(RUNTIME RECORD) 'INITIALIZE-RECORD-TYPE-TYPE! #t)
(RUNTIME SCODE-WALKER)
(RUNTIME CONTINUATION-PARSER)
(RUNTIME PROGRAM-COPIER)
- ;; Generic Procedures
- ((RUNTIME GENERIC-PROCEDURE EQHT) INITIALIZE-ADDRESS-HASHING!)
- ((RUNTIME GENERIC-PROCEDURE) INITIALIZE-GENERIC-PROCEDURES!)
- ((RUNTIME GENERIC-PROCEDURE MULTIPLEXER) INITIALIZE-MULTIPLEXER!)
- ((RUNTIME TAGGED-VECTOR) INITIALIZE-TAGGED-VECTOR!)
- ((RUNTIME RECORD-SLOT-ACCESS) INITIALIZE-RECORD-SLOT-ACCESS!)
+ ;; 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!)
;; Condition System
(RUNTIME ERROR-HANDLER)
(RUNTIME MICROCODE-ERRORS)
- ((RUNTIME GENERIC-PROCEDURE) INITIALIZE-CONDITIONS!)
- ((RUNTIME GENERIC-PROCEDURE MULTIPLEXER) INITIALIZE-CONDITIONS!)
- ((RUNTIME RECORD-SLOT-ACCESS) INITIALIZE-CONDITIONS!)
((RUNTIME STREAM) INITIALIZE-CONDITIONS!)
((RUNTIME REGULAR-SEXPRESSION) INITIALIZE-CONDITIONS!)
;; System dependent stuff
(register-predicate! compiled-procedure? 'compiled-procedure '<= procedure?)
(register-predicate! entity? 'entity '<= procedure?)
(register-predicate! record-entity? 'record-entity '<= entity?)
- (register-predicate! generic-procedure? 'generic-procedure '<= procedure?)
(register-predicate! memoizer? 'memoizer '<= apply-hook?)
(register-predicate! primitive-procedure? 'primitive-procedure
'<= procedure?)
(primitive-object-set-type 2)
(vector-cons 2))
-(define-integrable (%make-record tag length)
- (let ((record ((ucode-primitive object-set-type)
- (ucode-type record) (vector-cons length #f))))
+(define (%make-record tag length #!optional init-value)
+ (let ((record
+ ((ucode-primitive object-set-type)
+ (ucode-type record)
+ (vector-cons length
+ (if (default-object? init-value)
+ #f
+ init-value)))))
(%record-set! record 0 tag)
record))
(define-integrable (%record-type-length record-type)
(fix:+ 1 (%record-type-n-fields record-type)))
+(define-integrable (%record-type-field-name record-type index)
+ (vector-ref (%record-type-field-names record-type)
+ (fix:- index 1)))
+\f
(define (record-type-dispatch-tag record-type)
(guarantee-record-type record-type 'RECORD-TYPE-DISPATCH-TAG)
(%record-type-dispatch-tag record-type))
;; 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))))
-\f
+
(define (record-type-default-inits record-type)
(guarantee-record-type record-type 'RECORD-TYPE-DEFAULT-INITS)
(vector->list (%record-type-default-inits record-type)))
(define-integrable (check-list-untagged structure type)
(if (not (eq? (list?->length structure) (structure-type/length type)))
- (error:wrong-type-argument structure type #f)))
\ No newline at end of file
+ (error:wrong-type-argument structure type #f)))
+\f
+;;;; Conditions
+
+(define condition-type:slot-error)
+(define condition-type:uninitialized-slot)
+(define condition-type:no-such-slot)
+(define error:uninitialized-slot)
+(define error:no-such-slot)
+
+(define (initialize-conditions!)
+ (set! condition-type:slot-error
+ (make-condition-type 'SLOT-ERROR condition-type:cell-error
+ '()
+ (lambda (condition port)
+ (write-string "Anonymous error for slot " port)
+ (write (access-condition condition 'LOCATION) port)
+ (write-string "." port))))
+ (set! condition-type:uninitialized-slot
+ (make-condition-type 'UNINITIALIZED-SLOT condition-type:slot-error
+ '(RECORD)
+ (lambda (condition port)
+ (write-string "Attempt to reference slot " port)
+ (write (access-condition condition 'LOCATION) port)
+ (write-string " in record " port)
+ (write (access-condition condition 'RECORD) port)
+ (write-string " failed because the slot is not initialized."
+ port))))
+ (set! condition-type:no-such-slot
+ (make-condition-type 'NO-SUCH-SLOT condition-type:slot-error
+ '(RECORD-TYPE)
+ (lambda (condition port)
+ (write-string "No slot named " port)
+ (write (access-condition condition 'LOCATION) port)
+ (write-string " in records of type " port)
+ (write (access-condition condition 'RECORD-TYPE) port)
+ (write-string "." port))))
+ (set! error:uninitialized-slot
+ (let ((signal
+ (condition-signaller condition-type:uninitialized-slot
+ '(RECORD LOCATION)
+ standard-error-handler)))
+ (lambda (record index)
+ (let* ((location (%record-field-name record index))
+ (ls (write-to-string location)))
+ (call-with-current-continuation
+ (lambda (k)
+ (store-value-restart ls
+ (lambda (value)
+ (%record-set! record index value)
+ (k value))
+ (lambda ()
+ (use-value-restart
+ (string-append
+ "value to use instead of the contents of slot "
+ ls)
+ k
+ (lambda () (signal record location)))))))))))
+ (set! error:no-such-slot
+ (let ((signal
+ (condition-signaller condition-type:no-such-slot
+ '(RECORD-TYPE LOCATION)
+ standard-error-handler)))
+ (lambda (record-type name)
+ (call-with-current-continuation
+ (lambda (k)
+ (use-value-restart
+ (string-append "slot name to use instead of "
+ (write-to-string name))
+ k
+ (lambda () (signal record-type name))))))))
+ unspecific)
+\f
+(define (%record-field-name record index)
+ (or (and (fix:> index 0)
+ (record? record)
+ (let ((names
+ (%record-type-field-names (%record-type-descriptor record))))
+ (and (fix:<= index (vector-length names))
+ (vector-ref names (fix:- index 1)))))
+ index))
+
+(define (record-type-field-name record-type index)
+ (guarantee record-type? record-type 'record-type-field-name)
+ (%record-type-field-name record-type index))
+
+(define (store-value-restart location k thunk)
+ (let ((location (write-to-string location)))
+ (with-restart 'store-value
+ (string-append "Initialize slot " location " to a given value.")
+ k
+ (string->interactor (string-append "Set " location " to"))
+ thunk)))
+
+(define (use-value-restart noun-phrase k thunk)
+ (with-restart 'use-value
+ (string-append "Specify a " noun-phrase ".")
+ k
+ (string->interactor (string-titlecase noun-phrase))
+ thunk))
+
+(define ((string->interactor string))
+ (values (prompt-for-evaluated-expression string)))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Record Slot Access
-
-(declare (usual-integrations))
-\f
-(define (%record-accessor-generator name)
- (lambda (generic tags)
- generic
- (let ((index (%record-slot-index (%record (car tags)) name)))
- (and index
- (%record-accessor index)))))
-
-(define (%record-modifier-generator name)
- (lambda (generic tags)
- generic
- (let ((index (%record-slot-index (%record (car tags)) name)))
- (and index
- (%record-modifier index)))))
-
-(define (%record-initpred-generator name)
- (lambda (generic tags)
- generic
- (let ((index (%record-slot-index (%record (car tags)) name)))
- (and index
- (%record-initpred index)))))
-
-(define-syntax generate-index-cases
- (sc-macro-transformer
- (lambda (form environment)
- (let ((index (close-syntax (cadr form) environment))
- (limit (caddr form))
- (expand-case (close-syntax (cadddr form) environment)))
- `(CASE ,index
- ,@(let loop ((i 1))
- (if (= i limit)
- `((ELSE (,expand-case ,index)))
- `(((,i) (,expand-case ,i)) ,@(loop (+ i 1))))))))))
-
-(define (%record-accessor index)
- (generate-index-cases index 16
- (lambda (index)
- (declare (integrate index)
- (ignore-reference-traps (set record-slot-uninitialized)))
- (lambda (record)
- (if (eq? record-slot-uninitialized (%record-ref record index))
- (error:uninitialized-slot record index)
- (%record-ref record index))))))
-
-(define (%record-modifier index)
- (generate-index-cases index 16
- (lambda (index)
- (declare (integrate index))
- (lambda (record value) (%record-set! record index value)))))
-
-(define (%record-initpred index)
- (generate-index-cases index 16
- (lambda (index)
- (declare (integrate index)
- (ignore-reference-traps (set record-slot-uninitialized)))
- (lambda (record)
- (not (eq? record-slot-uninitialized (%record-ref record index)))))))
-
-(define (%record-slot-name record index)
- (if (not (and (exact-integer? index) (positive? index)))
- (error:wrong-type-argument index "record index" '%RECORD-SLOT-NAME))
- (let ((names
- (call-with-current-continuation
- (lambda (k)
- (bind-condition-handler (list condition-type:no-applicable-methods)
- (lambda (condition) condition (k 'UNKNOWN))
- (lambda ()
- (%record-slot-names record))))))
- (index (- index 1)))
- (and (list? names)
- (< index (length names))
- (list-ref names index))))
-\f
-(define %record-slot-index)
-(define %record-slot-names)
-
-(define (initialize-record-slot-access!)
- (set! %record-slot-index (make-generic-procedure 2 '%RECORD-SLOT-INDEX))
- (add-generic-procedure-generator %record-slot-index
- (lambda (generic tags)
- generic
- (and (record-type? (dispatch-tag-contents (car tags)))
- (lambda (record name)
- (record-type-field-index (record-type-descriptor record)
- name
- #f)))))
- (set! %record-slot-names (make-generic-procedure 1 '%RECORD-SLOT-NAMES))
- (add-generic-procedure-generator %record-slot-names
- (lambda (generic tags)
- generic
- (and (record-type? (dispatch-tag-contents (car tags)))
- (lambda (record)
- (record-type-field-names (record-type-descriptor record)))))))
-
-(define (store-value-restart location k thunk)
- (let ((location (write-to-string location)))
- (with-restart 'STORE-VALUE
- (string-append "Initialize slot " location " to a given value.")
- k
- (string->interactor (string-append "Set " location " to"))
- thunk)))
-
-(define (use-value-restart noun-phrase k thunk)
- (with-restart 'USE-VALUE
- (string-append "Specify a " noun-phrase ".")
- k
- (string->interactor (string-titlecase noun-phrase))
- thunk))
-
-(define ((string->interactor string))
- (values (prompt-for-evaluated-expression string)))
-\f
-(define condition-type:slot-error)
-(define condition-type:uninitialized-slot)
-(define condition-type:no-such-slot)
-(define error:uninitialized-slot)
-(define error:no-such-slot)
-
-(define (initialize-conditions!)
- (set! condition-type:slot-error
- (make-condition-type 'SLOT-ERROR condition-type:cell-error
- '()
- (lambda (condition port)
- (write-string "Anonymous error for slot " port)
- (write (access-condition condition 'LOCATION) port)
- (write-string "." port))))
- (set! condition-type:uninitialized-slot
- (make-condition-type 'UNINITIALIZED-SLOT condition-type:slot-error
- '(RECORD)
- (lambda (condition port)
- (write-string "Attempt to reference slot " port)
- (write (access-condition condition 'LOCATION) port)
- (write-string " in record " port)
- (write (access-condition condition 'RECORD) port)
- (write-string " failed because the slot is not initialized."
- port))))
- (set! condition-type:no-such-slot
- (make-condition-type 'NO-SUCH-SLOT condition-type:slot-error
- '(RECORD-TYPE)
- (lambda (condition port)
- (write-string "No slot named " port)
- (write (access-condition condition 'LOCATION) port)
- (write-string " in records of type " port)
- (write (access-condition condition 'RECORD-TYPE) port)
- (write-string "." port))))
- (set! error:uninitialized-slot
- (let ((signal
- (condition-signaller condition-type:uninitialized-slot
- '(RECORD LOCATION)
- standard-error-handler)))
- (lambda (record index)
- (let* ((location (or (%record-slot-name record index) index))
- (ls (write-to-string location)))
- (call-with-current-continuation
- (lambda (k)
- (store-value-restart ls
- (lambda (value)
- (%record-set! record index value)
- (k value))
- (lambda ()
- (use-value-restart
- (string-append
- "value to use instead of the contents of slot "
- ls)
- k
- (lambda () (signal record location)))))))))))
- (set! error:no-such-slot
- (let ((signal
- (condition-signaller condition-type:no-such-slot
- '(RECORD-TYPE LOCATION)
- standard-error-handler)))
- (lambda (record-type name)
- (call-with-current-continuation
- (lambda (k)
- (use-value-restart
- (string-append "slot name to use instead of "
- (write-to-string name))
- k
- (lambda () (signal record-type name))))))))
- unspecific)
\ No newline at end of file
%record-set!
%record-tag
%record?
+ condition-type:no-such-slot
+ condition-type:slot-error
+ condition-type:uninitialized-slot
copy-record
define-structure/default-value
define-structure/default-value-by-index
set-record-type-entity-unparser-method!
set-record-type-extension!
set-record-type-unparser-method!)
- (export (runtime record-slot-access)
+ (export (runtime)
+ error:no-such-slot
+ error:uninitialized-slot
record-type-field-index)
(export (runtime unparser)
structure-tag/entity-unparser-method
gdbm_wrcreat
gdbm_writer))
\f
-(define-package (runtime generic-procedure)
- (files "gentag" "gencache" "generic")
+(define-package (runtime tagged-dispatch)
+ (files "gentag" "gencache")
(parent (runtime))
(export ()
- dispatch-tag-contents
- dispatch-tag?
- make-dispatch-tag
-
- ;; generic.scm:
built-in-dispatch-tag
- built-in-dispatch-tags
- condition-type:no-applicable-methods
dispatch-tag
- error:no-applicable-methods
- generic-procedure-applicable?
- generic-procedure-arity
- generic-procedure-arity-max
- generic-procedure-arity-min
- generic-procedure-name
- generic-procedure?
- guarantee-generic-procedure
- make-generic-procedure
- purge-generic-procedure-cache
- standard-generic-procedure-tag)
- (export (runtime generic-procedure multiplexer)
- generic-procedure-generator
- set-generic-procedure-generator!))
-
-(define-package (runtime generic-procedure multiplexer)
- (files "genmult")
- (parent (runtime))
- (export ()
- add-generic-procedure-generator
- condition-type:extra-applicable-methods
- error:extra-applicable-methods
- generic-procedure-default-generator
- generic-procedure-generator-list
- remove-generic-procedure-generator
- remove-generic-procedure-generators
- set-generic-procedure-default-generator!))
-
-(define-package (runtime tagged-vector)
- (files "tvector")
- (parent (runtime))
- (export ()
- guarantee-tagged-vector
- make-tagged-vector
- record-slot-uninitialized
- set-tagged-vector-element!
- set-tagged-vector-tag!
- tagged-vector
- tagged-vector-element
- tagged-vector-element-initialized?
- tagged-vector-length
- tagged-vector-tag
- tagged-vector?))
-
-(define-package (runtime record-slot-access)
- (files "recslot")
- (parent (runtime))
- (export ()
- condition-type:no-such-slot
- condition-type:slot-error
- condition-type:uninitialized-slot
- %record-accessor
- %record-accessor-generator
- %record-initpred
- %record-initpred-generator
- %record-modifier
- %record-modifier-generator
- %record-slot-index
- %record-slot-name
- %record-slot-names)
- (export (runtime record)
- error:no-such-slot))
-
-(define-package (runtime generic-procedure eqht)
- (files "geneqht")
- (parent (runtime))
- (export (runtime generic-procedure)
- eqht/for-each
- eqht/get
- eqht/put!
- make-eqht))
+ dispatch-tag-contents
+ dispatch-tag?
+ make-dispatch-tag))
(define-package (runtime crypto)
(files "crypto")
((MACRO) `((:macro nil)))
(else
(let ((v (environment-lookup env symbol)))
- `((,(cond ((generic-procedure? v) ':generic-function)
- ((procedure? v) ':function)
+ `((,(cond ((procedure? v) ':function)
(else ':variable))
,v)))))))
(apropos-list text env #t))))
\f
;;;; Procedures
-(define (unparse-procedure procedure context usual-method)
- (if (generic-procedure? procedure)
- (*unparse-with-brackets 'GENERIC-PROCEDURE procedure context
- (let ((name (generic-procedure-name procedure)))
- (and name
- (lambda (context*)
- (*unparse-object name context*)))))
- (usual-method)))
-
(define (unparse/compound-procedure procedure context)
- (unparse-procedure procedure context
- (lambda ()
- (*unparse-with-brackets 'COMPOUND-PROCEDURE procedure context
- (and (get-param:unparse-compound-procedure-names?)
- (lambda-components* (procedure-lambda procedure)
- (lambda (name required optional rest body)
- required optional rest body
- (and (not (eq? name lambda-tag:unnamed))
- (lambda (context*)
- (*unparse-object name context*))))))))))
+ (*unparse-with-brackets 'COMPOUND-PROCEDURE procedure context
+ (and (get-param:unparse-compound-procedure-names?)
+ (lambda-components* (procedure-lambda procedure)
+ (lambda (name required optional rest body)
+ required optional rest body
+ (and (not (eq? name lambda-tag:unnamed))
+ (lambda (context*)
+ (*unparse-object name context*))))))))
(define (unparse/primitive-procedure procedure context)
- (unparse-procedure procedure context
- (lambda ()
- (let ((unparse-name
- (lambda (context)
- (*unparse-object (primitive-procedure-name procedure) context))))
- (cond ((get-param:unparse-primitives-by-name?)
- (unparse-name context))
- ((get-param:unparse-with-maximum-readability?)
- (*unparse-readable-hash procedure context))
- (else
- (*unparse-with-brackets 'PRIMITIVE-PROCEDURE #f context
- unparse-name)))))))
+ (let ((unparse-name
+ (lambda (context)
+ (*unparse-object (primitive-procedure-name procedure) context))))
+ (cond ((get-param:unparse-primitives-by-name?)
+ (unparse-name context))
+ ((get-param:unparse-with-maximum-readability?)
+ (*unparse-readable-hash procedure context))
+ (else
+ (*unparse-with-brackets 'PRIMITIVE-PROCEDURE #f context
+ unparse-name)))))
(define (unparse/compiled-entry entry context)
(let* ((type (compiled-entry-type entry))
(closure?
(and procedure?
(compiled-code-block/manifest-closure?
- (compiled-code-address->block entry))))
- (usual-method
- (lambda ()
- (*unparse-with-brackets (if closure? 'COMPILED-CLOSURE type)
- entry
- context
- (lambda (context*)
- (let ((name (and procedure? (compiled-procedure/name entry))))
- (receive (filename block-number)
- (compiled-entry/filename-and-index entry)
- (*unparse-char #\( context*)
- (if name
- (*unparse-string name context*))
- (if filename
- (begin
- (if name
- (*unparse-char #\space context*))
- (*unparse-object (pathname-name filename) context*)
- (if block-number
- (begin
- (*unparse-char #\space context*)
- (*unparse-hex block-number context*)))))
- (*unparse-char #\) context*)))
- (*unparse-char #\space context*)
- (*unparse-hex (compiled-entry/offset entry) context*)
- (if closure?
- (begin
- (*unparse-char #\space context*)
- (*unparse-datum (compiled-closure->entry entry)
- context*)))
- (*unparse-char #\space context*)
- (*unparse-datum entry context*))))))
- (if procedure?
- (unparse-procedure entry context usual-method)
- (usual-method))))
+ (compiled-code-address->block entry)))))
+ (*unparse-with-brackets (if closure? 'COMPILED-CLOSURE type)
+ entry
+ context
+ (lambda (context*)
+ (let ((name (and procedure? (compiled-procedure/name entry))))
+ (receive (filename block-number)
+ (compiled-entry/filename-and-index entry)
+ (*unparse-char #\( context*)
+ (if name
+ (*unparse-string name context*))
+ (if filename
+ (begin
+ (if name
+ (*unparse-char #\space context*))
+ (*unparse-object (pathname-name filename) context*)
+ (if block-number
+ (begin
+ (*unparse-char #\space context*)
+ (*unparse-hex block-number context*)))))
+ (*unparse-char #\) context*)))
+ (*unparse-char #\space context*)
+ (*unparse-hex (compiled-entry/offset entry) context*)
+ (if closure?
+ (begin
+ (*unparse-char #\space context*)
+ (*unparse-datum (compiled-closure->entry entry)
+ context*)))
+ (*unparse-char #\space context*)
+ (*unparse-datum entry context*)))))
\f
;;;; Miscellaneous
(with-working-directory-pathname (directory-pathname (current-load-pathname))
(lambda ()
(compile-file "class")
+ (compile-file "geneqht")
+ (compile-file "generic")
+ (compile-file "genmult")
(compile-file "instance")
(compile-file "macros")
(compile-file "method")
(compile-file "printer")
+ (compile-file "recslot")
(compile-file "slot")
+ (compile-file "tvector")
(cref/generate-constructors "sos" 'ALL)))
\ No newline at end of file
(standard-scheme-find-file-initialization
'#(
("class" (sos class))
+ ("geneqht" (sos generic-procedure eqht))
+ ("generic" (sos generic-procedure))
+ ("genmult" (sos generic-procedure multiplexer))
("instance" (sos instance))
("macros" (sos macros))
("method" (sos method))
("printer" (sos printer))
- ("slot" (sos slot))))
\ No newline at end of file
+ ("recslot" (sos record-slot-access))
+ ("slot" (sos slot))
+ ("tvector" (sos tagged-vector))))
\ No newline at end of file
(without-interruption (lambda () (rehash-table! table)))
(loop))))))
-(define-integrable (eq-hash-mod key modulus)
- (fix:remainder (let ((n
- ((ucode-primitive primitive-object-set-type)
- (ucode-type positive-fixnum)
- key)))
- (if (fix:< n 0)
- (fix:not n)
- n))
- modulus))
-
(define (record-address-hash-table! table)
(add-to-population! address-hash-tables table))
(lambda (table)
(set-table-needs-rehash?! table #t))))
-(define address-hash-tables)
-
-(define (initialize-address-hashing!)
- (set! address-hash-tables (make-serial-population))
- (add-primitive-gc-daemon! mark-address-hash-tables!))
+(define address-hash-tables (make-serial-population))
+(add-primitive-gc-daemon! mark-address-hash-tables!)
\f
;;;; Resizing
(primes prime-numbers-stream)
(needs-rehash? #f))
-(define-integrable minimum-size 4)
-
-(define-integrable (weak-cons car cdr)
- (system-pair-cons (ucode-type weak-cons) car cdr))
\ No newline at end of file
+(define-integrable minimum-size 4)
\ No newline at end of file
|#
;;;; Generic Procedures
-;;; package: (runtime generic-procedure)
+;;; package: (sos generic-procedure)
-(declare (usual-integrations)
- (integrate-external "gentag" "gencache"))
+(declare (usual-integrations))
\f
;;;; Generic Procedures
(fill-cache (generic-record/cache record) tags procedure))))
(apply procedure args))))
\f
-;;;; Object Tags
-
-;;; We assume that most new data types will be constructed from tagged
-;;; vectors, 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)))
- (if (and (%record? object)
- (%record? (%record-ref object 0))
- (eq? dispatch-tag-marker (%record-ref (%record-ref object 0) 0)))
- (%record-ref object 0)
- (if (vector-ref microcode-type-tag-table (object-type object))
- (vector-ref microcode-type-tag-table (object-type object))
- ((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-matching-item built-in-tags
- (lambda (tag)
- (memq name (dispatch-tag-contents tag)))))
-
-(define condition-type:no-applicable-methods)
-(define error:no-applicable-methods)
-
-(define (initialize-conditions!)
- (set! condition-type:no-applicable-methods
- (make-condition-type 'NO-APPLICABLE-METHODS condition-type:error
- '(OPERATOR OPERANDS)
- (lambda (condition port)
- (write-string "No applicable methods for " port)
- (write (access-condition condition 'OPERATOR) port)
- (write-string " with these arguments: " port)
- (write (access-condition condition 'OPERANDS) port)
- (write-string "." port))))
- (set! error:no-applicable-methods
- (condition-signaller condition-type:no-applicable-methods
- '(OPERATOR OPERANDS)
- standard-error-handler))
- unspecific)
-\f
-;;;; Initialization
-
-(define standard-generic-procedure-tag)
-(define generic-procedure-records)
-(define generic-procedure-records-mutex)
-(define built-in-tags)
-(define microcode-type-tag-table)
-(define microcode-type-method-table)
-
-(define (initialize-generic-procedures!)
- (set! standard-generic-procedure-tag
- (make-dispatch-tag 'STANDARD-GENERIC-PROCEDURE))
- (set! generic-procedure-records (make-eqht))
- (set! generic-procedure-records-mutex (make-thread-mutex))
-
- ;; Initialize the built-in 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 ((assign-type
- (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)))))
- (define-integrable (maybe-generic object default-tag)
- (let ((record (with-thread-mutex-lock generic-procedure-records-mutex
- (lambda ()
- (eqht/get generic-procedure-records object #f)))))
- (if record
- (generic-record/tag record)
- default-tag)))
- (let ((procedure-type
- (lambda (default-tag)
- (lambda (object)
- (maybe-generic object default-tag)))))
- (assign-type 'EXTENDED-PROCEDURE procedure-type)
- (assign-type 'PROCEDURE procedure-type))
- (assign-type
- 'COMPILED-ENTRY
- (let ((procedure-tag (make-built-in-tag '(COMPILED-PROCEDURE)))
- (return-address-tag (make-built-in-tag '(COMPILED-RETURN-ADDRESS)))
- (expression-tag (make-built-in-tag '(COMPILED-EXPRESSION))))
- (lambda (default-tag)
- (lambda (object)
- (case (system-hunk3-cxr0
- ((ucode-primitive compiled-entry-kind 1) object))
- ((0) (maybe-generic object procedure-tag))
- ((1) return-address-tag)
- ((2) expression-tag)
- (else default-tag))))))
- (let ((boolean-tag (make-built-in-tag '(BOOLEAN))))
- (assign-type 'FALSE
- (lambda (default-tag)
- (lambda (object)
- (if (eq? object #f)
- boolean-tag
- default-tag))))
- (assign-type 'CONSTANT
- (let ((null-tag (make-built-in-tag '(NULL)))
- (eof-tag (make-built-in-tag '(EOF)))
- (default-tag (make-built-in-tag '(DEFAULT)))
- (keyword-tag (make-built-in-tag '(LAMBDA-KEYWORD))))
- (lambda (constant-tag)
- (lambda (object)
- (cond ((eq? object #t) boolean-tag)
- ((null? object) null-tag)
- ((eof-object? object) eof-tag)
- ((default-object? object) default-tag)
- ((memq object '(#!optional #!rest #!key #!aux))
- keyword-tag)
- (else constant-tag)))))))
-
- ;; Flonum length can change size on different architectures, so we
- ;; measure one.
- (let ((flonum-length (system-vector-length microcode-id/floating-epsilon)))
- (assign-type 'FLONUM
- (let ((flonum-vector-tag
- (make-built-in-tag '(FLONUM-VECTOR))))
- (lambda (default-tag)
- (lambda (object)
- (if (fix:= flonum-length (system-vector-length object))
- default-tag
- flonum-vector-tag))))))
- (assign-type 'RECORD
- (let ((dt-tag (make-built-in-tag '(DISPATCH-TAG))))
- (lambda (default-tag)
- (lambda (object)
- (if (eq? dispatch-tag-marker (%record-ref object 0))
- dt-tag
- default-tag)))))))
\ No newline at end of file
+(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 condition-type:no-applicable-methods
+ (make-condition-type 'NO-APPLICABLE-METHODS condition-type:error
+ '(OPERATOR OPERANDS)
+ (lambda (condition port)
+ (write-string "No applicable methods for " port)
+ (write (access-condition condition 'OPERATOR) port)
+ (write-string " with these arguments: " port)
+ (write (access-condition condition 'OPERANDS) port)
+ (write-string "." port))))
+
+(define error:no-applicable-methods
+ (condition-signaller condition-type:no-applicable-methods
+ '(OPERATOR OPERANDS)
+ standard-error-handler))
\ No newline at end of file
(and default
(default generic tags))))))
-(define multiplexer-tag)
-(define condition-type:extra-applicable-methods)
-(define error:extra-applicable-methods)
-
-(define (initialize-multiplexer!)
- (set! multiplexer-tag (list 'GENERIC-PROCEDURE-MULTIPLEXER))
- unspecific)
-
-(define (initialize-conditions!)
- (set! condition-type:extra-applicable-methods
- (make-condition-type 'EXTRA-APPLICABLE-METHODS condition-type:error
- '(OPERATOR OPERANDS)
- (lambda (condition port)
- (write-string "Too many applicable methods for " port)
- (write (access-condition condition 'OPERATOR) port)
- (write-string " with these arguments: " port)
- (write (access-condition condition 'OPERANDS) port)
- (write-string "." port))))
- (set! error:extra-applicable-methods
- (condition-signaller condition-type:extra-applicable-methods
- '(OPERATOR OPERANDS)
- standard-error-handler))
- unspecific)
\ No newline at end of file
+(define multiplexer-tag
+ (list 'generic-procedure-multiplexer))
+
+(define condition-type:extra-applicable-methods
+ (make-condition-type 'extra-applicable-methods condition-type:error
+ '(OPERATOR OPERANDS)
+ (lambda (condition port)
+ (write-string "Too many applicable methods for " port)
+ (write (access-condition condition 'operator) port)
+ (write-string " with these arguments: " port)
+ (write (access-condition condition 'operands) port)
+ (write-string "." port))))
+
+(define error:extra-applicable-methods
+ (condition-signaller condition-type:extra-applicable-methods
+ '(operator operands)
+ standard-error-handler))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Record Slot Access
+
+(declare (usual-integrations))
+\f
+(define (%record-accessor-generator name)
+ (lambda (generic tags)
+ generic
+ (let ((index (%record-slot-index (%record (car tags)) name)))
+ (and index
+ (%record-accessor index)))))
+
+(define (%record-modifier-generator name)
+ (lambda (generic tags)
+ generic
+ (let ((index (%record-slot-index (%record (car tags)) name)))
+ (and index
+ (%record-modifier index)))))
+
+(define (%record-initpred-generator name)
+ (lambda (generic tags)
+ generic
+ (let ((index (%record-slot-index (%record (car tags)) name)))
+ (and index
+ (%record-initpred index)))))
+
+(define-syntax generate-index-cases
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((index (close-syntax (cadr form) environment))
+ (limit (caddr form))
+ (expand-case (close-syntax (cadddr form) environment)))
+ `(CASE ,index
+ ,@(let loop ((i 1))
+ (if (= i limit)
+ `((ELSE (,expand-case ,index)))
+ `(((,i) (,expand-case ,i)) ,@(loop (+ i 1))))))))))
+
+(define (%record-accessor index)
+ (generate-index-cases index 16
+ (lambda (index)
+ (declare (integrate index)
+ (ignore-reference-traps (set record-slot-uninitialized)))
+ (lambda (record)
+ (if (eq? record-slot-uninitialized (%record-ref record index))
+ (error:uninitialized-slot record index)
+ (%record-ref record index))))))
+
+(define (%record-modifier index)
+ (generate-index-cases index 16
+ (lambda (index)
+ (declare (integrate index))
+ (lambda (record value) (%record-set! record index value)))))
+
+(define (%record-initpred index)
+ (generate-index-cases index 16
+ (lambda (index)
+ (declare (integrate index)
+ (ignore-reference-traps (set record-slot-uninitialized)))
+ (lambda (record)
+ (not (eq? record-slot-uninitialized (%record-ref record index)))))))
+
+(define (%record-slot-name record index)
+ (if (not (and (exact-integer? index) (positive? index)))
+ (error:wrong-type-argument index "record index" '%RECORD-SLOT-NAME))
+ (let ((names
+ (call-with-current-continuation
+ (lambda (k)
+ (bind-condition-handler (list condition-type:no-applicable-methods)
+ (lambda (condition) condition (k 'UNKNOWN))
+ (lambda ()
+ (%record-slot-names record))))))
+ (index (- index 1)))
+ (and (list? names)
+ (< index (length names))
+ (list-ref names index))))
+\f
+(define %record-slot-index
+ (make-generic-procedure 2 '%record-slot-index))
+
+(add-generic-procedure-generator %record-slot-index
+ (lambda (generic tags)
+ generic
+ (and (record-type? (dispatch-tag-contents (car tags)))
+ (lambda (record name)
+ (record-type-field-index (record-type-descriptor record)
+ name
+ #f)))))
+(define %record-slot-names
+ (make-generic-procedure 1 '%record-slot-names))
+
+(add-generic-procedure-generator %record-slot-names
+ (lambda (generic tags)
+ generic
+ (and (record-type? (dispatch-tag-contents (car tags)))
+ (lambda (record)
+ (record-type-field-names (record-type-descriptor record))))))
\ No newline at end of file
(global-definitions "../runtime/runtime")
(define-package (sos)
- (parent ()))
+ (parent (runtime)))
+
+(define-package (sos generic-procedure eqht)
+ (files "geneqht")
+ (parent (sos))
+ (export (sos generic-procedure)
+ eqht/for-each
+ eqht/get
+ eqht/put!
+ make-eqht))
+
+(define-package (sos generic-procedure)
+ (files "generic")
+ (parent (sos))
+ (export ()
+ generic-procedure-applicable?
+ generic-procedure-arity
+ generic-procedure-arity-max
+ generic-procedure-arity-min
+ generic-procedure-name
+ generic-procedure?
+ guarantee-generic-procedure
+ make-generic-procedure
+ purge-generic-procedure-cache
+ standard-generic-procedure-tag)
+ (export (sos)
+ condition-type:no-applicable-methods
+ error:no-applicable-methods)
+ (export (sos generic-procedure multiplexer)
+ generic-procedure-generator
+ set-generic-procedure-generator!)
+ (import (runtime tagged-dispatch)
+ fill-cache
+ new-cache
+ probe-cache
+ probe-cache-1
+ probe-cache-2
+ probe-cache-3
+ probe-cache-4
+ purge-cache-entries))
+
+(define-package (sos generic-procedure multiplexer)
+ (files "genmult")
+ (parent (sos))
+ (export ()
+ add-generic-procedure-generator
+ condition-type:extra-applicable-methods
+ error:extra-applicable-methods
+ generic-procedure-default-generator
+ generic-procedure-generator-list
+ remove-generic-procedure-generator
+ remove-generic-procedure-generators
+ set-generic-procedure-default-generator!))
+
+(define-package (sos tagged-vector)
+ (files "tvector")
+ (parent (sos))
+ (export (sos)
+ guarantee-tagged-vector
+ make-tagged-vector
+ record-slot-uninitialized
+ set-tagged-vector-element!
+ set-tagged-vector-tag!
+ tagged-vector
+ tagged-vector-element
+ tagged-vector-element-initialized?
+ tagged-vector-length
+ tagged-vector-tag
+ tagged-vector?))
+
+(define-package (sos record-slot-access)
+ (files "recslot")
+ (parent (sos))
+ (export (sos)
+ %record-accessor
+ %record-accessor-generator
+ %record-initpred
+ %record-initpred-generator
+ %record-modifier
+ %record-modifier-generator
+ %record-slot-index
+ %record-slot-name
+ %record-slot-names))
(define-package (sos slot)
(files "slot")
(export (sos class)
canonicalize-slot-argument
compute-slot-descriptor
- install-slot-accessor-methods)
- (import (runtime record-slot-access)
- error:no-such-slot))
+ install-slot-accessor-methods))
(define-package (sos class)
(files "class")
subclass?)
(import (runtime microcode-tables)
microcode-type/code->name
- microcode-type/name->code)
- (import (runtime record-slot-access)
- error:no-such-slot))
+ microcode-type/name->code))
(define-package (sos instance)
(files "instance")
(define (make-tagged-vector tag length)
(guarantee dispatch-tag? tag 'MAKE-TAGGED-VECTOR)
(guarantee-index-integer length 'MAKE-TAGGED-VECTOR)
- (let ((result
- (object-new-type (ucode-type record)
- (make-vector (fix:+ length 1)
- record-slot-uninitialized))))
- (%record-set! result 0 tag)
- result))
+ (%make-record tag (fix:+ length 1) record-slot-uninitialized))
(define (tagged-vector tag . elements)
(guarantee dispatch-tag? tag 'MAKE-TAGGED-VECTOR)
- (object-new-type (ucode-type record) (apply vector tag elements)))
+ (apply %record tag elements))
(define (tagged-vector? object)
(and (%record? object)
(if (not (and (fix:fixnum? index) (fix:>= index 0)))
(error:wrong-type-argument vector "non-negative fixnum" caller)))
-(define record-slot-uninitialized)
-
-(define (initialize-tagged-vector!)
- (set! record-slot-uninitialized (intern "#[record-slot-uninitialized]"))
- unspecific)
\ No newline at end of file
+(define record-slot-uninitialized
+ (intern "#[record-slot-uninitialized]"))
\ No newline at end of file
"runtime/test-ephemeron"
("runtime/test-file-attributes" (runtime))
"runtime/test-floenv"
- "runtime/test-genmult"
"runtime/test-hash-table"
"runtime/test-integer-bits"
"runtime/test-md5"
"runtime/test-url"
("runtime/test-wttree" (runtime wt-tree))
;;"ffi/test-ffi"
+ "sos/test-genmult"
))
(with-working-directory-pathname
(declare (usual-integrations))
+(load-option 'sos)
+
(define-test 'REGRESSION:REMOVE-GENERIC-PROCEDURE-GENERATOR
(lambda ()
(define generic (make-generic-procedure 1))
projects / mit-scheme.git / commitdiff