From 7f6f59ec9bcb37e9945f83718f6c6193f4c2c1e0 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 7 Jan 2018 15:09:33 -0500 Subject: [PATCH] Convert record support to use new predicate dispatchers. --- src/compiler/base/object.scm | 2 +- src/runtime/debug.scm | 2 +- src/runtime/pp.scm | 10 +- src/runtime/predicate-metadata.scm | 19 +- src/runtime/record.scm | 269 ++++++++++++++--------------- src/runtime/runtime.pkg | 6 +- src/runtime/unpars.scm | 3 +- 7 files changed, 147 insertions(+), 164 deletions(-) diff --git a/src/compiler/base/object.scm b/src/compiler/base/object.scm index 78b84bc70..2ae868bd9 100644 --- a/src/compiler/base/object.scm +++ b/src/compiler/base/object.scm @@ -142,7 +142,7 @@ USA. (define (tagged-vector/description object) (cond ((named-structure? object) - named-structure/description) + pp-description) ((tagged-vector? object) (vector-tag-description (tagged-vector/tag object))) (else diff --git a/src/runtime/debug.scm b/src/runtime/debug.scm index 9f8b2d8e9..65a71c0e2 100644 --- a/src/runtime/debug.scm +++ b/src/runtime/debug.scm @@ -825,7 +825,7 @@ USA. (for-each (lambda (element) (newline port) (debugger-pp element 0 port)) - (named-structure/description (dstate/subproblem dstate)))))) + (pp-description (dstate/subproblem dstate)))))) (define-command (command/print-frame-elements dstate port) (debugger-presentation diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm index 354e47b6b..daa01d73e 100644 --- a/src/runtime/pp.scm +++ b/src/runtime/pp.scm @@ -180,15 +180,7 @@ USA. (define-predicate-dispatch-default-handler pp-description (lambda (object) - (cond ((named-structure? object) - (named-structure/description object)) - ((%record? object) ; unnamed record - (let loop ((i (- (%record-length object) 1)) (d '())) - (if (< i 0) - d - (loop (- i 1) - (cons (list i (%record-ref object i)) d))))) - ((and (entity? object) + (cond ((and (entity? object) (record? (entity-extra object))) ((record-entity-describer (entity-extra object)) object)) (else #f)))) diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm index 4d5f4e8a9..45808bbf2 100644 --- a/src/runtime/predicate-metadata.scm +++ b/src/runtime/predicate-metadata.scm @@ -214,10 +214,7 @@ USA. (add-boot-init! (lambda () (register-predicate! predicate? 'predicate) - (register-predicate! tag-name? 'tag-name) - (register-predicate! %record? '%record) - (register-predicate! record? 'record '<= %record?) - (cleanup-boot-time-record-predicates!))) + (register-predicate! tag-name? 'tag-name))) ;;; Registration of standard predicates (add-boot-init! @@ -325,8 +322,18 @@ USA. (register-predicate! keyword? 'keyword '<= symbol?) (register-predicate! lambda-tag? 'lambda-tag) (register-predicate! named-structure? 'named-structure) + (register-predicate! named-list? 'named-list + '<= non-empty-list? + '<= named-structure?) + (register-predicate! named-vector? 'named-vector + '<= vector? + '<= named-structure?) (register-predicate! population? 'population) (register-predicate! promise? 'promise) + (register-predicate! %record? '%record) + (register-predicate! record? 'record + '<= %record? + '<= named-structure?) (register-predicate! record-type? 'record-type '<= record?) (register-predicate! stack-address? 'stack-address) (register-predicate! thread-mutex? 'thread-mutex) @@ -340,7 +347,9 @@ USA. (register-predicate! weak-list? 'weak-list) (register-predicate! weak-pair? 'weak-pair) - (register-ustring-predicates!))) + (register-ustring-predicates!) + + (cleanup-boot-time-record-predicates!))) (add-boot-init! (lambda () diff --git a/src/runtime/record.scm b/src/runtime/record.scm index 94d8a125a..7d258e0aa 100644 --- a/src/runtime/record.scm +++ b/src/runtime/record.scm @@ -259,120 +259,6 @@ USA. (set! boot-time-record-types) unspecific) -;;;; Unparser Methods - -(define unparse-record) -(defer-boot-action 'record/procedures - (lambda () - (set! unparse-record - (standard-predicate-dispatcher 'unparse-record 2)) - - (define-predicate-dispatch-default-handler unparse-record - (standard-unparser-method 'record #f)) - - (define-predicate-dispatch-handler unparse-record - (list any-object? record?) - (standard-unparser-method - (lambda (record) - (strip-angle-brackets - (%record-type-name (%record-type-descriptor record)))) - #f)) - - (define-predicate-dispatch-handler unparse-record - (list any-object? record-type?) - (standard-unparser-method 'record-type - (lambda (type port) - (write-char #\space port) - (display (%record-type-name type) port)))) - - (define-predicate-dispatch-handler unparse-record - (list any-object? dispatch-tag?) - (simple-unparser-method 'dispatch-tag - (lambda (tag) - (list (dispatch-tag-contents tag))))))) - -(define set-record-type-unparser-method! - (deferred-property-setter - (variable-setter set-record-type-unparser-method!) - (named-lambda (set-record-type-unparser-method! record-type method) - (guarantee unparser-method? method 'set-record-type-unparser-method!) - (define-predicate-dispatch-handler unparse-record - (list any-object? (record-predicate record-type)) - method)))) - -(define record-entity-unparser) -(defer-boot-action 'record/procedures - (lambda () - (set! record-entity-unparser - (standard-predicate-dispatcher 'record-entity-unparser 1)) - - (define-predicate-dispatch-default-handler record-entity-unparser - (standard-unparser-method 'entity #f)))) - -(define set-record-type-entity-unparser-method! - (deferred-property-setter - (variable-setter set-record-type-entity-unparser-method!) - (named-lambda (set-record-type-entity-unparser-method! record-type method) - (guarantee unparser-method? method - 'set-record-type-entity-unparser-method!) - (define-predicate-dispatch-handler record-entity-unparser - (list (record-predicate record-type)) - (lambda (record) - (declare (ignore record)) - method))))) - -(define record-description) -(defer-boot-action 'record/procedures - (lambda () - (set! record-description - (standard-predicate-dispatcher 'record-description 1)) - - (define-predicate-dispatch-default-handler record-description - (lambda (record) - (let loop ((i (fix:- (%record-length record) 1)) (d '())) - (if (fix:< i 0) - d - (loop (fix:- i 1) - (cons (list i (%record-ref record i)) d)))))) - - (define-predicate-dispatch-handler record-description - (list record?) - (lambda (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 set-record-type-describer! - (deferred-property-setter - (variable-setter set-record-type-describer!) - (named-lambda (set-record-type-describer! record-type describer) - (guarantee unary-procedure? describer 'set-record-type-describer!) - (define-predicate-dispatch-handler record-description - (list (record-predicate record-type)) - describer)))) - -(define record-entity-describer) -(defer-boot-action 'record/procedures - (lambda () - (set! record-entity-describer - (standard-predicate-dispatcher 'record-entity-describer 1)) - - (define-predicate-dispatch-default-handler record-entity-describer - (lambda (entity) - (declare (ignore entity)) - #f)))) - -(define set-record-type-entity-describer! - (deferred-property-setter - (variable-setter set-record-type-entity-describer!) - (named-lambda (set-record-type-entity-describer! record-type describer) - (guarantee unary-procedure? describer 'set-record-type-entity-describer!) - (define-predicate-dispatch-handler record-entity-describer - (list (record-predicate record-type)) - describer)))) - ;;;; Constructors (define (record-constructor record-type #!optional field-names) @@ -590,6 +476,91 @@ USA. (define-guarantee record-type "record type") (define-guarantee record "record") +;;;; Printing + +(define-unparser-method record? + (standard-unparser-method + (lambda (record) + (strip-angle-brackets + (%record-type-name (%record-type-descriptor record)))) + #f)) + +(define-unparser-method record-type? + (standard-unparser-method 'record-type + (lambda (type port) + (write-char #\space port) + (display (%record-type-name type) port)))) + +(define-unparser-method dispatch-tag? + (simple-unparser-method 'dispatch-tag + (lambda (tag) + (list (dispatch-tag-contents tag))))) + +(define (set-record-type-unparser-method! record-type method) + (define-unparser-method (record-predicate record-type) + method)) + +(define-pp-describer %record? + (lambda (record) + (let loop ((i (fix:- (%record-length record) 1)) (d '())) + (if (fix:< i 0) + d + (loop (fix:- i 1) + (cons (list i (%record-ref record i)) d)))))) + +(define-pp-describer record? + (lambda (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 (set-record-type-describer! record-type describer) + (define-pp-describer (record-predicate record-type) + describer)) + +(define record-entity-unparser) +(defer-boot-action 'record/procedures + (lambda () + (set! record-entity-unparser + (standard-predicate-dispatcher 'record-entity-unparser 1)) + + (define-predicate-dispatch-default-handler record-entity-unparser + (standard-unparser-method 'entity #f)))) + +(define set-record-type-entity-unparser-method! + (deferred-property-setter + (variable-setter set-record-type-entity-unparser-method!) + (named-lambda (set-record-type-entity-unparser-method! record-type method) + (guarantee unparser-method? method + 'set-record-type-entity-unparser-method!) + (define-predicate-dispatch-handler record-entity-unparser + (list (record-predicate record-type)) + (lambda (record) + (declare (ignore record)) + method))))) + +(define record-entity-describer) +(defer-boot-action 'record/procedures + (lambda () + (set! record-entity-describer + (standard-predicate-dispatcher 'record-entity-describer 1)) + + (define-predicate-dispatch-default-handler record-entity-describer + (lambda (entity) + (declare (ignore entity)) + #f)))) + +(define set-record-type-entity-describer! + (deferred-property-setter + (variable-setter set-record-type-entity-describer!) + (named-lambda (set-record-type-entity-describer! record-type describer) + (guarantee unary-procedure? describer 'set-record-type-entity-describer!) + (define-predicate-dispatch-handler record-entity-describer + (list (record-predicate record-type)) + describer)))) + ;;;; Runtime support for DEFINE-STRUCTURE (define (initialize-structure-type-type!) @@ -678,45 +649,55 @@ USA. (loop (fix:+ i 1))))))) (define (structure-tag/unparser-method tag physical-type) - (let ((type (tag->structure-type tag physical-type))) - (and type - (structure-type/unparser-method type)))) + (and (structure-type-tag? tag physical-type) + (structure-type/unparser-method (tag->structure-type tag)))) (define (structure-tag/entity-unparser-method tag physical-type) - (let ((type (tag->structure-type tag physical-type))) - (and type - (structure-type/entity-unparser-method type)))) + (and (structure-type-tag? tag physical-type) + (structure-type/entity-unparser-method (tag->structure-type tag)))) (define (named-structure? object) - (cond ((record? object) #t) - ((vector? object) - (and (not (fix:= (vector-length object) 0)) - (tag->structure-type (vector-ref object 0) 'VECTOR))) - ((pair? object) (tag->structure-type (car object) 'LIST)) - (else #f))) - -(define (tag->structure-type tag physical-type) + (or (named-list? object) + (named-vector? object) + (record? object))) + +(define (named-list? object) + (and (pair? object) + (structure-type-tag? (car object) 'list) + (list? (cdr object)))) + +(define (named-vector? object) + (and (vector? object) + (fix:> (vector-length object) 0) + (structure-type-tag? (vector-ref object 0) 'vector))) + +(define (structure-type-tag? tag physical-type) + (let ((type (tag->structure-type tag))) + (and type + (eq? (structure-type/physical-type type) physical-type)))) + +(define (tag->structure-type tag) (if (structure-type? tag) - (and (eq? (structure-type/physical-type tag) physical-type) - tag) + tag (let ((type (named-structure/get-tag-description tag))) (and (structure-type? type) - (eq? (structure-type/physical-type type) physical-type) type)))) -(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))) - (vector->list (structure-type/field-names type)) - (vector->list (structure-type/field-indexes type)))))) - (else - (error:wrong-type-argument structure "named structure" - 'NAMED-STRUCTURE/DESCRIPTION)))) +(define-pp-describer named-list? + (lambda (pair) + (let ((type (tag->structure-type (car pair)))) + (map (lambda (field-name index) + `(,field-name ,(list-ref pair index))) + (vector->list (structure-type/field-names type)) + (vector->list (structure-type/field-indexes type)))))) + +(define-pp-describer named-vector? + (lambda (vector) + (let ((type (tag->structure-type (vector-ref vector 0)))) + (map (lambda (field-name index) + `(,field-name ,(vector-ref vector index))) + (vector->list (structure-type/field-names type)) + (vector->list (structure-type/field-indexes type)))))) (define (define-structure/default-value type field-name) ((structure-type/default-init type field-name))) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 5fa235215..942bd60d2 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3749,8 +3749,9 @@ USA. list-of-unique-symbols? make-define-structure-type make-record-type - named-structure/description + named-list? named-structure? + named-vector? record-accessor record-constructor record-copy @@ -3773,8 +3774,7 @@ USA. set-record-type-entity-describer! set-record-type-entity-unparser-method! set-record-type-extension! - set-record-type-unparser-method! - unparse-record) + set-record-type-unparser-method!) (export (runtime pretty-printer) record-entity-describer) (export (runtime record-slot-access) diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm index de06b5776..1d7ef2b0b 100644 --- a/src/runtime/unpars.scm +++ b/src/runtime/unpars.scm @@ -642,7 +642,8 @@ USA. ((uri? record) (unparse/uri record context)) ((get-param:unparse-with-maximum-readability?) (*unparse-readable-hash record context)) - (else (invoke-user-method unparse-record record context)))) + (else + (*unparse-with-brackets 'record record context #f)))) (define (unparse/uri uri context) (*unparse-string "#<" context) -- 2.25.1