From: Chris Hanson Date: Thu, 14 Apr 2005 04:42:53 +0000 (+0000) Subject: Change BUILT-IN-DISPATCH-TAG so that it accepts each of the different X-Git-Tag: 20090517-FFI~1330 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9542fc604aa961b771139e0b4664f62c41106b66;p=mit-scheme.git Change BUILT-IN-DISPATCH-TAG so that it accepts each of the different names for a given microcode type code. --- diff --git a/v7/src/runtime/generic.scm b/v7/src/runtime/generic.scm index f15e53c43..7133926b3 100644 --- a/v7/src/runtime/generic.scm +++ b/v7/src/runtime/generic.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -307,21 +307,33 @@ USA. ((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) @@ -346,7 +358,7 @@ USA. (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) @@ -356,12 +368,15 @@ USA. (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 @@ -384,9 +399,9 @@ USA. (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 @@ -395,7 +410,7 @@ USA. ((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) @@ -410,14 +425,14 @@ USA. 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)) diff --git a/v7/src/runtime/gentag.scm b/v7/src/runtime/gentag.scm index 5366bb800..570204bc9 100644 --- a/v7/src/runtime/gentag.scm +++ b/v7/src/runtime/gentag.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -60,10 +60,6 @@ USA. (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))) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index f2ca5ca7a..88eadb5b1 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-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 @@ -2311,6 +2311,7 @@ USA. 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) @@ -4300,7 +4301,6 @@ USA. dispatch-tag? guarantee-dispatch-tag make-dispatch-tag - set-dispatch-tag-contents! ;; generic.scm: arity-max diff --git a/v7/src/runtime/utabs.scm b/v7/src/runtime/utabs.scm index 3892b9aac..236c6b04b 100644 --- a/v7/src/runtime/utabs.scm +++ b/v7/src/runtime/utabs.scm @@ -1,9 +1,9 @@ #| -*-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. @@ -37,23 +37,20 @@ USA. (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))))) (define (read-microcode-tables! #!optional filename) (set! microcode-tables-identification @@ -96,7 +93,7 @@ USA. (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 @@ -144,7 +141,7 @@ USA. (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))) @@ -155,23 +152,25 @@ USA. (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))) (define returns-slot) @@ -214,6 +213,12 @@ USA. (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))) @@ -222,7 +227,7 @@ USA. (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