From a533157436b6dbee6c5ab19b915b453423a5c79d Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 13 Mar 2003 20:13:03 +0000 Subject: [PATCH] Change MAKE-DEFINE-STRUCTURE-TYPE to accept a length rather than an offset. Also, don't allow the default-inits argument to be specified as #F; it must be a list. Implement DEFINE-STRUCTURE/KEYWORD-PARSER* to provide more efficient generation of keyword constructors. --- v7/src/runtime/record.scm | 175 +++++++++++++++++++++----------------- 1 file changed, 98 insertions(+), 77 deletions(-) diff --git a/v7/src/runtime/record.scm b/v7/src/runtime/record.scm index 35344c74c..812273c2d 100644 --- a/v7/src/runtime/record.scm +++ b/v7/src/runtime/record.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: record.scm,v 1.40 2003/03/13 03:58:18 cph Exp $ +$Id: record.scm,v 1.41 2003/03/13 20:13:03 cph Exp $ Copyright 1989,1990,1991,1993,1994,1996 Massachusetts Institute of Technology Copyright 1997,2002,2003 Massachusetts Institute of Technology @@ -462,7 +462,7 @@ USA. ;;;; Runtime support for DEFINE-STRUCTURE -(define ) +(define rtd:structure-type) (define make-define-structure-type) (define structure-type?) (define structure-type/physical-type) @@ -473,61 +473,62 @@ USA. (define structure-type/unparser-method) (define set-structure-type/unparser-method!) (define structure-type/tag) -(define structure-type/offset) +(define structure-type/length) (define (initialize-structure-type-type!) - (set! + (set! rtd:structure-type (make-record-type "structure-type" '(PHYSICAL-TYPE NAME FIELD-NAMES FIELD-INDEXES DEFAULT-INITS UNPARSER-METHOD TAG - OFFSET))) + LENGTH))) (set! make-define-structure-type - (let ((constructor (record-constructor ))) - (lambda (physical-type name field-names field-indexes . rest) - (receive (default-inits unparser-method tag offset) - (case (length rest) - ((1) (values #f (car rest) physical-type 0)) - ((2) (values (car rest) (cadr rest) physical-type 0)) - ((4) (apply values rest)) - (else - (error:wrong-number-of-arguments - 'MAKE-DEFINE-STRUCTURE-TYPE - 8 - (cons* physical-type name field-names field-indexes - rest)))) - (constructor physical-type - name - (list->vector field-names) - (list->vector field-indexes) - (if default-inits - (list->vector default-inits) - (make-vector (length field-names) - (lambda () #f))) - unparser-method - tag - offset))))) + (let ((constructor (record-constructor rtd:structure-type))) + (lambda (physical-type name field-names field-indexes default-inits + unparser-method tag length) + (constructor physical-type + name + (list->vector field-names) + (list->vector field-indexes) + (list->vector default-inits) + unparser-method + tag + length)))) (set! structure-type? - (record-predicate )) + (record-predicate rtd:structure-type)) (set! structure-type/physical-type - (record-accessor 'PHYSICAL-TYPE)) + (record-accessor rtd:structure-type 'PHYSICAL-TYPE)) (set! structure-type/name - (record-accessor 'NAME)) + (record-accessor rtd:structure-type 'NAME)) (set! structure-type/field-names - (record-accessor 'FIELD-NAMES)) + (record-accessor rtd:structure-type 'FIELD-NAMES)) (set! structure-type/field-indexes - (record-accessor 'FIELD-INDEXES)) + (record-accessor rtd:structure-type 'FIELD-INDEXES)) (set! structure-type/default-inits - (record-accessor 'DEFAULT-INITS)) + (record-accessor rtd:structure-type 'DEFAULT-INITS)) (set! structure-type/unparser-method - (record-accessor 'UNPARSER-METHOD)) + (record-accessor rtd:structure-type 'UNPARSER-METHOD)) (set! set-structure-type/unparser-method! - (record-modifier 'UNPARSER-METHOD)) + (record-modifier rtd:structure-type 'UNPARSER-METHOD)) (set! structure-type/tag - (record-accessor 'TAG)) - (set! structure-type/offset - (record-accessor 'OFFSET)) + (record-accessor rtd:structure-type 'TAG)) + (set! structure-type/length + (record-accessor rtd:structure-type 'LENGTH)) unspecific) +(define (structure-type/field-index type field-name) + (vector-ref (structure-type/field-indexes type) + (structure-type/field-name-index type field-name))) + +(define (structure-type/field-name-index type field-name) + (let ((names (structure-type/field-names type))) + (let ((n (vector-length names))) + (let loop ((i 0)) + (if (not (fix:< i n)) + (error:no-such-slot type field-name)) + (if (eq? (vector-ref names i) field-name) + i + (loop (fix:+ i 1))))))) + (define (structure-tag/unparser-method tag type) (let ((structure-type (tag->structure-type tag type))) (and structure-type @@ -659,41 +660,61 @@ USA. (structure-type/name type) `(,accessor-type ,type ',field-name))))) -(define (define-structure/keyword-parser type argument-list) - (let ((inits (structure-type/default-inits type))) - (let ((n (vector-length inits))) - (if (pair? argument-list) - (let* ((unseen (list 'UNSEEN)) - (values (make-vector n unseen))) - (do ((args argument-list (cddr args))) - ((not (pair? args))) - (if (not (pair? (cdr args))) - (error "Keyword list does not have even length:" - argument-list)) - (let ((i (structure-type/field-name-index type (car args)))) - (if (eq? (vector-ref values i) unseen) - (vector-set! values i (cadr args))))) - (do ((i (fix:- n 1) (fix:- i 1)) - (l '() - (cons (if (eq? (vector-ref values i) unseen) - (vector-ref values i) - ((vector-ref inits i))) - l))) - ((not (fix:>= i 0)) l))) - (do ((i (fix:- n 1) (fix:- i 1)) - (l '() (cons ((vector-ref inits i)) l))) - ((not (fix:>= i 0)) l)))))) - -(define (structure-type/field-index type field-name) - (vector-ref (structure-type/field-indexes type) - (structure-type/field-name-index type field-name))) - -(define (structure-type/field-name-index type field-name) - (let ((names (structure-type/field-names type))) +(define (define-structure/keyword-parser type arguments) + (let ((names (structure-type/field-names type)) + (inits (structure-type/default-inits type))) (let ((n (vector-length names))) - (let loop ((i 0)) - (if (not (fix:< i n)) - (error:no-such-slot type field-name)) - (if (eq? (vector-ref names i) field-name) - i - (loop (fix:+ i 1))))))) \ No newline at end of file + (let* ((unseen (list 'UNSEEN)) + (values (make-vector n unseen))) + (do ((args arguments (cddr args))) + ((not (pair? args))) + (if (not (pair? (cdr args))) + (error "Keyword list does not have even length:" arguments)) + (let ((i (structure-type/field-name-index type (car args)))) + (if (eq? (vector-ref values i) unseen) + (vector-set! values i (cadr args))))) + (do ((i (fix:- n 1) (fix:- i 1)) + (l '() + (cons (if (eq? (vector-ref values i) unseen) + (vector-ref values i) + ((vector-ref inits i))) + l))) + ((not (fix:>= i 0)) l)))))) + +(define (define-structure/keyword-parser* type arguments) + (let ((names (structure-type/field-names type)) + (indexes (structure-type/field-indexes type)) + (inits (structure-type/default-inits type)) + (v (vector-cons (structure-type/length type) #f))) + (let ((n (vector-length names))) + (let ((tag (structure-type/tag type))) + (if tag + (vector-set! v 0 tag))) + (let ((seen? (make-vector n #f))) + (do ((args arguments (cddr args))) + ((not (pair? args))) + (if (not (pair? (cdr args))) + (error "Keyword list does not have even length:" arguments)) + (let ((field-name (car args))) + (let loop ((i 0)) + (if (not (fix:< i n)) + (error:no-such-slot type field-name)) + (if (eq? (vector-ref names i) field-name) + (if (not (vector-ref seen? i)) + (begin + (vector-set! v + (vector-ref indexes i) + (cadr args)) + (vector-set! seen? i #t))) + (loop (fix:+ i 1)))))) + (do ((i 0 (fix:+ i 1))) + ((not (fix:< i n))) + (if (not (vector-ref seen? i)) + (vector-set! v + (vector-ref indexes i) + ((vector-ref inits i)))))) + (if (eq? (structure-type/physical-type type) 'LIST) + (do ((i (fix:- n 1) (fix:- i 1)) + (l '() (cons (vector-ref v i) l))) + ((not (fix:>= i 0)) l)) + v)))) \ No newline at end of file -- 2.25.1