names for a given microcode type code.
#| -*-Scheme-*-
-$Id: generic.scm,v 1.8 2005/04/12 18:36:32 cph Exp $
+$Id: generic.scm,v 1.9 2005/04/14 04:42:31 cph Exp $
Copyright 1996,2003,2005 Massachusetts Institute of Technology
((vector-ref microcode-type-method-table (object-type object))
object))))
-(define (make-built-in-tag name)
- (let ((entry (assq name built-in-tag-table)))
- (if entry
- (cdr entry)
- (let ((tag (make-dispatch-tag name)))
- (set! built-in-tag-table (cons (cons name tag) built-in-tag-table))
+(define (make-built-in-tag names)
+ (let ((tags (map built-in-dispatch-tag names)))
+ (if (there-exists? tags (lambda (tag) tag))
+ (let ((tag (car tags)))
+ (if (not (and (for-all? (cdr tags)
+ (lambda (tag*)
+ (eq? tag* tag)))
+ (let ((names* (dispatch-tag-contents tag)))
+ (and (for-all? names
+ (lambda (name)
+ (memq name names*)))
+ (for-all? names*
+ (lambda (name)
+ (memq name 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)
- (map cdr built-in-tag-table))
+ (list-copy built-in-tags))
(define (built-in-dispatch-tag name)
- (let ((entry (assq name built-in-tag-table)))
- (and entry
- (cdr entry))))
+ (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 standard-generic-procedure-tag)
(define generic-procedure-records)
-(define built-in-tag-table)
+(define built-in-tags)
(define microcode-type-tag-table)
(define microcode-type-method-table)
(set! generic-procedure-records (make-eqht))
;; Initialize the built-in tag tables.
- (set! built-in-tag-table '())
+ (set! built-in-tags '())
(set! microcode-type-tag-table
(make-initialized-vector (microcode-type/code-limit)
(lambda (code)
(make-built-in-tag
- (or (microcode-type/code->name code) 'OBJECT)))))
+ (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
(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)))
+ (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
((1) return-address-tag)
((2) expression-tag)
(else default-tag))))))
- (let ((boolean-tag (make-built-in-tag 'BOOLEAN)))
+ (let ((boolean-tag (make-built-in-tag '(BOOLEAN))))
(assign-type 'FALSE
(lambda (default-tag)
(lambda (object)
default-tag)))))
(assign-type 'FLONUM
(let ((flonum-vector-tag
- (make-built-in-tag 'FLONUM-VECTOR)))
+ (make-built-in-tag '(FLONUM-VECTOR))))
(lambda (default-tag)
(lambda (object)
(if (fix:= 2 (system-vector-length object))
default-tag
flonum-vector-tag)))))
(assign-type 'RECORD
- (let ((dt-tag (make-built-in-tag 'DISPATCH-TAG)))
+ (let ((dt-tag (make-built-in-tag '(DISPATCH-TAG))))
(lambda (default-tag)
(lambda (object)
(if (eq? dispatch-tag-marker (%record-ref object 0))
#| -*-Scheme-*-
-$Id: gentag.scm,v 1.5 2003/02/14 18:28:32 cph Exp $
+$Id: gentag.scm,v 1.6 2005/04/14 04:42:37 cph Exp $
-Copyright 1993-1999 Massachusetts Institute of Technology
+Copyright 1996,2005 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(guarantee-dispatch-tag tag 'DISPATCH-TAG-CONTENTS)
(%record-ref tag 1))
-(define (set-dispatch-tag-contents! tag contents)
- (guarantee-dispatch-tag tag 'SET-DISPATCH-TAG-CONTENTS!)
- (%record-set! tag 1 contents))
-
(define-integrable (guarantee-dispatch-tag tag caller)
(if (not (dispatch-tag? tag))
(error:wrong-type-argument tag "dispatch tag" caller)))
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.537 2005/04/01 04:47:06 cph Exp $
+$Id: runtime.pkg,v 14.538 2005/04/14 04:42:45 cph Exp $
Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
microcode-termination/code-limit
microcode-termination/name->code
microcode-type/code->name
+ microcode-type/code->names
microcode-type/code-limit
microcode-type/name->code)
(export (runtime save/restore)
dispatch-tag?
guarantee-dispatch-tag
make-dispatch-tag
- set-dispatch-tag-contents!
;; generic.scm:
arity-max
#| -*-Scheme-*-
-$Id: utabs.scm,v 14.18 2003/07/22 02:40:31 cph Exp $
+$Id: utabs.scm,v 14.19 2005/04/14 04:42:53 cph Exp $
Copyright 1986,1987,1988,1991,1992,1994 Massachusetts Institute of Technology
-Copyright 2001,2003 Massachusetts Institute of Technology
+Copyright 2001,2003,2005 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(let ((new-vector (vector-copy new-identification))
(old-vector (vector-copy identification-vector)))
(let loop ((fields '(CONSOLE-WIDTH CONSOLE-HEIGHT)))
- (if (not (null? fields))
+ (if (pair? fields)
(let ((slot
(microcode-identification-vector-slot (car fields))))
- (vector-set! old-vector slot false)
- (vector-set! new-vector slot false)
+ (vector-set! old-vector slot #f)
+ (vector-set! new-vector slot #f)
(loop (cdr fields)))))
(if (not (equal? new-vector old-vector))
- (error
- "re-read-microcode-tables!: Missing microcode description"
- file-name)
- (begin
- (set! identification-vector new-identification)
- (set! microcode-id/tty-x-size
- (microcode-identification-item 'CONSOLE-WIDTH))
- (set! microcode-id/tty-y-size
- (microcode-identification-item 'CONSOLE-HEIGHT))
- unspecific)))))))
+ (error "Missing microcode description:" file-name))
+ (set! identification-vector new-identification)
+ (set! microcode-id/tty-x-size
+ (microcode-identification-item 'CONSOLE-WIDTH))
+ (set! microcode-id/tty-y-size
+ (microcode-identification-item 'CONSOLE-HEIGHT))
+ unspecific)))))
\f
(define (read-microcode-tables! #!optional filename)
(set! microcode-tables-identification
(let ((string (microcode-identification-item 'STACK-TYPE-STRING)))
(cond ((string? string) (intern string))
((not string) 'STANDARD)
- (else (error "illegal stack type" string)))))
+ (else (error "Illegal stack type:" string)))))
(set! microcode-id/tty-x-size
(microcode-identification-item 'CONSOLE-WIDTH))
(set! microcode-id/tty-y-size
(define (fixed-objects-vector-slot name)
(or (fixed-object/name->code name)
- (error "FIXED-OBJECTS-VECTOR-SLOT: Unknown name" name)))
+ (error:bad-range-argument name 'FIXED-OBJECTS-VECTOR-SLOT)))
(define (fixed-objects-item name)
(vector-ref (get-fixed-objects-vector) (fixed-objects-vector-slot name)))
(define (microcode-table-search slot name)
(let ((vector (vector-ref (get-fixed-objects-vector) slot)))
(let ((end (vector-length vector)))
- (define (loop i)
- (and (not (= i end))
+ (let loop ((i 0))
+ (and (fix:< i end)
(let ((entry (vector-ref vector i)))
(if (if (pair? entry)
(memq name entry)
(eq? name entry))
i
- (loop (1+ i))))))
- (loop 0))))
+ (loop (fix:+ i 1)))))))))
-(define (microcode-table-ref slot index)
+(define (microcode-table-entry slot index)
(let ((vector (vector-ref (get-fixed-objects-vector) slot)))
- (and (< index (vector-length vector))
- (let ((entry (vector-ref vector index)))
- (if (pair? entry)
- (car entry)
- entry)))))
+ (and (fix:< index (vector-length vector))
+ (vector-ref vector index))))
+
+(define (microcode-table-ref slot index)
+ (let ((entry (microcode-table-entry slot index)))
+ (if (pair? entry)
+ (car entry)
+ entry)))
\f
(define returns-slot)
(define (microcode-type/code->name code)
(microcode-table-ref types-slot code))
+(define (microcode-type/code->names code)
+ (let ((entry (microcode-table-entry types-slot code)))
+ (cond ((not entry) '())
+ ((list? entry) entry)
+ (else (list entry)))))
+
(define (microcode-type/code-limit)
(vector-length (vector-ref (get-fixed-objects-vector) types-slot)))
(define (microcode-identification-vector-slot name)
(or (microcode-table-search identifications-slot name)
- (error "Unknown microcode identification item" name)))
+ (error:bad-range-argument name 'MICROCODE-IDENTIFICATION-VECTOR-SLOT)))
(define (microcode-identification-item name)
(vector-ref identification-vector
projects / mit-scheme.git / commitdiff