From: Taylor R Campbell Date: Thu, 14 Oct 2010 04:50:52 +0000 (+0000) Subject: Implement user-defined unparser methods for entities. X-Git-Tag: 20101212-Gtk~41 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=06adf6b3ff28ba2d90825f93ee8dfacd0447c3f8;p=mit-scheme.git Implement user-defined unparser methods for entities. New DEFINE-STRUCTURE option PRINT-ENTITY-PROCEDURE is like PRINT-PROCEDURE, except that the second argument to the procedure is not a structure instance itself but an entity whose extra is a structure instance. New procedure SET-RECORD-TYPE-ENTITY-UNPARSER-METHOD! is like SET-RECORD-TYPE-UNPARSER-METHOD! with the same difference. New optional argument to MAKE-RECORD-TYPE specifies an entity unparser method. Existing code should be unaffected by the changes, including existing compiled code that used DEFINE-STRUCTURE. --- diff --git a/src/runtime/defstr.scm b/src/runtime/defstr.scm index ece048be9..317bfc51d 100644 --- a/src/runtime/defstr.scm +++ b/src/runtime/defstr.scm @@ -56,6 +56,9 @@ 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 @@ -114,6 +117,8 @@ 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)) @@ -132,7 +137,8 @@ differences: (check-for-illegal-untyped named-option initial-offset-option)) (if (not tagged?) (check-for-illegal-untagged predicate-option - print-procedure-option)) + print-procedure-option + print-entity-procedure-option)) (do ((slots slots (cdr slots)) (index (if tagged? (+ offset 1) offset) (+ index 1))) ((not (pair? slots))) @@ -159,6 +165,9 @@ 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) @@ -211,7 +220,9 @@ differences: (if initial-offset-option (lose initial-offset-option)))) -(define (check-for-illegal-untagged predicate-option print-procedure-option) +(define (check-for-illegal-untagged predicate-option + print-procedure-option + print-entity-procedure-option) (let ((test (lambda (option) (if (and option @@ -221,7 +232,8 @@ differences: (error "Structure option illegal for unnamed structure:" (option/original option)))))) (test predicate-option) - (test print-procedure-option))) + (test print-procedure-option) + (test print-entity-procedure-option))) (define (compute-constructors constructor-options keyword-constructor-options @@ -425,6 +437,13 @@ 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 @@ -538,9 +557,9 @@ differences: (define-record-type (make-structure context conc-name constructors keyword-constructors copier - predicate print-procedure physical-type named? - type-descriptor tag-expression safe-accessors? offset - slots) + predicate print-procedure print-entity-procedure + physical-type named? type-descriptor tag-expression + safe-accessors? offset slots) structure? (context structure/context) (conc-name structure/conc-name) @@ -549,6 +568,7 @@ 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) @@ -792,7 +812,8 @@ differences: (tag-expression (structure/tag-expression structure)) (slots (structure/slots structure)) (context (structure/context structure)) - (print-procedure (structure/print-procedure structure))) + (print-procedure (structure/print-procedure structure)) + (print-entity-procedure (structure/print-entity-procedure structure))) (let ((name (symbol->string (parser-context/name context))) (field-names (map slot/name slots)) (inits @@ -805,7 +826,8 @@ differences: ',name ',field-names (LIST ,@inits) - ,(close print-procedure context)) + ,(close print-procedure context) + ,(close print-entity-procedure context)) `(,(absolute 'MAKE-DEFINE-STRUCTURE-TYPE context) ',(structure/physical-type structure) ',name @@ -821,7 +843,10 @@ differences: '#F) ',(+ (if (structure/tagged? structure) 1 0) (structure/offset structure) - (length slots))))) + (length slots)) + ,(if (structure/tagged? structure) + (close print-entity-procedure context) + '#F)))) ,@(if (and tag-expression (not (eq? tag-expression type-name))) `((,(absolute 'NAMED-STRUCTURE/SET-TAG-DESCRIPTION! context) diff --git a/src/runtime/record.scm b/src/runtime/record.scm index 152aec62f..1741475d6 100644 --- a/src/runtime/record.scm +++ b/src/runtime/record.scm @@ -63,6 +63,7 @@ USA. (define record-type-type-tag) (define unparse-record) +(define record-entity-unparser) (define record-description) (define (initialize-record-type-type!) @@ -104,6 +105,15 @@ USA. (write-char #\space port) (write (dispatch-tag-contents tag) port)))) (else record-method)))))) + (set! record-entity-unparser + (make-generic-procedure 1 'RECORD-ENTITY-UNPARSER)) + (set-generic-procedure-default-generator! record-entity-unparser + (let ((default-method + (let ((method (standard-unparser-method 'ENTITY #f))) + (lambda (extra) extra method)))) + (lambda (generic tags) + generic tags ;ignore + default-method))) (set! %set-record-type-default-inits! %set-record-type-default-inits!/after-boot) (set! set-record-type-unparser-method! @@ -131,7 +141,8 @@ USA. (cons (list i (%record-ref record i)) d))))))))) (define (make-record-type type-name field-names - #!optional default-inits unparser-method) + #!optional + default-inits unparser-method entity-unparser-method) (let ((caller 'MAKE-RECORD-TYPE)) (guarantee-list-of-unique-symbols field-names caller) (let* ((names ((ucode-primitive list->vector) field-names)) @@ -149,6 +160,9 @@ USA. (%set-record-type-default-inits! record-type default-inits caller)) (if (not (default-object? unparser-method)) (set-record-type-unparser-method! record-type unparser-method)) + (if (not (default-object? entity-unparser-method)) + (set-record-type-entity-unparser-method! record-type + entity-unparser-method)) record-type))) (define (record-type? object) @@ -235,6 +249,16 @@ USA. ((vector-ref (%record-type-default-inits record-type) (fix:- field-name-index 1)))) +(define (record-type-extension record-type) + (guarantee-record-type record-type 'RECORD-TYPE-EXTENSION) + (%record-type-extension record-type)) + +(define (set-record-type-extension! record-type extension) + (guarantee-record-type record-type 'SET-RECORD-TYPE-EXTENSION!) + (%set-record-type-extension! record-type extension)) + +;;;; Unparser Methods + (define set-record-type-unparser-method! (named-lambda (set-record-type-unparser-method!/booting record-type method) (let loop ((ms deferred-unparser-methods)) @@ -264,13 +288,31 @@ USA. generic (and (eq? (cadr tags) tag) method))))))) -(define (record-type-extension record-type) - (guarantee-record-type record-type 'RECORD-TYPE-EXTENSION) - (%record-type-extension record-type)) +;;; It's not kosher to use this during the cold load. -(define (set-record-type-extension! record-type extension) - (guarantee-record-type record-type 'SET-RECORD-TYPE-EXTENSION!) - (%set-record-type-extension! record-type extension)) +(define (set-record-type-entity-unparser-method! record-type method) + (guarantee-record-type record-type 'SET-RECORD-TYPE-UNPARSER-METHOD!) + (if method + (guarantee-unparser-method method 'SET-RECORD-TYPE-UNPARSER-METHOD!)) + (let ((tag (%record-type-dispatch-tag record-type))) + (remove-generic-procedure-generators record-entity-unparser (list tag)) + (if method + ;; Kludge to make generic dispatch work. + (let ((method (lambda (extra) extra method))) + (add-generic-procedure-generator record-entity-unparser + (lambda (generic tags) + generic + (and (eq? (car tags) tag) method))))))) + +;;; To mimic UNPARSE-RECORD. Dunno whether anyone cares. + +(define (unparse-record-entity state entity) + (guarantee-unparser-state state 'UNPARSE-RECORD-ENTITY) + (if (entity? entity) + (guarantee-record (entity-extra entity) 'UNPARSE-RECORD-ENTITY) + (error:wrong-type-argument entity "record entity" + 'UNPARSE-RECORD-ENTITY)) + ((record-entity-unparser (entity-extra entity)) state entity)) (define (record-constructor record-type #!optional field-names) (guarantee-record-type record-type 'RECORD-CONSTRUCTOR) @@ -487,29 +529,17 @@ USA. ;;;; Runtime support for DEFINE-STRUCTURE -(define rtd:structure-type) -(define make-define-structure-type) -(define structure-type?) -(define structure-type/physical-type) -(define structure-type/name) -(define structure-type/field-names) -(define structure-type/field-indexes) -(define structure-type/default-inits) -(define structure-type/unparser-method) -(define set-structure-type/unparser-method!) -(define structure-type/tag) -(define structure-type/length) - (define (initialize-structure-type-type!) (set! rtd:structure-type (make-record-type "structure-type" '(PHYSICAL-TYPE NAME FIELD-NAMES FIELD-INDEXES DEFAULT-INITS UNPARSER-METHOD TAG - LENGTH))) + LENGTH ENTITY-UNPARSER-METHOD))) (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) + unparser-method tag length + #!optional entity-unparser-method) (constructor physical-type name field-names @@ -517,7 +547,10 @@ USA. default-inits unparser-method tag - length)))) + length + (if (default-object? entity-unparser-method) + #f + entity-unparser-method))))) (set! structure-type? (record-predicate rtd:structure-type)) (set! structure-type/physical-type @@ -538,7 +571,26 @@ USA. (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) +(define make-define-structure-type) +(define structure-type?) +(define structure-type/physical-type) +(define structure-type/name) +(define structure-type/field-names) +(define structure-type/field-indexes) +(define structure-type/default-inits) +(define structure-type/unparser-method) +(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) @@ -567,6 +619,11 @@ USA. (and type (structure-type/unparser-method type)))) +(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)))) + (define (named-structure? object) (cond ((record? object) #t) ((vector? object) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 19176487b..0a735f42c 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3222,6 +3222,7 @@ USA. record-constructor record-copy record-description + record-entity-unparser record-keyword-constructor record-modifier record-predicate @@ -3237,12 +3238,15 @@ USA. record-updater record? set-record-type-default-inits! + set-record-type-entity-unparser-method! set-record-type-extension! set-record-type-unparser-method! - unparse-record) + unparse-record + unparse-record-entity) (export (runtime record-slot-access) record-type-field-index) (export (runtime unparser) + structure-tag/entity-unparser-method structure-tag/unparser-method) (initialization (initialize-package!))) diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm index 5815a789c..01413a599 100644 --- a/src/runtime/unpars.scm +++ b/src/runtime/unpars.scm @@ -352,7 +352,7 @@ USA. (*unparse-string "#[keyword ") (unparse-symbol-name s) (*unparse-char #\])))) - + (define (unparse-symbol-name s) (if (or (string-find-next-char-in-set s @@ -476,6 +476,11 @@ USA. ;; 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) (limit-unparse-depth (lambda () @@ -558,6 +563,9 @@ USA. ;; 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) (*unparse-string prefix) (*unparse-object (safe-car (safe-cdr pair)))) @@ -707,7 +715,7 @@ USA. (unparse/flonum ((ucode-primitive floating-vector-ref) v i))) (if (< limit length) (*unparse-string " ...")))))))) - + (define (unparse/entity entity) (define (plain name) @@ -729,5 +737,18 @@ USA. (compiled-procedure/name proc)) => named-arity-dispatched-procedure) (else (plain 'ARITY-DISPATCHED-PROCEDURE))))) - (else - (plain 'ENTITY)))) \ No newline at end of file + (*unparse-with-maximum-readability?* + (*unparse-readable-hash entity)) + ((record? (entity-extra entity)) + ;; Kludge to make the generic dispatch mechanism work. + (invoke-user-method + (lambda (state entity) + ((record-entity-unparser (entity-extra entity)) state entity)) + entity)) + ((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))) + (else (plain 'ENTITY)))) \ No newline at end of file