From 29dbb3db8c05556ea80dae53f25d159b8257d6e5 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 7 Dec 1992 19:07:03 +0000 Subject: [PATCH] Rewrite record package and DEFINE-STRUCTURE macro to use the record datatype rather than vectors. --- v7/src/runtime/boot.scm | 8 +- v7/src/runtime/defstr.scm | 1039 ++++++++++++++++++------------------ v7/src/runtime/events.scm | 15 +- v7/src/runtime/io.scm | 16 +- v7/src/runtime/make.scm | 51 +- v7/src/runtime/packag.scm | 61 ++- v7/src/runtime/record.scm | 296 +++++----- v7/src/runtime/runtime.pkg | 25 +- v7/src/runtime/scode.scm | 61 +-- v7/src/runtime/unpars.scm | 21 +- v7/src/runtime/version.scm | 4 +- v8/src/runtime/make.scm | 51 +- v8/src/runtime/runtime.pkg | 25 +- 13 files changed, 849 insertions(+), 824 deletions(-) diff --git a/v7/src/runtime/boot.scm b/v7/src/runtime/boot.scm index 8cac467a2..371fb8393 100644 --- a/v7/src/runtime/boot.scm +++ b/v7/src/runtime/boot.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/boot.scm,v 14.4 1990/09/19 00:32:41 cph Rel $ +$Id: boot.scm,v 14.5 1992/12/07 19:06:39 cph Exp $ -Copyright (c) 1988, 1990 Massachusetts Institute of Technology +Copyright (c) 1988-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -58,6 +58,10 @@ MIT in each case. |# (unparser state object))) (write-char #\] port)))))) +(define (unparser-method? object) + (and (procedure? object) + (procedure-arity-valid? object 2))) + (define-integrable interrupt-bit/stack #x0001) (define-integrable interrupt-bit/global-gc #x0002) (define-integrable interrupt-bit/gc #x0004) diff --git a/v7/src/runtime/defstr.scm b/v7/src/runtime/defstr.scm index e61b6c2db..e8562f35d 100644 --- a/v7/src/runtime/defstr.scm +++ b/v7/src/runtime/defstr.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: defstr.scm,v 14.19 1992/11/29 14:15:27 gjr Exp $ +$Id: defstr.scm,v 14.20 1992/12/07 19:06:41 cph Exp $ Copyright (c) 1988-1992 Massachusetts Institute of Technology @@ -43,41 +43,40 @@ This macro works like the Common Lisp `defstruct' with the following differences: * The default constructor procedure takes positional arguments, in the -same order as specified in the definition of the structure. A keyword -constructor may be specified by giving the option KEYWORD-CONSTRUCTOR. + same order as specified in the definition of the structure. A + keyword constructor may be specified by giving the option + KEYWORD-CONSTRUCTOR. * BOA constructors are described using Scheme lambda lists. Since -there is nothing corresponding to &aux in Scheme lambda lists, this -functionality is not implemented. + there is nothing corresponding to &aux in Scheme lambda lists, this + functionality is not implemented. * By default, no COPIER procedure is generated. -* COPIERS are not allowed for structures of type RECORD. - * The side effect procedure corresponding to the accessor "foo" is -given the name "set-foo!". + given the name "set-foo!". * Keywords are just ordinary symbols -- use "foo" instead of ":foo". * The option values FALSE, NIL, TRUE, and T are treated as if the -appropriate boolean constant had been specified instead. + appropriate boolean constant had been specified instead. * The PRINT-FUNCTION option is named PRINT-PROCEDURE. Its argument is -a procedure of two arguments (the unparser state and the structure -instance) rather than three as in Common Lisp. + a procedure of two arguments (the unparser state and the structure + instance) rather than three as in Common Lisp. * By default, named structures are tagged with a unique object of some -kind. In Common Lisp, the structures are tagged with symbols, but -that depends on the Common Lisp package system to help generate unique -tags; Scheme has no such way of generating unique symbols. + kind. In Common Lisp, the structures are tagged with symbols, but + that depends on the Common Lisp package system to help generate + unique tags; Scheme has no such way of generating unique symbols. * The NAMED option may optionally take an argument, which is normally -the name of a variable (any expression may be used, but it will be -evaluated whenever the tag name is needed). If used, structure -instances will be tagged with that variable's value. The variable -must be defined when the defstruct is evaluated. + the name of a variable (any expression may be used, but it will be + evaluated whenever the tag name is needed). If used, structure + instances will be tagged with that variable's value. The variable + must be defined when the defstruct is evaluated. -* The TYPE option is restricted to the values VECTOR, LIST and RECORD. +* The TYPE option is restricted to the values VECTOR and LIST. * The INCLUDE option is not implemented. @@ -90,391 +89,339 @@ must be defined when the defstruct is evaluated. (define transform/define-structure (macro (name-and-options . slot-descriptions) - (let ((structure (parse/name-and-options name-and-options))) - (structure/set-slots! structure - (parse/slot-descriptions structure - slot-descriptions)) - (if (eq? (structure/scheme-type structure) 'RECORD) - (structure/set-type! structure - (make-record-type - (make-record-type-name structure) - (map slot/name (structure/slots structure))))) + (let ((structure + (with-values + (lambda () + (if (pair? name-and-options) + (values (car name-and-options) (cdr name-and-options)) + (values name-and-options '()))) + (lambda (name options) + (parse/options name + options + (map parse/slot-description + slot-descriptions)))))) + (do ((slots (structure/slots structure) (cdr slots)) + (index (if (structure/named? structure) + (+ (structure/offset structure) 1) + (structure/offset structure)) + (+ index 1))) + ((null? slots)) + (set-slot/index! (car slots) index)) `(BEGIN ,@(type-definitions structure) ,@(constructor-definitions structure) ,@(accessor-definitions structure) - ,@(settor-definitions structure) + ,@(modifier-definitions structure) ,@(predicate-definitions structure) ,@(copier-definitions structure) ,@(print-procedure-definitions structure) ',(structure/name structure))))) -;;;; Parse Name-and-Options - -(define (parse/name-and-options name-and-options) - (if (pair? name-and-options) - (parse/options (car name-and-options) (cdr name-and-options)) - (parse/options name-and-options '()))) +;;;; Parse Options -(define (parse/options name options) +(define (parse/options name options slots) (if (not (symbol? name)) - (error "Structure name must be a symbol" name)) + (error "Structure name must be a symbol:" name)) (if (not (list? options)) - (error "Structure options must be a list" options)) + (error "Structure options must be a list:" options)) (let ((conc-name (symbol-append name '-)) (default-constructor-disabled? false) (boa-constructors '()) (keyword-constructors '()) (copier-name false) (predicate-name (symbol-append name '?)) - (print-procedure default-value) - (type-seen? false) - (type 'STRUCTURE) - (named-seen? false) - (tag-name default-value) + (print-procedure `(,(absolute 'UNPARSER/STANDARD-METHOD) ',name)) + (type 'RECORD) + (type-name name) + (tag-expression) (offset 0) - (include false)) - - (define (parse/option option keyword arguments) - (let ((n-arguments (length arguments))) - - (define (check-arguments min max) - (if (or (< n-arguments min) (> n-arguments max)) - (error "Structure option used with wrong number of arguments" - option))) - - (define (symbol-option default) - (parse/option-value symbol? keyword (car arguments) default)) - - (case keyword - ((CONC-NAME) - (check-arguments 0 1) - (set! conc-name - (and (not (null? arguments)) - (symbol-option (symbol-append name '-))))) - ((KEYWORD-CONSTRUCTOR) - (check-arguments 0 1) - (set! keyword-constructors - (cons (list option - (if (null? arguments) - (symbol-append 'make- name) - (car arguments))) - keyword-constructors))) - ((CONSTRUCTOR) - (check-arguments 0 2) - (if (null? arguments) - (set! boa-constructors - (cons (list option (symbol-append 'make- name)) - boa-constructors)) - (let ((name (car arguments))) - (if (memq name '(#F FALSE NIL)) - (set! default-constructor-disabled? true) - (set! boa-constructors - (cons (cons option arguments) - boa-constructors)))))) - ((COPIER) - (check-arguments 0 1) - (if (not (null? arguments)) - (set! copier-name (symbol-option (symbol-append 'copy- name))))) - ((PREDICATE) - (check-arguments 0 1) - (if (not (null? arguments)) - (set! predicate-name (symbol-option (symbol-append name '?))))) - - ((PRINT-PROCEDURE) - (check-arguments 1 1) - (set! print-procedure - (parse/option-value (lambda (x) x true) - keyword - (car arguments) - false))) - ((NAMED) - (check-arguments 0 1) - (set! named-seen? true) - (if (not (null? arguments)) - (set! tag-name (car arguments)))) - ((TYPE) - (check-arguments 1 1) - (set! type-seen? true) - (set! type (car arguments))) - ((INITIAL-OFFSET) - (check-arguments 1 1) - (set! offset (car arguments))) - #| - ((INCLUDE) - (check-arguments 1 1) - (set! include arguments)) - |# - (else - (error "Unrecognized structure option" keyword))))) - - (for-each (lambda (option) - (if (pair? option) - (parse/option option (car option) (cdr option)) - (parse/option option option '()))) - options) + (options-seen '())) + (set! tag-expression type-name) + (for-each + (lambda (option) + (if (not (or (symbol? option) + (and (pair? option) + (symbol? (car option)) + (list? (cdr option))))) + (error "Ill-formed structure option:" option)) + (with-values + (lambda () + (if (pair? option) + (values (car option) (cdr option)) + (values option '()))) + (lambda (keyword arguments) + (set! options-seen (cons (cons keyword option) options-seen)) + (let ((n-arguments (length arguments)) + (check-duplicate + (lambda () + (let ((previous (assq keyword (cdr options-seen)))) + (if previous + (error "Duplicate structure option:" + previous option))))) + (symbol-option + (lambda (argument) + (cond ((memq argument '(#F FALSE NIL)) false) + ((symbol? argument) argument) + (else (error "Illegal structure option:" option)))))) + (let ((check-argument + (lambda () + (if (not (= n-arguments 1)) + (error + (if (= n-arguments 0) + "Structure option requires an argument:" + "Structure option accepts at most 1 argument:") + option)))) + (check-arguments + (lambda (max) + (if (> n-arguments max) + (error (string-append + "Structure option accepts at most " + (number->string max) + " arguments:") + option))))) + (case keyword + ((CONC-NAME) + (check-duplicate) + (check-argument) + (set! conc-name (symbol-option (car arguments)))) + ((CONSTRUCTOR) + (check-arguments 2) + (if (null? arguments) + (set! boa-constructors + (cons (list option (symbol-append 'MAKE- name)) + boa-constructors)) + (let ((name (car arguments))) + (if (memq name '(#F FALSE NIL)) + (set! default-constructor-disabled? true) + (set! boa-constructors + (cons (cons option arguments) + boa-constructors)))))) + ((KEYWORD-CONSTRUCTOR) + (check-arguments 1) + (set! keyword-constructors + (cons (list option + (if (null? arguments) + (symbol-append 'MAKE- name) + (car arguments))) + keyword-constructors))) + ((COPIER) + (check-duplicate) + (check-arguments 1) + (set! copier-name + (if (null? arguments) + (symbol-append 'COPY- name) + (symbol-option (car arguments))))) + ((PREDICATE) + (check-duplicate) + (check-arguments 1) + (set! predicate-name + (if (null? arguments) + (symbol-append name '?) + (symbol-option (car arguments))))) + ((PRINT-PROCEDURE) + (check-duplicate) + (check-argument) + (set! print-procedure + (and (not (memq (car arguments) '(#F FALSE NIL))) + (car arguments)))) + ((TYPE) + (check-duplicate) + (check-argument) + (if (not (memq (car arguments) '(VECTOR LIST))) + (error "Illegal structure option:" option)) + (set! type (car arguments))) + ((NAMED) + (check-duplicate) + (check-arguments 1) + (if (null? arguments) + (begin + (set! type-name name) + (set! tag-expression type-name)) + (begin + (set! type-name false) + (set! tag-expression (car arguments))))) + ((INITIAL-OFFSET) + (check-duplicate) + (check-argument) + (if (not (exact-nonnegative-integer? (car arguments))) + (error "Illegal structure option:" option)) + (set! offset (car arguments))) + (else + (error "Unknown structure option:" option)))))))) + options) (let loop ((constructors (append boa-constructors keyword-constructors))) (if (not (null? constructors)) (begin (let ((name (cadar constructors))) (for-each (lambda (constructor) (if (eq? name (cadr constructor)) - (error "Conflicting constructor definitions" + (error "Conflicting constructor definitions:" (caar constructors) (car constructor)))) (cdr constructors))) (loop (cdr constructors))))) - (vector structure - name - conc-name - false - (map cdr keyword-constructors) - (cond ((or (not (null? boa-constructors)) - (not (null? keyword-constructors))) - (map cdr boa-constructors)) - ((not default-constructor-disabled?) - (list (list (symbol-append 'make- name)))) - (else - '())) - copier-name - predicate-name - (if (eq? print-procedure default-value) - `(,(absolute 'UNPARSER/STANDARD-METHOD) ',name) - print-procedure) - type - (cond ((eq? type 'STRUCTURE) 'VECTOR) - ((eq? type 'VECTOR) 'VECTOR) - ((eq? type 'LIST) 'LIST) - ((eq? type 'RECORD) 'RECORD) - (else (error "Unsupported structure type" type))) - (and (or (not type-seen?) named-seen?) - (if (eq? tag-name default-value) 'DEFAULT true)) - (if (eq? tag-name default-value) - name - tag-name) - (if (and (eq? type 'RECORD) (not (zero? offset))) - (error "Offset not allowed for record type structures" offset) - offset) - include - '()))) - -(define default-value - "default") + (let ((type-seen? (assq 'TYPE options-seen)) + (named-seen? (assq 'NAMED options-seen))) + (let ((named? (or (not type-seen?) named-seen?))) + (if (not type-seen?) + (begin + (if (and named-seen? (not type-name)) + (error "Illegal structure option:" (cdr named-seen?))) + (let ((initial-offset-seen? (assq 'INITIAL-OFFSET options-seen))) + (if initial-offset-seen? + (error "Structure option illegal without TYPE option:" + (cdr initial-offset-seen?)))))) + (if (not named?) + (let ((check + (lambda (option-seen) + (if option-seen + (error + "Structure option illegal for unnamed structure:" + (cdr option-seen)))))) + (if predicate-name + (check (assq 'PREDICATE options-seen))) + (if print-procedure + (check (assq 'PRINT-PROCEDURE options-seen))))) + (make-structure name + conc-name + (map cdr keyword-constructors) + (cond ((or (not (null? boa-constructors)) + (not (null? keyword-constructors))) + (map cdr boa-constructors)) + ((not default-constructor-disabled?) + (list (list (symbol-append 'MAKE- name)))) + (else + '())) + copier-name + (and named? predicate-name) + (and named? print-procedure) + type + named? + (and named? type-name) + (and named? tag-expression) + offset + slots))))) ;;;; Parse Slot-Descriptions -(define (parse/slot-descriptions structure slot-descriptions) - (define (loop slot-descriptions index) - (if (null? slot-descriptions) - '() - (cons (parse/slot-description structure (car slot-descriptions) index) - (loop (cdr slot-descriptions) (1+ index))))) - (loop slot-descriptions - (if (structure/named? structure) - (1+ (structure/offset structure)) - (structure/offset structure)))) - -(define (parse/slot-description structure slot-description index) - structure - (let ((kernel - (lambda (name default options) - (if (not (list? options)) - (error "Structure slot options must be a list" options)) - (let ((type #T) (read-only? false)) - (define (with-option-type-and-argument options receiver) - (if (null? (cdr options)) - (error "DEFINE-STRUCTURE -- Argument to option not given" - (car options)) - (receiver (car options) (cadr options)))) - (let loop ((options options)) - (if (not (null? options)) - (begin - (case (car options) - ((TYPE) - (set! type - (with-option-type-and-argument options - (lambda (type arg) - (parse/option-value symbol? - type - arg - true))))) - ((READ-ONLY) - (set! read-only? - (with-option-type-and-argument options - (lambda (type arg) - (parse/option-value boolean? - type - arg - true))))) - (else - (error "Unrecognized structure slot option" - (car options)))) - (loop (cddr options))))) - (vector name index default type read-only?))))) - (if (pair? slot-description) - (if (pair? (cdr slot-description)) - (kernel (car slot-description) - (cadr slot-description) - (cddr slot-description)) - (kernel (car slot-description) false '())) - (kernel slot-description false '())))) - -(define (parse/option-value predicate keyword option default) - (case option - ((FALSE NIL) - #F) - ((TRUE T) - default) - (else - (if (not (or (predicate option) - (not option) - (eq? option default))) - (error "Structure option has incorrect type" keyword option)) - option))) +(define (parse/slot-description slot-description) + (with-values + (lambda () + (if (pair? slot-description) + (if (pair? (cdr slot-description)) + (values (car slot-description) + (cadr slot-description) + (cddr slot-description)) + (values (car slot-description) false '())) + (values slot-description false '()))) + (lambda (name default options) + (if (not (list? options)) + (error "Structure slot options must be a list" options)) + (let ((type true) + (read-only? false) + (options-seen '())) + (do ((options options (cddr options))) + ((null? options)) + (if (null? (cdr options)) + (error "Missing slot option argument:" (car options))) + (let ((previous (assq (car options) options-seen)) + (option (list (car options) (cadr options)))) + (if previous + (error "Duplicate slot option:" previous option)) + (set! options-seen (cons option options-seen)) + (case (car options) + ((TYPE) + (set! type + (let ((argument (cadr options))) + (cond ((memq argument '(#T TRUE T)) true) + ((symbol? argument) argument) + (else (error "Illegal slot option:" option)))))) + ((READ-ONLY) + (set! read-only? + (let ((argument (cadr options))) + (cond ((memq argument '(#F FALSE NIL)) false) + ((memq argument '(#T TRUE T)) true) + (else (error "Illegal slot option:" option)))))) + (else + (error "Unrecognized structure slot option:" option))))) + (make-slot name default type read-only?))))) ;;;; Descriptive Structure -(let-syntax - ((define-structure-refs - (macro (name reserved . slots) - (define (loop slots n) - (if (null? slots) - '() - (cons - (let ((ref-name (symbol-append name '/ (car slots))) - (set-name (symbol-append name '/set- (car slots) '!))) - `(BEGIN - (DECLARE (INTEGRATE-OPERATOR ,ref-name ,set-name)) - (DEFINE (,ref-name ,name) - (DECLARE (INTEGRATE ,name)) - (VECTOR-REF ,name ,n)) - (DEFINE (,set-name ,name ,(car slots)) - (DECLARE (INTEGRATE ,name ,(car slots))) - (VECTOR-SET! ,name ,n ,(car slots))))) - (loop (cdr slots) (1+ n))))) - `(BEGIN ,@(loop slots reserved))))) - - (define-structure-refs structure 1 - name - conc-name - *dummy* - keyword-constructors - boa-constructors - copier-name - predicate-name - print-procedure - type - scheme-type - named? - tag-name - offset - include - slots) - - (define-structure-refs slot 0 - name - index - default - type - read-only?)) - -(define-integrable structure - ((ucode-primitive string->symbol) "#[defstruct-description]")) +(define structure-rtd + (make-record-type "structure" + '(NAME + CONC-NAME + KEYWORD-CONSTRUCTORS + BOA-CONSTRUCTORS + COPIER-NAME + PREDICATE-NAME + PRINT-PROCEDURE + TYPE + NAMED? + TYPE-NAME + TAG-EXPRESSION + OFFSET + SLOTS))) -(define slot-assoc) +(define make-structure + (record-constructor structure-rtd)) -(define (structure? object) - (and (vector? object) - (not (zero? (vector-length object))) - (eq? structure (vector-ref object 0)))) - -(define (tag->structure tag) - (if (structure? tag) - tag - (named-structure/get-tag-description tag))) - -(define record-type-name-tag - ((ucode-primitive string->symbol) "#[defstruct-tag]")) - -(unparser/set-tagged-vector-method! record-type-name-tag - (lambda (state record-type-name) - (unparse-object - state - (record-type-name->tag-name record-type-name)))) - -(define-integrable (make-record-type-name structure-descriptor) - (vector - record-type-name-tag - (structure/tag-name structure-descriptor) - structure-descriptor)) - -(define-integrable (record-type-name->tag-name type-name) - (and (vector? type-name) - (= 3 (vector-length type-name)) - (vector-second type-name))) - -(define-integrable (record-type-name->structure-descriptor type-name) - (and (vector? type-name) - (= 3 (vector-length type-name)) - (vector-third type-name))) - -(define-integrable (record-is-structure? record) - (eq? (record-type-name->structure-descriptor record) - record-type-name-tag)) +(define structure? + (record-predicate structure-rtd)) -(define (named-structure? object) - (let ((object - (cond ((and (record? object) (record-is-structure? object)) - (tag->structure - (record-type-name->structure-descriptor - (record-type-name (record-type-descriptor object))))) - ((vector? object) - (and (not (zero? (vector-length object))) - (tag->structure (vector-ref object 0)))) - ((pair? object) - (tag->structure (car object))) - (else false)))) - (or (structure? object) - (procedure? object)))) - -(define (named-structure/description instance) - (let ((structure - (tag->structure - (cond ((vector? instance) (vector-ref instance 0)) - ((pair? instance) (car instance)) - ((record? instance) - (record-type-name->structure-descriptor - (record-type-name (record-type-descriptor instance)))) - (else (error "Illegal structure instance" instance)))))) - (cond ((structure? structure) - (let ((scheme-type (structure/scheme-type structure))) - (if (not (case scheme-type - ((VECTOR) (vector? instance)) - ((LIST) (list? instance)) - ((RECORD) (record? instance)) - (else (error "Illegal structure type" scheme-type)))) - (error "Malformed structure instance" instance)) - (let ((accessor - (case scheme-type - ((VECTOR) - (lambda (instance slot) - (vector-ref instance (slot/index slot)))) - ((LIST) - (lambda (instance slot) - (list-ref instance (slot/index slot)))) - ((RECORD) - (lambda (instance slot) - ((record-accessor - (structure/type structure) - (slot/name slot)) - instance)))))) - (map (lambda (slot) - `(,(slot/name slot) - ,(accessor instance slot))) - (structure/slots structure))))) - ((procedure? structure) - (structure instance)) - (else - (error "Illegal structure instance" instance))))) +(define structure/name + (record-accessor structure-rtd 'NAME)) + +(define structure/conc-name + (record-accessor structure-rtd 'CONC-NAME)) + +(define structure/keyword-constructors + (record-accessor structure-rtd 'KEYWORD-CONSTRUCTORS)) + +(define structure/boa-constructors + (record-accessor structure-rtd 'BOA-CONSTRUCTORS)) + +(define structure/copier-name + (record-accessor structure-rtd 'COPIER-NAME)) + +(define structure/predicate-name + (record-accessor structure-rtd 'PREDICATE-NAME)) + +(define structure/print-procedure + (record-accessor structure-rtd 'PRINT-PROCEDURE)) + +(define structure/type + (record-accessor structure-rtd 'TYPE)) + +(define structure/named? + (record-accessor structure-rtd 'NAMED?)) + +(define structure/type-name + (record-accessor structure-rtd 'TYPE-NAME)) + +(define structure/tag-expression + (record-accessor structure-rtd 'TAG-EXPRESSION)) + +(define structure/offset + (record-accessor structure-rtd 'OFFSET)) + +(define structure/slots + (record-accessor structure-rtd 'SLOTS)) + +(define slot-rtd + (make-record-type "slot" '(NAME DEFAULT TYPE READ-ONLY? INDEX))) + +(define make-slot + (record-constructor slot-rtd '(NAME DEFAULT TYPE READ-ONLY?))) + +(define slot/name (record-accessor slot-rtd 'NAME)) +(define slot/default (record-accessor slot-rtd 'DEFAULT)) +(define slot/type (record-accessor slot-rtd 'TYPE)) +(define slot/read-only? (record-accessor slot-rtd 'READ-ONLY?)) +(define slot/index (record-accessor slot-rtd 'INDEX)) +(define set-slot/index! (record-modifier slot-rtd 'INDEX)) + +(define slot-assoc) ;;;; Code Generation @@ -482,70 +429,51 @@ must be defined when the defstruct is evaluated. `(ACCESS ,name #F)) (define (accessor-definitions structure) + (map (lambda (slot) + `(DEFINE-INTEGRABLE + (,(if (structure/conc-name structure) + (symbol-append (structure/conc-name structure) + (slot/name slot)) + (slot/name slot)) + STRUCTURE) + (,(absolute + (case (structure/type structure) + ((RECORD) '%RECORD-REF) + ((VECTOR) 'VECTOR-REF) + ((LIST) 'LIST-REF))) + STRUCTURE + ,(slot/index slot)))) + (structure/slots structure))) + +(define (modifier-definitions structure) (append-map! (lambda (slot) - (let ((accessor-name - (if (structure/conc-name structure) - (symbol-append (structure/conc-name structure) - (slot/name slot)) - (slot/name slot)))) - (if (eq? (structure/scheme-type structure) 'RECORD) - `((DECLARE (INTEGRATE-OPERATOR ,accessor-name)) - (DEFINE ,accessor-name - (,(absolute 'RECORD-ACCESSOR) - ,(structure/type structure) - ',(slot/name slot)))) - `((DECLARE (INTEGRATE-OPERATOR ,accessor-name)) - (DEFINE (,accessor-name STRUCTURE) - (DECLARE (INTEGRATE STRUCTURE)) - ,(case (structure/scheme-type structure) - ((VECTOR) - `(,(absolute 'VECTOR-REF) - STRUCTURE - ,(slot/index slot))) - ((LIST) - `(,(absolute 'LIST-REF) - STRUCTURE - ,(slot/index slot))) - (error "Unknown scheme type" structure))))))) + (if (slot/read-only? slot) + '() + `((DEFINE-INTEGRABLE + (,(if (structure/conc-name structure) + (symbol-append 'SET- + (structure/conc-name structure) + (slot/name slot) + '!) + (symbol-append 'SET- (slot/name slot) '!)) + STRUCTURE + VALUE) + ,(case (structure/type structure) + ((RECORD) + `(,(absolute '%RECORD-SET!) STRUCTURE + ,(slot/index slot) + VALUE)) + ((VECTOR) + `(,(absolute 'VECTOR-SET!) STRUCTURE + ,(slot/index slot) + VALUE)) + ((LIST) + `(,(absolute 'SET-CAR!) + (,(absolute 'LIST-TAIL) STRUCTURE + ,(slot/index slot)) + VALUE))))))) (structure/slots structure))) -(define (settor-definitions structure) - (append-map! - (lambda (slot) - (if (slot/read-only? slot) - '() - (let ((settor-name - (if (structure/conc-name structure) - (symbol-append 'SET- - (structure/conc-name structure) - (slot/name slot) - '!) - (symbol-append 'SET- - (slot/name slot) - '!)))) - (if (eq? (structure/scheme-type structure) 'RECORD) - `((DECLARE (INTEGRATE-OPERATOR ,settor-name)) - (DEFINE ,settor-name - (,(absolute 'RECORD-UPDATER) - ,(structure/type structure) - ',(slot/name slot)))) - `((DECLARE (INTEGRATE-OPERATOR ,settor-name)) - (DEFINE (,settor-name STRUCTURE VALUE) - (DECLARE (INTEGRATE STRUCTURE VALUE)) - ,(case (structure/scheme-type structure) - ((VECTOR) - `(,(absolute 'VECTOR-SET!) STRUCTURE - ,(slot/index slot) - VALUE)) - ((LIST) - `(,(absolute 'SET-CAR!) - (,(absolute 'LIST-TAIL) STRUCTURE - ,(slot/index slot)) - VALUE)) - (else - (error "Unknown scheme type" structure))))))))) - (structure/slots structure))) - (define (constructor-definitions structure) `(,@(map (lambda (boa-constructor) (if (null? (cdr boa-constructor)) @@ -565,24 +493,20 @@ must be defined when the defstruct is evaluated. (map (lambda (slot) (string->uninterned-symbol (symbol->string (slot/name slot)))) (structure/slots structure)))) - (if (eq? (structure/scheme-type structure) 'RECORD) - `(DEFINE ,name - (,(absolute 'RECORD-CONSTRUCTOR) - ,(structure/type structure) - ',(map slot/name - (structure/slots structure)))) - `(DEFINE (,name ,@slot-names) - ;; *** Kludge -- SCHEME-TYPE happens to be same as constructor. - (,(absolute (structure/scheme-type structure)) - ,@(constructor-prefix-slots structure) - ,@slot-names))))) + `(DEFINE (,name ,@slot-names) + (,(absolute + (case (structure/type structure) + ((RECORD) '%RECORD) + ((VECTOR) 'VECTOR) + ((LIST) 'LIST))) + ,@(constructor-prefix-slots structure) + ,@slot-names)))) (define (constructor-definition/keyword structure name) (let ((keyword-list (string->uninterned-symbol "keyword-list"))) `(DEFINE (,name . ,keyword-list) ,(let ((list-cons - `(,(absolute 'CONS*) - ,@(constructor-prefix-slots structure) + `(,@(constructor-prefix-slots structure) (,(absolute 'DEFINE-STRUCTURE/KEYWORD-PARSER) ,keyword-list (,(absolute 'LIST) @@ -590,16 +514,13 @@ must be defined when the defstruct is evaluated. `(,(absolute 'CONS) ',(slot/name slot) ,(slot/default slot))) (structure/slots structure))))))) - (case (structure/scheme-type structure) + (case (structure/type structure) + ((RECORD) + `(,(absolute 'APPLY) ,(absolute '%RECORD) ,@list-cons)) ((VECTOR) - `(,(absolute 'LIST->VECTOR) ,list-cons)) + `(,(absolute 'APPLY) ,(absolute 'VECTOR) ,@list-cons)) ((LIST) - list-cons) - ((RECORD) - `((,(absolute 'RECORD-CONSTRUCTOR) (structure/type structure)) - ,list-cons)) - (else - (error "Unknown scheme type" structure))))))) + `(,(absolute 'CONS*) ,@list-cons))))))) (define (define-structure/keyword-parser argument-list default-alist) (if (null? argument-list) @@ -620,8 +541,14 @@ must be defined when the defstruct is evaluated. (map cdr alist)))) (define (constructor-definition/boa structure name lambda-list) - (let ((handle-defaults - (parse-lambda-list lambda-list + `(DEFINE (,name . ,lambda-list) + (,(absolute + (case (structure/type structure) + ((RECORD) '%RECORD) + ((VECTOR) 'VECTOR) + ((LIST) 'LIST))) + ,@(constructor-prefix-slots structure) + ,@(parse-lambda-list lambda-list (lambda (required optional rest) (let ((name->slot (lambda (name) @@ -640,94 +567,146 @@ must be defined when the defstruct is evaluated. ,(slot/name slot))) (else (slot/default slot)))) - (structure/slots structure))))))) - (prefix-slots (constructor-prefix-slots structure)) - (scheme-type (structure/scheme-type structure))) - (if (eq? scheme-type 'RECORD) - `(DEFINE (,name . ,lambda-list) - (,((access RECORD-CONSTRUCTOR '()) - (structure/type structure)) - ,@handle-defaults)) - `(DEFINE (,name . ,lambda-list) - ;; *** Kludge -- SCHEME-TYPE happens to be same as constructor. - (,(absolute scheme-type) - ,@prefix-slots - ,@handle-defaults))))) + (structure/slots structure))))))))) (define (constructor-prefix-slots structure) (let ((offsets (make-list (structure/offset structure) false))) (if (structure/named? structure) - (cons (structure/tag-name structure) offsets) + (cons (structure/tag-expression structure) offsets) offsets))) -(define (type-definitions structure) - (cond ((not (structure/named? structure)) - '()) - ((eq? (structure/named? structure) 'DEFAULT) - `((DEFINE ,(structure/tag-name structure) - ',structure))) - (else - `((NAMED-STRUCTURE/SET-TAG-DESCRIPTION! - ,(structure/tag-name structure) - ',structure))))) - -(define (predicate-definitions structure) - (if (and (structure/predicate-name structure) - (structure/named? structure)) - (let ((variable (string->uninterned-symbol "object"))) - (case (structure/scheme-type structure) - ((VECTOR) - `((DEFINE (,(structure/predicate-name structure) ,variable) - (AND (,(absolute 'VECTOR?) ,variable) - (,(absolute 'NOT) - (,(absolute 'ZERO?) - (,(absolute 'VECTOR-LENGTH) ,variable))) - (,(absolute 'EQ?) (,(absolute 'VECTOR-REF) ,variable 0) - ,(structure/tag-name structure)))))) - ((LIST) - `((DEFINE (,(structure/predicate-name structure) ,variable) - (AND (,(absolute 'PAIR?) ,variable) - (,(absolute 'EQ?) (,(absolute 'CAR) ,variable) - ,(structure/tag-name structure)))))) - ((RECORD) - `((DEFINE ,(structure/predicate-name structure) - (,(absolute 'RECORD-PREDICATE) - ,(structure/type structure))))) - (else - (error "Unknown scheme type" structure)))) - '())) - (define (copier-definitions structure) (let ((copier-name (structure/copier-name structure))) (if copier-name - `((DECLARE (INTEGRATE-OPERATOR ,copier-name)) - ,(case (structure/scheme-type structure) - ((VECTOR) - `(DEFINE (,copier-name OBJECT) - (DECLARE (INTEGRATE OBJECT)) - (,(absolute 'VECTOR-COPY) OBJECT))) - ((LIST) - `(DEFINE (,copier-name OBJECT) - (DECLARE (INTEGRATE OBJECT)) - (,(absolute 'LIST-COPY) OBJECT))) - ((RECORD) - (error "No copiers for record type structures" structure)) - (else - (error "Unknown scheme type" structure)))) + `((DEFINE ,copier-name + ,(absolute + (case (structure/type structure) + ((RECORD) 'RECORD-COPY) + ((VECTOR) 'VECTOR-COPY) + ((LIST) 'LIST-COPY))))) + '()))) + +(define (predicate-definitions structure) + (let ((predicate-name (structure/predicate-name structure))) + (if predicate-name + (let ((tag-expression (structure/tag-expression structure)) + (variable (string->uninterned-symbol "object"))) + `((DEFINE (,predicate-name ,variable) + ,(case (structure/type structure) + ((RECORD) + `(AND (,(absolute '%RECORD?) ,variable) + (,(absolute 'EQ?) + (,(absolute '%RECORD-REF) ,variable 0) + ,tag-expression))) + ((VECTOR) + `(AND (,(absolute 'VECTOR?) ,variable) + (,(absolute 'NOT) + (,(absolute 'ZERO?) + (,(absolute 'VECTOR-LENGTH) ,variable))) + (,(absolute 'EQ?) (,(absolute 'VECTOR-REF) ,variable 0) + ,tag-expression))) + ((LIST) + `(AND (,(absolute 'PAIR?) ,variable) + (,(absolute 'EQ?) (,(absolute 'CAR) ,variable) + ,tag-expression))))))) '()))) (define (print-procedure-definitions structure) - (if (and (structure/print-procedure structure) - (structure/named? structure)) - (let ((scheme-type (structure/scheme-type structure))) - `((,(absolute (case scheme-type - ((VECTOR) 'UNPARSER/SET-TAGGED-VECTOR-METHOD!) - ((LIST) 'UNPARSER/SET-TAGGED-PAIR-METHOD!) - ((RECORD) 'SET-RECORD-TYPE-UNPARSER-METHOD!) - (else (error "Unknown scheme type" structure)))) - ,((if (eq? scheme-type 'RECORD) - structure/type - structure/tag-name) - structure) - ,(structure/print-procedure structure)))) - '())) \ No newline at end of file + (let ((print-procedure (structure/print-procedure structure))) + (if (and print-procedure (eq? (structure/type structure) 'RECORD)) + `((,(absolute 'SET-RECORD-TYPE-UNPARSER-METHOD!) + ,(structure/type-name structure) + ,print-procedure)) + '()))) + +(define (type-definitions structure) + (if (structure/named? structure) + (let ((type (structure/type structure)) + (type-name (structure/type-name structure)) + (name (symbol->string (structure/name structure))) + (field-names (map slot/name (structure/slots structure)))) + (if (eq? type 'RECORD) + `((DEFINE ,type-name + (,(absolute 'MAKE-RECORD-TYPE) ',name ',field-names))) + (let ((type-expression + `(,(absolute 'MAKE-DEFINE-STRUCTURE-TYPE) + ',type + ',name + ',field-names + ',(map slot/index (structure/slots structure)) + ,(structure/print-procedure structure)))) + (if type-name + `((DEFINE ,type-name ,type-expression)) + `((NAMED-STRUCTURE/SET-TAG-DESCRIPTION! + ,(structure/tag-expression structure) + ,type-expression)))))) + '())) + +(define structure-type-rtd + (make-record-type "structure-type" + '(TYPE NAME FIELD-NAMES FIELD-INDEXES UNPARSER-METHOD))) + +(define make-define-structure-type + (record-constructor structure-type-rtd)) + +(define structure-type? + (record-predicate structure-type-rtd)) + +(define structure-type/type + (record-accessor structure-type-rtd 'TYPE)) + +(define structure-type/name + (record-accessor structure-type-rtd 'NAME)) + +(define structure-type/field-names + (record-accessor structure-type-rtd 'FIELD-NAMES)) + +(define structure-type/field-indexes + (record-accessor structure-type-rtd 'FIELD-INDEXES)) + +(define structure-type/unparser-method + (record-accessor structure-type-rtd 'UNPARSER-METHOD)) + +(define set-structure-type/unparser-method! + (record-modifier structure-type-rtd 'UNPARSER-METHOD)) + +(define (structure-tag/unparser-method tag type) + (let ((structure-type (tag->structure-type tag type))) + (and structure-type + (structure-type/unparser-method structure-type)))) + +(define (named-structure? object) + (cond ((record? object) + true) + ((vector? object) + (and (not (zero? (vector-length object))) + (tag->structure-type (vector-ref object 0) 'VECTOR))) + ((pair? object) + (tag->structure-type (car object) 'LIST)) + (else + false))) + +(define (named-structure/description structure) + (cond ((record? structure) + (record-description structure)) + ((named-structure? structure) + => + (lambda (type) + (let ((accessor (if (pair? structure) list-ref vector-ref))) + (map (lambda (field-name index) + `(,field-name ,(accessor structure index))) + (structure-type/field-names type) + (structure-type/field-indexes type))))) + (else + (error:wrong-type-argument structure "named structure" + 'NAMED-STRUCTURE/DESCRIPTION)))) + +(define (tag->structure-type tag type) + (if (structure-type? tag) + (and (eq? (structure-type/type tag) type) + tag) + (and (symbol? tag) + (let ((structure-type (named-structure/get-tag-description tag))) + (and (structure-type? structure-type) + (eq? (structure-type/type structure-type) type) + structure-type))))) \ No newline at end of file diff --git a/v7/src/runtime/events.scm b/v7/src/runtime/events.scm index 3437dc2cd..4d29ab5d2 100644 --- a/v7/src/runtime/events.scm +++ b/v7/src/runtime/events.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/events.scm,v 14.2 1991/04/25 14:40:13 markf Exp $ +$Id: events.scm,v 14.3 1992/12/07 19:06:44 cph Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988-92 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -39,17 +39,12 @@ MIT in each case. |# (define (initialize-package!) (set! add-event-receiver! (make-receiver-modifier 'ADD-RECEIVER)) - (set! remove-event-receiver! (make-receiver-modifier 'REMOVE-RECEIVER))) - -(define (initialize-unparser!) - (unparser/set-tagged-vector-method! - event-distributor - (unparser/standard-method 'EVENT-DISTRIBUTOR))) + (set! remove-event-receiver! (make-receiver-modifier 'REMOVE-RECEIVER)) + unspecific) (define-structure (event-distributor (constructor make-event-distributor ()) - (conc-name event-distributor/) - (print-procedure false)) + (conc-name event-distributor/)) (events (make-queue)) (lock false) (receivers '())) diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm index b108c313d..2857bc0d3 100644 --- a/v7/src/runtime/io.scm +++ b/v7/src/runtime/io.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.30 1992/04/16 05:12:27 jinx Exp $ +$Id: io.scm,v 14.31 1992/12/07 19:06:45 cph Exp $ Copyright (c) 1988-1992 Massachusetts Institute of Technology @@ -405,6 +405,8 @@ MIT in each case. |# (define (terminal-output-baud-rate channel) ((ucode-primitive baud-index->rate 1) ((ucode-primitive terminal-get-ospeed 1) (channel-descriptor channel)))) + +;;;; PTY Master Primitives (define (open-pty-master) (without-interrupts @@ -545,7 +547,8 @@ MIT in each case. |# buffer-size)) (lambda (logical-size string-size) (%make-output-buffer channel - (and (fix:> string-size 0) (make-string string-size)) + (and (fix:> string-size 0) + (make-string string-size)) 0 translation logical-size))))) @@ -776,7 +779,7 @@ MIT in each case. |# (define (input-buffer/buffered-chars buffer) (fix:- (input-buffer/end-index buffer) (input-buffer/start-index buffer))) - + (define (input-buffer/chars-remaining buffer) (let ((channel (input-buffer/channel buffer))) (and (channel-open? channel) @@ -785,7 +788,7 @@ MIT in each case. |# (let ((n (fix:- (file-length channel) (file-position channel)))) (and (fix:>= n 0) (fix:+ (input-buffer/buffered-chars buffer) n)))))) - + (define (input-buffer/char-ready? buffer interval) (char-ready? buffer (lambda (buffer) @@ -999,12 +1002,13 @@ MIT in each case. |# string start) (set-input-buffer/start-index! buffer end-index) (fix:+ available - (or (and (channel-open? (input-buffer/channel buffer)) + (or (and (channel-open? + (input-buffer/channel buffer)) (read-directly (fix:+ start available) end)) 0)))))) ((or (fix:= end-index 0) - (channel-closed? channel)) + (channel-closed? (input-buffer/channel buffer))) 0) (else (read-directly start end))))) diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index 949e94518..d491ad048 100644 --- a/v7/src/runtime/make.scm +++ b/v7/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: make.scm,v 14.38 1992/11/03 22:41:13 jinx Exp $ +$Id: make.scm,v 14.39 1992/12/07 19:06:47 cph Exp $ Copyright (c) 1988-1992 Massachusetts Institute of Technology @@ -261,39 +261,44 @@ MIT in each case. |# (eval (fasload "runtim.bcon" #f) system-global-environment) ;;; Global databases. Load, then initialize. -(let ((sine-qua-non +(let ((files1 '(("gcdemn" . (RUNTIME GC-DAEMONS)) - ("poplat" . (RUNTIME POPULATION)) - ("prop1d" . (RUNTIME 1D-PROPERTY)) - ("events" . (RUNTIME EVENT-DISTRIBUTOR)) - ("gdatab" . (RUNTIME GLOBAL-DATABASE)) + ("gc" . (RUNTIME GARBAGE-COLLECTOR)) ("boot" . ()) ("queue" . ()) - ("gc" . (RUNTIME GARBAGE-COLLECTOR)) ("equals" . ()) ("list" . (RUNTIME LIST)) - ("record" . (RUNTIME RECORD))))) - (let loop ((files sine-qua-non)) - (if (not (null? files)) - (begin - (eval (fasload (map-filename (car (car files))) #t) - (package-reference (cdr (car files)))) - (loop (cdr files))))) + ("symbol" . ()) + ("uproc" . (RUNTIME PROCEDURE)) + ("record" . (RUNTIME RECORD)))) + (files2 + '(("defstr" . (RUNTIME DEFSTRUCT)) + ("poplat" . (RUNTIME POPULATION)) + ("prop1d" . (RUNTIME 1D-PROPERTY)) + ("events" . (RUNTIME EVENT-DISTRIBUTOR)) + ("gdatab" . (RUNTIME GLOBAL-DATABASE)))) + (load-files + (lambda (files) + (do ((files files (cdr files))) + ((null? files)) + (eval (fasload (map-filename (car (car files))) #t) + (package-reference (cdr (car files)))))))) + (load-files files1) (package-initialize '(RUNTIME GC-DAEMONS) 'INITIALIZE-PACKAGE! true) - (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE! true) - (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE! true) - (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE! true) - (package-initialize '(RUNTIME GLOBAL-DATABASE) 'INITIALIZE-PACKAGE! true) - (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER! true) - (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER! true) - (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-UNPARSER! true) - (package-initialize '(PACKAGE) 'INITIALIZE-UNPARSER! true) (package-initialize '(RUNTIME GARBAGE-COLLECTOR) 'INITIALIZE-PACKAGE! true) (lexical-assignment (package-reference '(RUNTIME GARBAGE-COLLECTOR)) 'CONSTANT-SPACE/BASE constant-space/base) (package-initialize '(RUNTIME LIST) 'INITIALIZE-PACKAGE! true) (package-initialize '(RUNTIME RECORD) 'INITIALIZE-PACKAGE! true) + (package-initialize '(PACKAGE) 'FINALIZE-PACKAGE-RECORD-TYPE! true) + (load-files files2) + (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE! true) + (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE! true) + (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE! true) + (package-initialize '(RUNTIME GLOBAL-DATABASE) 'INITIALIZE-PACKAGE! true) + (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER! true) + (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER! true) ;; Load everything else. ;; Note: The following code needs MAP* and MEMBER-PROCEDURE @@ -307,7 +312,7 @@ MIT in each case. |# (fasload "runtim.bad" #f) '()) car - sine-qua-non))) + (append files1 files2)))) (string-member? (member-procedure string=?))) (lambda (filename environment) (if (not (string-member? filename to-avoid)) diff --git a/v7/src/runtime/packag.scm b/v7/src/runtime/packag.scm index ac41188f3..2cae8e832 100644 --- a/v7/src/runtime/packag.scm +++ b/v7/src/runtime/packag.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: packag.scm,v 14.11 1992/11/29 14:18:20 gjr Exp $ +$Id: packag.scm,v 14.12 1992/12/07 19:06:51 cph Exp $ Copyright (c) 1988-1992 Massachusetts Institute of Technology @@ -37,15 +37,50 @@ MIT in each case. |# (declare (usual-integrations)) -(define-structure (package - (constructor make-package (parent %name environment)) - (conc-name package/) - (print-procedure false)) - (parent false read-only true) - (children '()) - (%name false read-only true) - (environment false read-only true)) +;;; Kludge -- package objects want to be records, but this file must +;;; be loaded first, before the record package. The way we solve this +;;; problem is to build the initial packages without an appropriate +;;; record type, then build the record type and clobber it into the +;;; packages. Thereafter, packages are constructed normally. +(define package-rtd + false) + +(define-integrable (make-package parent name environment) + (%record package-rtd parent '() name environment)) + +(define (package? object) + (and (%record? object) + (eq? (%record-ref object 0) package-rtd))) + +(define-integrable (package/parent package) + (%record-ref package 1)) + +(define-integrable (package/children package) + (%record-ref package 2)) + +(define-integrable (set-package/children! package children) + (%record-set! package 2 children)) + +(define-integrable (package/%name package) + (%record-ref package 3)) + +(define-integrable (package/environment package) + (%record-ref package 4)) + +(define (finalize-package-record-type!) + (let ((rtd + (make-record-type "package" '(PARENT CHILDREN %NAME ENVIRONMENT)))) + (set! package-rtd rtd) + (let loop ((package system-global-package)) + (%record-set! package 0 rtd) + (for-each loop (package/children package))) + (set-record-type-unparser-method! + rtd + (unparser/standard-method 'PACKAGE + (lambda (state package) + (unparse-object state (package/name package))))))) + (define (package/child package name) (let loop ((children (package/children package))) (and (not (null? children)) @@ -144,10 +179,4 @@ MIT in each case. |# (make-package false false system-global-environment)) (local-assignment system-global-environment package-name-tag - system-global-package)) - -(define (initialize-unparser!) - (unparser/set-tagged-vector-method! package - (unparser/standard-method 'PACKAGE - (lambda (state package) - (unparse-object state (package/name package)))))) \ No newline at end of file + system-global-package)) \ No newline at end of file diff --git a/v7/src/runtime/record.scm b/v7/src/runtime/record.scm index eff493c93..9f52c2813 100644 --- a/v7/src/runtime/record.scm +++ b/v7/src/runtime/record.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: record.scm,v 1.16 1992/12/02 20:30:00 cph Exp $ +$Id: record.scm,v 1.17 1992/12/07 19:06:52 cph Exp $ Copyright (c) 1989-1992 Massachusetts Institute of Technology @@ -49,165 +49,207 @@ MIT in each case. |# (define-integrable (%record? object) (object-type? (ucode-type record) object)) -(define (initialize-package!) - (set! record-type-marker - ((ucode-primitive string->symbol) - "#[(runtime record)record-type-marker]")) - (unparser/set-tagged-vector-method! - record-type-marker - (unparser/standard-method 'RECORD-TYPE-DESCRIPTOR - (lambda (state record-type) - (unparse-object state (record-type-name record-type))))) - (named-structure/set-tag-description! record-type-marker - (lambda (record-type) - (if (not (record-type? record-type)) - (error:wrong-type-argument record-type "record type" false)) - `((TYPE-NAME ,(record-type-name record-type)) - (FIELD-NAMES ,(record-type-field-names record-type)))))) +(define (%make-record length #!optional object) + (if (not (exact-integer? length)) + (error:wrong-type-argument length "exact integer" '%MAKE-RECORD)) + (if (not (> length 0)) + (error:bad-range-argument length '%MAKE-RECORD)) + (if (default-object? object) + (object-new-type (ucode-type record) (make-vector length)) + (object-new-type (ucode-type record) (make-vector length object)))) + +(define (%record-copy record) + (let ((length (%record-length record))) + (let ((result (object-new-type (ucode-type record) (make-vector length)))) + (do ((index 0 (+ index 1))) + ((= index length)) + (%record-set! result index (%record-ref record index))) + result))) -(define record-type-marker) - (define (make-record-type type-name field-names) - (let ((record-type - (vector record-type-marker type-name (list-copy field-names)))) - (unparser/set-tagged-vector-method! record-type - (unparser/standard-method type-name)) - (named-structure/set-tag-description! record-type - (letrec ((description - (let ((predicate (record-predicate record-type))) - (lambda (record) - (if (not (predicate record)) - (record-type-error record record-type description)) - (map (lambda (field-name) - (list field-name - (vector-ref - record - (record-type-field-index record-type - field-name - description)))) - (vector-ref record-type 2)))))) - description)) - record-type)) + (guarantee-list-of-unique-symbols field-names 'MAKE-RECORD-TYPE) + (%record record-type-type + false + (->string type-name) + (list-copy field-names) + false)) (define (record-type? object) - (and (vector? object) - (fix:= (vector-length object) 3) - (eq? (vector-ref object 0) record-type-marker))) + (and (%record? object) + (eq? (%record-ref object 0) record-type-type))) + +(define (record-type-application-method record-type) + (guarantee-record-type record-type 'RECORD-TYPE-APPLICATION-METHOD) + (%record-ref record-type 1)) + +(define (set-record-type-application-method! record-type method) + (guarantee-record-type record-type 'SET-RECORD-TYPE-APPLICATION-METHOD!) + (if (not (or (not method) (procedure? method))) + (error:wrong-type-argument method "application method" + 'SET-RECORD-TYPE-APPLICATION-METHOD!)) + (%record-set! record-type 1 method)) (define (record-type-name record-type) - (if (not (record-type? record-type)) - (error:wrong-type-argument record-type "record type" 'RECORD-TYPE-NAME)) - (vector-ref record-type 1)) + (guarantee-record-type record-type 'RECORD-TYPE-NAME) + (%record-type/name record-type)) + +(define-integrable (%record-type/name record-type) + (%record-ref record-type 2)) (define (record-type-field-names record-type) - (if (not (record-type? record-type)) - (error:wrong-type-argument record-type "record type" - 'RECORD-TYPE-FIELD-NAMES)) - (list-copy (vector-ref record-type 2))) + (guarantee-record-type record-type 'RECORD-TYPE-FIELD-NAMES) + (list-copy (%record-type/field-names record-type))) + +(define-integrable (%record-type/field-names record-type) + (%record-ref record-type 3)) -(define (record-type-record-length record-type) - (fix:+ (length (vector-ref record-type 2)) 1)) +(define (record-type-unparser-method record-type) + (guarantee-record-type record-type 'RECORD-TYPE-UNPARSER-METHOD) + (%record-type/unparser-method record-type)) + +(define-integrable (%record-type/unparser-method record-type) + (%record-ref record-type 4)) + +(define (set-record-type-unparser-method! record-type method) + (guarantee-record-type record-type 'SET-RECORD-TYPE-UNPARSER-METHOD!) + (if (not (or (not method) (unparser-method? method))) + (error:wrong-type-argument method "unparser method" + 'SET-RECORD-TYPE-UNPARSER-METHOD!)) + (%record-set! record-type 4 method)) + +(define record-type-type) + +(define (initialize-package!) + (set! record-type-type + (let ((record-type-type + (%record false + false + "record-type" + '(RECORD-TYPE-APPLICATION-METHOD + RECORD-TYPE-NAME + RECORD-TYPE-FIELD-NAMES + RECORD-TYPE-UNPARSER-METHOD) + false))) + (%record-set! record-type-type 0 record-type-type) + record-type-type)) + unspecific) (define (record-type-field-index record-type field-name procedure-name) - (let loop ((field-names (vector-ref record-type 2)) (index 1)) + (let loop ((field-names (%record-type/field-names record-type)) (index 1)) (if (null? field-names) (error:bad-range-argument field-name procedure-name)) (if (eq? field-name (car field-names)) index - (loop (cdr field-names) (fix:+ index 1))))) - -(define (record-type-error record record-type procedure) - (error:wrong-type-argument - record - (string-append "record of type " - (let ((type-name (vector-ref record-type 1))) - (if (string? type-name) - type-name - (write-to-string type-name)))) - procedure)) - -(define (set-record-type-unparser-method! record-type method) - (if (not (record-type? record-type)) - (error:wrong-type-argument record-type "record type" - 'SET-RECORD-TYPE-UNPARSER-METHOD!)) - (unparser/set-tagged-vector-method! record-type method)) + (loop (cdr field-names) (+ index 1))))) (define (record-constructor record-type #!optional field-names) - (if (not (record-type? record-type)) - (error:wrong-type-argument record-type "record type" - 'RECORD-CONSTRUCTOR)) - (let ((field-names - (if (default-object? field-names) - (vector-ref record-type 2) - field-names))) - (let ((record-length (record-type-record-length record-type)) - (number-of-inits (length field-names)) - (indexes - (map (lambda (field-name) - (record-type-field-index record-type - field-name - 'RECORD-CONSTRUCTOR)) - field-names))) - (lambda field-values - (if (not (fix:= (length field-values) number-of-inits)) - (error "wrong number of arguments to record constructor" - field-values record-type field-names)) - (let ((record (make-vector record-length))) - (vector-set! record 0 record-type) - (for-each (lambda (index value) (vector-set! record index value)) - indexes - field-values) - record))))) + (guarantee-record-type record-type 'RECORD-CONSTRUCTOR) + (let ((all-field-names (%record-type/field-names record-type))) + (let ((field-names + (if (default-object? field-names) all-field-names field-names)) + (record-length (+ 1 (length all-field-names)))) + (let ((number-of-inits (length field-names)) + (indexes + (map (lambda (field-name) + (record-type-field-index record-type + field-name + 'RECORD-CONSTRUCTOR)) + field-names))) + (lambda field-values + (if (not (= (length field-values) number-of-inits)) + (error "wrong number of arguments to record constructor" + field-values record-type field-names)) + (let ((record + (object-new-type (ucode-type record) + (make-vector record-length)))) + (%record-set! record 0 record-type) + (do ((indexes indexes (cdr indexes)) + (field-values field-values (cdr field-values))) + ((null? indexes)) + (%record-set! record (car indexes) (car field-values))) + record)))))) (define (record? object) - (and (vector? object) - (fix:> (vector-length object) 0) - (record-type? (vector-ref object 0)))) + (and (%record? object) + (record-type? (%record-ref object 0)))) (define (record-type-descriptor record) - (if (not (record? record)) - (error:wrong-type-argument record "record" 'RECORD-TYPE-DESCRIPTOR)) - (vector-ref record 0)) + (guarantee-record record 'RECORD-TYPE-DESCRIPTOR) + (%record-ref record 0)) (define (record-copy record) - (vector-copy record)) + (guarantee-record record 'RECORD-COPY) + (%record-copy record)) + +(define (%record-unparser-method record) + ;; Used by unparser. Assumes RECORD has type-code RECORD. + (let ((type (%record-ref record 0))) + (and (record-type? type) + (or (%record-type/unparser-method type) + (unparser/standard-method (record-type-name type)))))) + +(define (record-description record) + (let ((type (record-type-descriptor record))) + (map (lambda (field-name) + `(,field-name ,((record-accessor type field-name) record))) + (record-type-field-names type)))) (define (record-predicate record-type) - (if (not (record-type? record-type)) - (error:wrong-type-argument record-type "record type" 'RECORD-PREDICATE)) - (let ((record-length (record-type-record-length record-type))) - (lambda (object) - (and (vector? object) - (fix:= (vector-length object) record-length) - (eq? (vector-ref object 0) record-type))))) + (guarantee-record-type record-type 'RECORD-PREDICATE) + (lambda (object) + (and (%record? object) + (eq? (%record-ref object 0) record-type)))) (define (record-accessor record-type field-name) - (if (not (record-type? record-type)) - (error:wrong-type-argument record-type "record type" 'RECORD-ACCESSOR)) - (let ((record-length (record-type-record-length record-type)) - (procedure-name `(RECORD-ACCESSOR ,record-type ',field-name)) + (guarantee-record-type record-type 'RECORD-ACCESSOR) + (let ((procedure-name `(RECORD-ACCESSOR ,record-type ',field-name)) (index (record-type-field-index record-type field-name 'RECORD-ACCESSOR))) (lambda (record) - (if (not (and (vector? record) - (fix:= (vector-length record) record-length) - (eq? (vector-ref record 0) record-type))) - (record-type-error record record-type procedure-name)) - (vector-ref record index)))) + (guarantee-record-of-type record record-type procedure-name) + (%record-ref record index)))) (define (record-modifier record-type field-name) - (if (not (record-type? record-type)) - (error:wrong-type-argument record-type "record type" 'RECORD-UPDATER)) - (let ((record-length (record-type-record-length record-type)) - (procedure-name `(RECORD-UPDATER ,record-type ',field-name)) + (guarantee-record-type record-type 'RECORD-MODIFIER) + (let ((procedure-name `(RECORD-ACCESSOR ,record-type ',field-name)) (index - (record-type-field-index record-type field-name 'RECORD-UPDATER))) + (record-type-field-index record-type field-name 'RECORD-MODIFIER))) (lambda (record field-value) - (if (not (and (vector? record) - (fix:= (vector-length record) record-length) - (eq? (vector-ref record 0) record-type))) - (record-type-error record record-type procedure-name)) - (vector-set! record index field-value)))) + (guarantee-record-of-type record record-type procedure-name) + (%record-set! record index field-value)))) (define record-updater - record-modifier) \ No newline at end of file + record-modifier) + +(define (->string object) + (if (string? object) + object + (write-to-string object))) + +(define-integrable (guarantee-list-of-unique-symbols object procedure) + (if (not (list-of-unique-symbols? object)) + (error:wrong-type-argument object "list of unique symbols" procedure))) + +(define (list-of-unique-symbols? object) + (and (list? object) + (let loop ((elements object)) + (or (null? elements) + (and (symbol? (car elements)) + (not (memq (car elements) (cdr elements))) + (loop (cdr elements))))))) + +(define-integrable (guarantee-record-type record-type procedure) + (if (not (record-type? record-type)) + (error:wrong-type-argument record-type "record type" procedure))) + +(define-integrable (guarantee-record-of-type record record-type procedure-name) + (if (not (and (%record? record) + (eq? (%record-ref record 0) record-type))) + (error:wrong-type-argument + record + (string-append "record of type " (%record-type/name record-type)) + procedure-name))) + +(define-integrable (guarantee-record record procedure-name) + (if (not (record? record)) + (error:wrong-type-argument record "record" procedure-name))) \ No newline at end of file diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 0f2a77529..ee44b3738 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.165 1992/12/02 20:21:45 cph Exp $ +$Id: runtime.pkg,v 14.166 1992/12/07 19:06:56 cph Exp $ Copyright (c) 1988-1992 Massachusetts Institute of Technology @@ -45,6 +45,7 @@ MIT in each case. |# "queue" "sfile" "string" + "symbol" "udata" "vector") (file-case sort-type @@ -439,8 +440,11 @@ MIT in each case. |# (parent ()) (export () define-structure/keyword-parser + make-define-structure-type named-structure/description named-structure?) + (export (runtime unparser) + structure-tag/unparser-method) (initialization (initialize-package!))) (define-package (runtime directory) @@ -1689,7 +1693,9 @@ MIT in each case. |# (files "record") (parent ()) (export () + %make-record %record + %record-copy %record-length %record-ref %record-set! @@ -1698,15 +1704,21 @@ MIT in each case. |# record-accessor record-constructor record-copy + record-description record-modifier record-predicate + record-type-application-method record-type-descriptor record-type-field-names record-type-name + record-type-unparser-method record-type? record-updater record? + set-record-type-application-method! set-record-type-unparser-method!) + (export (runtime unparser) + %record-unparser-method) (initialization (initialize-package!))) (define-package (runtime reference-trap) @@ -1855,9 +1867,6 @@ MIT in each case. |# in-package-environment in-package-expression in-package? - intern - intern-soft - interned-symbol? make-absolute-reference make-access make-assignment @@ -1877,15 +1886,7 @@ MIT in each case. |# set-comment-text! set-declaration-expression! set-declaration-text! - string->symbol - string->uninterned-symbol - symbol->string - symbol-append - symbol-hash - symbol-hash-mod - symbol? the-environment? - uninterned-symbol? variable-components variable-name variable?) diff --git a/v7/src/runtime/scode.scm b/v7/src/runtime/scode.scm index 3dcf6fb85..89f6378a3 100644 --- a/v7/src/runtime/scode.scm +++ b/v7/src/runtime/scode.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: scode.scm,v 14.14 1992/11/08 04:24:31 jinx Exp $ +$Id: scode.scm,v 14.15 1992/12/07 19:06:58 cph Exp $ Copyright (c) 1988-1992 Massachusetts Institute of Technology @@ -38,7 +38,8 @@ MIT in each case. |# (declare (usual-integrations)) (define (initialize-package!) - (set! scode-constant/type-vector (make-scode-constant/type-vector))) + (set! scode-constant/type-vector (make-scode-constant/type-vector)) + unspecific) ;;;; Constant @@ -85,7 +86,7 @@ MIT in each case. |# VECTOR-16B VECTOR-1B)) type-vector)) - + ;;;; Quotation (define-integrable (make-quotation expression) @@ -97,60 +98,6 @@ MIT in each case. |# (define-integrable (quotation-expression quotation) (&singleton-element quotation)) -;;;; Symbol - -(define (symbol? object) - (or (interned-symbol? object) - (uninterned-symbol? object))) - -(define-integrable (interned-symbol? object) - (object-type? (ucode-type interned-symbol) object)) - -(define-integrable (uninterned-symbol? object) - (object-type? (ucode-type uninterned-symbol) object)) - -(define (string->uninterned-symbol string) - (if (not (string? string)) - (error:wrong-type-argument string "string" 'STRING->UNINTERNED-SYMBOL)) - (&typed-pair-cons (ucode-type uninterned-symbol) - string - (make-unbound-reference-trap))) - -(define-integrable find-symbol - (ucode-primitive find-symbol)) - -(define (string->symbol string) - ;; This prevents the symbol from being affected if the string - ;; is mutated. The string is copied only if the symbol is - ;; created. - (or (find-symbol string) - ((ucode-primitive string->symbol) (string-copy string)))) - -(define-integrable (intern string) - ((ucode-primitive string->symbol) (string-downcase string))) - -(define (intern-soft string) - (find-symbol (string-downcase string))) - -(define (symbol-name symbol) - (if (not (symbol? symbol)) - (error:wrong-type-argument symbol "symbol" 'SYMBOL-NAME)) - (system-pair-car symbol)) - -(define-integrable (symbol->string symbol) - (string-copy (symbol-name symbol))) - -(define (symbol-append . symbols) - (let ((string (apply string-append (map symbol-name symbols)))) - (string-downcase! string) - ((ucode-primitive string->symbol) string))) - -(define-integrable (symbol-hash symbol) - (string-hash (symbol-name symbol))) - -(define-integrable (symbol-hash-mod symbol modulus) - (string-hash-mod (symbol-name symbol) modulus)) - ;;;; Variable (define-integrable (make-variable name) diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm index 93cc9b6b1..dff494dcf 100644 --- a/v7/src/runtime/unpars.scm +++ b/v7/src/runtime/unpars.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: unpars.scm,v 14.28 1992/09/21 20:33:45 cph Exp $ +$Id: unpars.scm,v 14.29 1992/12/07 19:07:00 cph Exp $ Copyright (c) 1988-92 Massachusetts Institute of Technology @@ -97,6 +97,7 @@ MIT in each case. |# (PRIMITIVE ,unparse/primitive-procedure) (PROCEDURE ,unparse/compound-procedure) (RATNUM ,unparse/number) + (RECORD ,unparse/record) (RETURN-ADDRESS ,unparse/return-address) (STRING ,unparse/string) (UNINTERNED-SYMBOL ,unparse/uninterned-symbol) @@ -398,7 +399,10 @@ MIT in each case. |# (define (unparse-vector/unparser vector) (and (not (zero? (vector-length vector))) - (unparser/tagged-vector-method (safe-vector-ref vector 0)))) + (let ((tag (safe-vector-ref vector 0))) + (or (structure-tag/unparser-method tag 'VECTOR) + ;; Check the global tagging table too. + (unparser/tagged-vector-method tag))))) (define (unparse-vector/normal vector) (limit-unparse-depth @@ -429,6 +433,12 @@ MIT in each case. |# (vector-ref vector index))))) (error "Attempt to unparse partially marked vector")) (vector-ref vector index)) + +(define (unparse/record record) + (let ((method (%record-unparser-method record))) + (if method + (invoke-user-method method record) + (unparse/default record)))) (define (unparse/pair pair) (let ((prefix (unparse-list/prefix-pair? pair))) @@ -487,8 +497,11 @@ MIT in each case. |# (*unparse-string " . ") (*unparse-object l)))) -(define-integrable (unparse-list/unparser object) - (unparser/tagged-pair-method (car object))) +(define (unparse-list/unparser pair) + (let ((tag (car pair))) + (or (structure-tag/unparser-method tag 'LIST) + ;; Check the global tagging table too. + (unparser/tagged-pair-method tag)))) (define (unparse-list/prefix-pair prefix pair) (*unparse-string prefix) diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm index 26ac9ce92..9d8489cbb 100644 --- a/v7/src/runtime/version.scm +++ b/v7/src/runtime/version.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: version.scm,v 14.158 1992/12/02 19:44:25 cph Exp $ +$Id: version.scm,v 14.159 1992/12/07 19:07:03 cph Exp $ Copyright (c) 1988-1992 Massachusetts Institute of Technology @@ -45,7 +45,7 @@ MIT in each case. |# '())) (add-system! microcode-system) (add-event-receiver! event:after-restore snarf-microcode-version!) - (add-identification! "Runtime" 14 158)) + (add-identification! "Runtime" 14 159)) (define microcode-system) diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm index 949e94518..d491ad048 100644 --- a/v8/src/runtime/make.scm +++ b/v8/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: make.scm,v 14.38 1992/11/03 22:41:13 jinx Exp $ +$Id: make.scm,v 14.39 1992/12/07 19:06:47 cph Exp $ Copyright (c) 1988-1992 Massachusetts Institute of Technology @@ -261,39 +261,44 @@ MIT in each case. |# (eval (fasload "runtim.bcon" #f) system-global-environment) ;;; Global databases. Load, then initialize. -(let ((sine-qua-non +(let ((files1 '(("gcdemn" . (RUNTIME GC-DAEMONS)) - ("poplat" . (RUNTIME POPULATION)) - ("prop1d" . (RUNTIME 1D-PROPERTY)) - ("events" . (RUNTIME EVENT-DISTRIBUTOR)) - ("gdatab" . (RUNTIME GLOBAL-DATABASE)) + ("gc" . (RUNTIME GARBAGE-COLLECTOR)) ("boot" . ()) ("queue" . ()) - ("gc" . (RUNTIME GARBAGE-COLLECTOR)) ("equals" . ()) ("list" . (RUNTIME LIST)) - ("record" . (RUNTIME RECORD))))) - (let loop ((files sine-qua-non)) - (if (not (null? files)) - (begin - (eval (fasload (map-filename (car (car files))) #t) - (package-reference (cdr (car files)))) - (loop (cdr files))))) + ("symbol" . ()) + ("uproc" . (RUNTIME PROCEDURE)) + ("record" . (RUNTIME RECORD)))) + (files2 + '(("defstr" . (RUNTIME DEFSTRUCT)) + ("poplat" . (RUNTIME POPULATION)) + ("prop1d" . (RUNTIME 1D-PROPERTY)) + ("events" . (RUNTIME EVENT-DISTRIBUTOR)) + ("gdatab" . (RUNTIME GLOBAL-DATABASE)))) + (load-files + (lambda (files) + (do ((files files (cdr files))) + ((null? files)) + (eval (fasload (map-filename (car (car files))) #t) + (package-reference (cdr (car files)))))))) + (load-files files1) (package-initialize '(RUNTIME GC-DAEMONS) 'INITIALIZE-PACKAGE! true) - (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE! true) - (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE! true) - (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE! true) - (package-initialize '(RUNTIME GLOBAL-DATABASE) 'INITIALIZE-PACKAGE! true) - (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER! true) - (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER! true) - (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-UNPARSER! true) - (package-initialize '(PACKAGE) 'INITIALIZE-UNPARSER! true) (package-initialize '(RUNTIME GARBAGE-COLLECTOR) 'INITIALIZE-PACKAGE! true) (lexical-assignment (package-reference '(RUNTIME GARBAGE-COLLECTOR)) 'CONSTANT-SPACE/BASE constant-space/base) (package-initialize '(RUNTIME LIST) 'INITIALIZE-PACKAGE! true) (package-initialize '(RUNTIME RECORD) 'INITIALIZE-PACKAGE! true) + (package-initialize '(PACKAGE) 'FINALIZE-PACKAGE-RECORD-TYPE! true) + (load-files files2) + (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE! true) + (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE! true) + (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE! true) + (package-initialize '(RUNTIME GLOBAL-DATABASE) 'INITIALIZE-PACKAGE! true) + (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER! true) + (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER! true) ;; Load everything else. ;; Note: The following code needs MAP* and MEMBER-PROCEDURE @@ -307,7 +312,7 @@ MIT in each case. |# (fasload "runtim.bad" #f) '()) car - sine-qua-non))) + (append files1 files2)))) (string-member? (member-procedure string=?))) (lambda (filename environment) (if (not (string-member? filename to-avoid)) diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 0f2a77529..ee44b3738 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.165 1992/12/02 20:21:45 cph Exp $ +$Id: runtime.pkg,v 14.166 1992/12/07 19:06:56 cph Exp $ Copyright (c) 1988-1992 Massachusetts Institute of Technology @@ -45,6 +45,7 @@ MIT in each case. |# "queue" "sfile" "string" + "symbol" "udata" "vector") (file-case sort-type @@ -439,8 +440,11 @@ MIT in each case. |# (parent ()) (export () define-structure/keyword-parser + make-define-structure-type named-structure/description named-structure?) + (export (runtime unparser) + structure-tag/unparser-method) (initialization (initialize-package!))) (define-package (runtime directory) @@ -1689,7 +1693,9 @@ MIT in each case. |# (files "record") (parent ()) (export () + %make-record %record + %record-copy %record-length %record-ref %record-set! @@ -1698,15 +1704,21 @@ MIT in each case. |# record-accessor record-constructor record-copy + record-description record-modifier record-predicate + record-type-application-method record-type-descriptor record-type-field-names record-type-name + record-type-unparser-method record-type? record-updater record? + set-record-type-application-method! set-record-type-unparser-method!) + (export (runtime unparser) + %record-unparser-method) (initialization (initialize-package!))) (define-package (runtime reference-trap) @@ -1855,9 +1867,6 @@ MIT in each case. |# in-package-environment in-package-expression in-package? - intern - intern-soft - interned-symbol? make-absolute-reference make-access make-assignment @@ -1877,15 +1886,7 @@ MIT in each case. |# set-comment-text! set-declaration-expression! set-declaration-text! - string->symbol - string->uninterned-symbol - symbol->string - symbol-append - symbol-hash - symbol-hash-mod - symbol? the-environment? - uninterned-symbol? variable-components variable-name variable?) -- 2.25.1