From: Chris Hanson Date: Sun, 18 Mar 2018 22:01:23 +0000 (-0700) Subject: Eliminate default-inits arg from make-record-type. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~202 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f7f4b264090948f24081053d8ed66a29d853a9b6;p=mit-scheme.git Eliminate default-inits arg from make-record-type. This will allow all optional args to be removed after 9.3. --- diff --git a/src/runtime/defstr.scm b/src/runtime/defstr.scm index 960c3c91f..ba90d6ea9 100644 --- a/src/runtime/defstr.scm +++ b/src/runtime/defstr.scm @@ -800,33 +800,37 @@ differences: (let ((default (slot/default slot))) (if (false-marker? default) #f - `(LAMBDA () ,(close default context))))) + `(lambda () ,(close default context))))) slots))) - `((DEFINE ,type-name + `((define ,type-name ,(if (structure/record-type? structure) - `(,(absolute 'MAKE-RECORD-TYPE context) + `(,(absolute 'make-record-type context) ',name - ',field-names - (LIST ,@inits)) - `(,(absolute 'MAKE-DEFINE-STRUCTURE-TYPE context) + (list ,@(map (lambda (name init) + (if init + `(list ',name ,init) + `',name)) + field-names + inits))) + `(,(absolute 'make-define-structure-type context) ',(structure/physical-type structure) ',name '#(,@field-names) '#(,@(map slot/index slots)) - (VECTOR ,@inits) + (vector ,@inits) ;; This field was the print-procedure, no longer used. ;; It should be removed after 9.3 is released. #f ,(if (and tag-expression (not (eq? tag-expression type-name))) (close tag-expression context) - '#F) + '#f) ',(+ (if (structure/tagged? structure) 1 0) (structure/offset structure) (length slots))))) ,@(if (and tag-expression (not (eq? tag-expression type-name))) - `((,(absolute 'NAMED-STRUCTURE/SET-TAG-DESCRIPTION! context) + `((,(absolute 'named-structure/set-tag-description! context) ,(close tag-expression context) ,type-name)) '()))))) diff --git a/src/runtime/record.scm b/src/runtime/record.scm index c8fa6810b..e79028642 100644 --- a/src/runtime/record.scm +++ b/src/runtime/record.scm @@ -43,22 +43,24 @@ USA. (%record-set! result index (%record-ref record index))) result))) -(define (make-record-type type-name field-names +(define (make-record-type type-name field-specs #!optional default-inits unparser-method entity-unparser-method) - ;; The unparser-method and entity-unparser-method arguments should be removed - ;; after the 9.3 release. + ;; The optional arguments should be removed after the 9.3 release. (declare (ignore entity-unparser-method)) (let ((caller 'make-record-type)) - (if (not (list-of-unique-symbols? field-names)) - (error:not-a list-of-unique-symbols? field-names caller)) - (let* ((names (list->vector field-names)) - (n (vector-length names))) - (if (not (or (default-object? default-inits) - (%valid-default-inits? default-inits n))) - (error:wrong-type-argument default-inits - "default initializers" - caller)) + (let ((field-specs + (if (default-object? default-inits) + (begin + (guarantee valid-field-specs? field-specs caller) + field-specs) + (begin + (if (not (list-of-unique-symbols? field-specs)) + (error:not-a list-of-unique-symbols? field-specs caller)) + (guarantee list? default-inits caller) + (if (not (fix:= (length field-specs) (length default-inits))) + (error:bad-range-argument default-inits caller)) + (map make-field-spec field-specs default-inits))))) (letrec* ((predicate (lambda (object) @@ -66,10 +68,8 @@ USA. (tag (%make-record-type (->type-name type-name) predicate - names - (if (default-object? default-inits) - (vector-cons n #f) - (list->vector default-inits)) + (list->vector (map field-spec-name field-specs)) + (list->vector (map field-spec-init field-specs)) #f #f))) (%set-record-type-instance-marker! tag tag) @@ -78,23 +78,66 @@ USA. (not (default-object? unparser-method))) (define-unparser-method predicate unparser-method)) tag)))) + +(define (valid-field-specs? object) + (and (list? object) + (every field-spec? object) + (let loop ((field-specs object)) + (if (pair? field-specs) + (if (any (let ((name (field-spec-name (car field-specs)))) + (lambda (field-spec) + (eq? name (field-spec-name field-spec)))) + (cdr field-specs)) + #f + (loop (cdr field-specs))) + #t)))) +(register-predicate! valid-field-specs? 'valid-field-specs '<= list?) -(define (%valid-default-inits? default-inits n-fields) - (fix:= n-fields (length default-inits))) +(define (field-spec? object) + (or (symbol? object) + (and (pair? object) + (symbol? (car object)) + (pair? (cdr object)) + (%valid-default-init? (cadr object)) + (null? (cddr object))))) + +(define (make-field-spec name init) + (if init + (list name init) + name)) + +(define (field-spec-name spec) + (if (pair? spec) (car spec) spec)) + +(define (field-spec-init spec) + (if (pair? spec) (cadr spec) #f)) + +(define (%valid-default-init? object) + (declare (ignore object)) + #t) (defer-boot-action 'record-procedures (lambda () - (set! %valid-default-inits? - (named-lambda (%valid-default-inits? default-inits n-fields) - (and (fix:= n-fields (length default-inits)) - (every (lambda (init) - (or (not init) - (thunk? init))) - default-inits)))) + (set! %valid-default-init? + (named-lambda (%valid-default-init? object) + (or (not object) + (thunk? object)))) unspecific)) (define (initialize-record-procedures!) (run-deferred-boot-actions 'record-procedures)) + +(define (list-of-unique-symbols? object) + (and (list-of-type? object symbol?) + (let loop ((elements object)) + (if (pair? elements) + (and (not (memq (car elements) (cdr elements))) + (loop (cdr elements))) + #t)))) + +(define (%valid-default-inits? default-inits n-fields) + (and (fix:= n-fields (length default-inits)) + (every %valid-default-init? default-inits))) (define %record-metatag) (define record-type?) @@ -458,14 +501,6 @@ USA. ((symbol? object) object) (else (error:wrong-type-argument object "type name" #f)))) -(define (list-of-unique-symbols? object) - (and (list-of-type? object symbol?) - (let loop ((elements object)) - (if (pair? elements) - (and (not (memq (car elements) (cdr elements))) - (loop (cdr elements))) - #t)))) - (define-guarantee record-type "record type") (define-guarantee record "record")