From: Chris Hanson Date: Tue, 9 Jan 2018 02:58:48 +0000 (-0500) Subject: Eliminate special support for defstruct printers. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~394 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8fd9fe1a3f67cf27d5533e35bb73012e23a5fa7b;p=mit-scheme.git Eliminate special support for defstruct printers. In future just use define-unparser-method. --- diff --git a/src/runtime/defstr.scm b/src/runtime/defstr.scm index ebb2f0237..4cab2ae78 100644 --- a/src/runtime/defstr.scm +++ b/src/runtime/defstr.scm @@ -57,9 +57,6 @@ differences: a procedure of two arguments (the unparser state and the structure instance) rather than three as in Common Lisp. -* There is an additional option PRINT-ENTITY-PROCEDURE, used to print - an entity whose extra object is a structure instance. - * 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 @@ -105,7 +102,8 @@ differences: ,@(accessor-definitions structure) ,@(modifier-definitions structure) ,@(predicate-definitions structure) - ,@(copier-definitions structure)))))))) + ,@(copier-definitions structure) + ,@(printer-definitions structure)))))))) ;;;; Parse options @@ -118,8 +116,6 @@ differences: (copier-option (find-option 'COPIER options)) (predicate-option (find-option 'PREDICATE options)) (print-procedure-option (find-option 'PRINT-PROCEDURE options)) - (print-entity-procedure-option - (find-option 'PRINT-ENTITY-PROCEDURE options)) (type-option (find-option 'TYPE options)) (type-descriptor-option (find-option 'TYPE-DESCRIPTOR options)) (named-option (find-option 'NAMED options)) @@ -138,8 +134,7 @@ differences: (check-for-illegal-untyped named-option initial-offset-option)) (if (not tagged?) (check-for-illegal-untagged predicate-option - print-procedure-option - print-entity-procedure-option)) + print-procedure-option)) (do ((slots slots (cdr slots)) (index (if tagged? (+ offset 1) offset) (+ index 1))) ((not (pair? slots))) @@ -166,9 +161,6 @@ differences: (option/argument print-procedure-option) (and type-option (default-unparser-text context))) - (if print-entity-procedure-option - (option/argument print-entity-procedure-option) - #f) (if type-option (option/argument type-option) 'RECORD) @@ -222,8 +214,7 @@ differences: (lose initial-offset-option)))) (define (check-for-illegal-untagged predicate-option - print-procedure-option - print-entity-procedure-option) + print-procedure-option) (let ((test (lambda (option) (if (and option @@ -233,8 +224,7 @@ differences: (error "Structure option illegal for unnamed structure:" (option/original option)))))) (test predicate-option) - (test print-procedure-option) - (test print-entity-procedure-option))) + (test print-procedure-option))) (define (compute-constructors constructor-options keyword-constructor-options @@ -438,13 +428,6 @@ differences: (lambda (arg) `(PRINT-PROCEDURE ,(if (false-expression? arg context) #f arg)))))) -(define-option 'PRINT-ENTITY-PROCEDURE #f - (lambda (option context) - (one-required-argument option - (lambda (arg) - `(PRINT-ENTITY-PROCEDURE - ,(if (false-expression? arg context) #f arg)))))) - (define-option 'TYPE #f (lambda (option context) context @@ -558,9 +541,8 @@ differences: (define-record-type (make-structure context conc-name constructors keyword-constructors copier - predicate print-procedure print-entity-procedure - physical-type named? type-descriptor tag-expression - safe-accessors? offset slots) + predicate print-procedure physical-type named? + type-descriptor tag-expression safe-accessors? offset slots) structure? (context structure/context) (conc-name structure/conc-name) @@ -569,7 +551,6 @@ differences: (copier structure/copier) (predicate structure/predicate) (print-procedure structure/print-procedure) - (print-entity-procedure structure/print-entity-procedure) (physical-type structure/physical-type) (named? structure/tagged?) (type-descriptor structure/type-descriptor) @@ -806,9 +787,7 @@ differences: (let ((type-name (structure/type-descriptor structure)) (tag-expression (structure/tag-expression structure)) (slots (structure/slots structure)) - (context (structure/context structure)) - (print-procedure (structure/print-procedure structure)) - (print-entity-procedure (structure/print-entity-procedure structure))) + (context (structure/context structure))) (let ((name (symbol->string (parser-context/name context))) (field-names (map slot/name slots)) (inits @@ -823,34 +802,36 @@ differences: `(,(absolute 'MAKE-RECORD-TYPE context) ',name ',field-names - (LIST ,@inits) - ,(close print-procedure context) - ,@(if print-entity-procedure - (list (close print-entity-procedure context)) - '())) + (LIST ,@inits)) `(,(absolute 'MAKE-DEFINE-STRUCTURE-TYPE context) ',(structure/physical-type structure) ',name '#(,@field-names) '#(,@(map slot/index slots)) (VECTOR ,@inits) - ,(if (structure/tagged? structure) - (close print-procedure context) - '#F) + ;; 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) ',(+ (if (structure/tagged? structure) 1 0) (structure/offset structure) - (length slots)) - ,@(if (and (structure/tagged? structure) - print-entity-procedure) - (list (close print-entity-procedure context)) - '())))) + (length slots))))) ,@(if (and tag-expression (not (eq? tag-expression type-name))) `((,(absolute 'NAMED-STRUCTURE/SET-TAG-DESCRIPTION! context) ,(close tag-expression context) ,type-name)) - '()))))) \ No newline at end of file + '()))))) + +(define (printer-definitions structure) + (if (and (structure/predicate structure) + (or (structure/record-type? structure) + (structure/tagged? structure))) + (let ((context (structure/context structure))) + `((define-unparser-method + ,(close (structure/predicate structure) context) + ,(close (structure/print-procedure structure) context)))) + '())) \ No newline at end of file diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm index f264c302d..566bfad92 100644 --- a/src/runtime/pp.scm +++ b/src/runtime/pp.scm @@ -737,10 +737,7 @@ USA. (make-prefix-node prefix (numerical-walk (cadr object) list-depth)) - (let ((unparser (unparse-list/unparser object))) - (if unparser - (walk-custom unparser object list-depth) - (walk-pair object list-depth)))))) + (walk-pair object list-depth)))) ((symbol? object) (if (or (get-param:pp-uninterned-symbols-by-name?) (interned-symbol? object)) @@ -759,12 +756,9 @@ USA. ((vector? object) (if (zero? (vector-length object)) (walk-custom unparse-object object list-depth) - (let ((unparser (unparse-vector/unparser object))) - (if unparser - (walk-custom unparser object list-depth) - (make-prefix-node "#" - (walk-pair (vector->list object) - list-depth)))))) + (make-prefix-node "#" + (walk-pair (vector->list object) + list-depth)))) ((primitive-procedure? object) (if (get-param:pp-primitives-by-name?) (primitive-procedure-name object) @@ -817,8 +811,7 @@ USA. (make-list-node (numerical-walk (car pair) list-depth) (let ((list-breadth (+ list-breadth 1))) - (if (and (pair? (cdr pair)) - (not (unparse-list/unparser (cdr pair)))) + (if (pair? (cdr pair)) (loop (cdr pair) list-breadth) (make-list-node "." @@ -902,11 +895,8 @@ USA. (cadr object) (advance half-pointer (update-queue queue '(CDR CAR))) list-depth)) - (let ((unparser (unparse-list/unparser object))) - (if unparser - (walk-custom unparser object list-depth) - (walk-pair-terminating object half-pointer/queue - list-depth)))))) + (walk-pair-terminating object half-pointer/queue + list-depth)))) ((symbol? object) (if (or (get-param:pp-uninterned-symbols-by-name?) (interned-symbol? object)) @@ -922,14 +912,11 @@ USA. ((vector? object) (if (zero? (vector-length object)) (walk-custom unparse-object object list-depth) - (let ((unparser (unparse-vector/unparser object))) - (if unparser - (walk-custom unparser object list-depth) - (make-prefix-node - "#" - (walk-vector-terminating - (vector->list object) - half-pointer/queue list-depth)))))) + (make-prefix-node + "#" + (walk-vector-terminating + (vector->list object) + half-pointer/queue list-depth)))) ((primitive-procedure? object) (if (get-param:pp-primitives-by-name?) (primitive-procedure-name object) @@ -975,8 +962,7 @@ USA. (car pair) half-pointer/queue list-depth))) (let ((list-breadth (+ list-breadth 1))) (if - (and (pair? (cdr pair)) - (not (unparse-list/unparser (cdr pair)))) + (pair? (cdr pair)) (let ((half-pointer/queue (advance (car half-pointer/queue) @@ -1041,21 +1027,7 @@ USA. (circularity-string (cdr half-pointer/queue)) (numerical-walk-terminating (car pair) half-pointer/queue list-depth))) - (let ((list-breadth (+ list-breadth 1))) - (if (not (unparse-list/unparser (cdr pair))) - (loop (cdr pair) list-breadth) - (make-list-node - "." - (make-singleton-list-node - (if (let ((limit - (get-param:unparser-list-breadth-limit))) - (and limit - (>= list-breadth limit) - (no-highlights? pair))) - "..." - (numerical-walk-terminating - (cdr pair) - half-pointer/queue list-depth))))))))))))) + (loop (cdr pair) (+ list-breadth 1))))))))) ;;;; These procedures allow the walkers to interact with the queue. diff --git a/src/runtime/record.scm b/src/runtime/record.scm index b59e068fd..3588c244a 100644 --- a/src/runtime/record.scm +++ b/src/runtime/record.scm @@ -99,6 +99,8 @@ USA. (define (make-record-type type-name field-names #!optional default-inits unparser-method entity-unparser-method) + ;; The unparser-method and entity-unparser-method arguments should be removed + ;; after the 9.3 release. (let ((caller 'MAKE-RECORD-TYPE)) (if (not (list-of-unique-symbols? field-names)) (error:not-a list-of-unique-symbols? field-names caller)) @@ -117,19 +119,20 @@ USA. (%record-set! record-type 1 tag) (if (not (default-object? default-inits)) (%set-record-type-default-inits! record-type default-inits caller)) - (%set-record-type-predicate! record-type - (lambda (object) - (%tagged-record? tag object))) - (%set-record-type-entity-predicate! record-type - (lambda (object) - (%tagged-record-entity? tag object))) - (if (and unparser-method - (not (default-object? unparser-method))) - (set-record-type-unparser-method! record-type unparser-method)) - (if (and entity-unparser-method - (not (default-object? entity-unparser-method))) - (set-record-type-entity-unparser-method! record-type - entity-unparser-method)) + (let ((predicate + (lambda (object) + (%tagged-record? tag object))) + (entity-predicate + (lambda (object) + (%tagged-record-entity? tag object)))) + (%set-record-type-predicate! record-type predicate) + (%set-record-type-entity-predicate! record-type entity-predicate) + (if (and unparser-method + (not (default-object? unparser-method))) + (define-unparser-method predicate unparser-method)) + (if (and entity-unparser-method + (not (default-object? entity-unparser-method))) + (define-unparser-method entity-predicate entity-unparser-method))) record-type))) (define (record-type? object) @@ -564,7 +567,7 @@ USA. (define (set-record-type-describer! record-type describer) (define-pp-describer (record-predicate record-type) describer)) - + (define (set-record-type-entity-unparser-method! record-type method) (define-unparser-method (record-entity-predicate record-type) method)) @@ -579,24 +582,20 @@ USA. (set! rtd:structure-type (make-record-type "structure-type" '(PHYSICAL-TYPE NAME FIELD-NAMES FIELD-INDEXES - DEFAULT-INITS UNPARSER-METHOD TAG - LENGTH ENTITY-UNPARSER-METHOD))) + DEFAULT-INITS TAG LENGTH))) (set! make-define-structure-type (let ((constructor (record-constructor rtd:structure-type))) (lambda (physical-type name field-names field-indexes default-inits - unparser-method tag length - #!optional entity-unparser-method) + unparser-method tag length) + ;; unparser-method arg should be removed after 9.3 is released. + (declare (ignore unparser-method)) (constructor physical-type name field-names field-indexes default-inits - unparser-method tag - length - (if (default-object? entity-unparser-method) - #f - entity-unparser-method))))) + length)))) (set! structure-type? (record-predicate rtd:structure-type)) (set! structure-type/physical-type @@ -609,18 +608,10 @@ USA. (record-accessor rtd:structure-type 'FIELD-INDEXES)) (set! structure-type/default-inits (record-accessor rtd:structure-type 'DEFAULT-INITS)) - (set! structure-type/unparser-method - (record-accessor rtd:structure-type 'UNPARSER-METHOD)) - (set! set-structure-type/unparser-method! - (record-modifier rtd:structure-type 'UNPARSER-METHOD)) (set! structure-type/tag (record-accessor rtd:structure-type 'TAG)) (set! structure-type/length (record-accessor rtd:structure-type 'LENGTH)) - (set! structure-type/entity-unparser-method - (record-accessor rtd:structure-type 'ENTITY-UNPARSER-METHOD)) - (set! set-structure-type/entity-unparser-method! - (record-modifier rtd:structure-type 'ENTITY-UNPARSER-METHOD)) unspecific) (define rtd:structure-type) @@ -635,8 +626,6 @@ USA. (define set-structure-type/unparser-method!) (define structure-type/tag) (define structure-type/length) -(define structure-type/entity-unparser-method) -(define set-structure-type/entity-unparser-method!) (define-integrable (structure-type/field-index type field-name) (vector-ref (structure-type/field-indexes type) @@ -660,14 +649,6 @@ USA. i (loop (fix:+ i 1))))))) -(define (structure-tag/unparser-method tag physical-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) - (and (structure-type-tag? tag physical-type) - (structure-type/entity-unparser-method (tag->structure-type tag)))) - (define (named-structure? object) (or (named-list? object) (named-vector? object) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 171d75bc0..ec6d3faa5 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3785,9 +3785,6 @@ USA. error:no-such-slot error:uninitialized-slot record-type-field-index) - (export (runtime unparser) - structure-tag/entity-unparser-method - structure-tag/unparser-method) (export (runtime predicate-metadata) cleanup-boot-time-record-predicates!) (export (runtime predicate-tagging) @@ -4852,9 +4849,7 @@ USA. get-param:unparser-list-breadth-limit get-param:unparser-list-depth-limit make-unparser-state - unparse-list/prefix-pair? - unparse-list/unparser - unparse-vector/unparser) + unparse-list/prefix-pair?) (export (runtime record) (rtd:unparser-state ))) diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm index 79d7c3849..39783ab9d 100644 --- a/src/runtime/unpars.scm +++ b/src/runtime/unpars.scm @@ -568,24 +568,6 @@ USA. (loop (fix:- index 1)))))) (define (unparse/vector vector context) - (let ((method (unparse-vector/unparser vector))) - (if method - (invoke-user-method method vector context) - (unparse-vector/normal vector context)))) - -(define (unparse-vector/unparser vector) - (and (fix:> (vector-length 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/entity-unparser vector) - (and (fix:> (vector-length vector) 0) - (structure-tag/entity-unparser-method (safe-vector-ref vector 0) - 'VECTOR))) - -(define (unparse-vector/normal vector context) (limit-unparse-depth context (lambda (context*) (let ((end (vector-length vector))) @@ -653,8 +635,6 @@ USA. (define (unparse/pair pair context) (cond ((unparse-list/prefix-pair? pair) => (lambda (prefix) (unparse-list/prefix-pair prefix pair context))) - ((unparse-list/unparser pair) - => (lambda (method) (invoke-user-method method pair context))) ((and (get-param:unparse-streams?) (stream-pair? pair)) (unparse-list/stream-pair pair context)) (else @@ -678,33 +658,18 @@ USA. (define (unparse-tail l n context) (cond ((pair? l) - (let ((method (unparse-list/unparser l))) - (if method - (begin - (*unparse-string " . " context) - (invoke-user-method method l context)) - (begin - (*unparse-char #\space context) - (*unparse-object (safe-car l) context) - (if (let ((limit (context-list-breadth-limit context))) - (and limit - (>= n limit) - (pair? (safe-cdr l)))) - (*unparse-string " ..." context) - (unparse-tail (safe-cdr l) (+ n 1) context)))))) + (*unparse-char #\space context) + (*unparse-object (safe-car l) context) + (if (let ((limit (context-list-breadth-limit context))) + (and limit + (>= n limit) + (pair? (safe-cdr l)))) + (*unparse-string " ..." context) + (unparse-tail (safe-cdr l) (+ n 1) context))) ((not (null? l)) (*unparse-string " . " context) (*unparse-object l context)))) - -(define (unparse-list/unparser pair) - (let ((tag (safe-car pair))) - (or (structure-tag/unparser-method tag 'LIST) - ;; Check the global tagging table too. - (unparser/tagged-pair-method tag)))) -(define (unparse-list/entity-unparser pair) - (structure-tag/entity-unparser-method (safe-car pair) 'LIST)) - (define (unparse-list/prefix-pair prefix pair context) (*unparse-string prefix context) (*unparse-object (safe-car (safe-cdr pair)) context)) @@ -910,12 +875,6 @@ USA. (else (plain 'ARITY-DISPATCHED-PROCEDURE))))) ((get-param:unparse-with-maximum-readability?) (*unparse-readable-hash entity context)) - ((or (and (vector? (%entity-extra entity)) - (unparse-vector/entity-unparser (%entity-extra entity))) - (and (pair? (%entity-extra entity)) - (unparse-list/entity-unparser (%entity-extra entity)))) - => (lambda (method) - (invoke-user-method method entity context))) (else (plain 'ENTITY)))) (define (unparse/promise promise context)