From ba6061b439cf55be2d8bb48ec6f1b8afd81972ce Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 14 Mar 2016 23:59:00 -0700 Subject: [PATCH] Eliminate unparser/standard-method. * Allow name arg of simple-unparser-method and standard-unparser-method to be a procedure that computes the name. * Favor the use of simple-unparser-method where possible. * Implement general-unparser-method and bracketed-unparser-method. --- src/compiler/base/blocks.scm | 20 +++------ src/compiler/base/ctypes.scm | 24 +++++------ src/compiler/base/enumer.scm | 6 +-- src/compiler/base/lvalue.scm | 6 +-- src/compiler/base/object.scm | 15 ++----- src/compiler/base/proced.scm | 27 ++++++------ src/compiler/base/rvalue.scm | 18 ++++---- src/compiler/base/subprb.scm | 11 +++-- src/compiler/rtlbase/rtlobj.scm | 21 ++++----- src/compiler/rtlbase/valclass.scm | 6 +-- src/compiler/rtlopt/rcseht.scm | 3 +- src/compiler/rtlopt/rcserq.scm | 2 +- src/compiler/rtlopt/rdflow.scm | 6 +-- src/cref/object.scm | 29 +++++-------- src/edwin/bufwin.scm | 28 ++++++------ src/edwin/comman.scm | 12 +++--- src/edwin/display.scm | 7 ++- src/edwin/keyparse.scm | 14 +++--- src/edwin/modes.scm | 11 ++--- src/edwin/struct.scm | 19 ++++---- src/edwin/window.scm | 18 ++++---- src/gdbm/gdbm.scm | 8 ++-- src/imail/imail-core.scm | 7 ++- src/imail/imail-mime.scm | 7 ++- src/runtime/boot.scm | 72 +++++++++++++++---------------- src/runtime/gdbm.scm | 7 ++- src/runtime/graphics.scm | 7 ++- src/runtime/packag.scm | 7 ++- src/runtime/port.scm | 25 +++++------ src/runtime/record.scm | 7 ++- src/runtime/runtime.pkg | 5 ++- src/runtime/urtrap.scm | 10 ++--- src/runtime/win32-registry.scm | 14 +++--- src/runtime/x11graph.scm | 7 ++- src/sf/object.scm | 16 +++---- src/sf/pthmap.scm | 2 +- src/sos/class.scm | 9 ++-- src/sos/printer.scm | 5 +-- src/win32/module.scm | 6 +-- src/xml/xml-names.scm | 7 ++- src/xml/xml-struct.scm | 8 ++-- 41 files changed, 241 insertions(+), 298 deletions(-) diff --git a/src/compiler/base/blocks.scm b/src/compiler/base/blocks.scm index 4a8de7ed9..3cf00c417 100644 --- a/src/compiler/base/blocks.scm +++ b/src/compiler/base/blocks.scm @@ -113,19 +113,13 @@ from the continuation, and then "glued" into place afterwards. block)) (define-vector-tag-unparser block-tag - (lambda (state block) - ((standard-unparser - (symbol->string 'BLOCK) - (lambda (state block) - (unparse-object state - (enumeration/index->name block-types - (block-type block))) - (let ((procedure (block-procedure block))) - (if (and procedure (rvalue/procedure? procedure)) - (begin - (unparse-string state " ") - (unparse-label state (procedure-label procedure))))))) - state block))) + (simple-unparser-method "LIAR:block" + (lambda (block) + (cons (enumeration/index->name block-types (block-type block)) + (let ((procedure (block-procedure block))) + (if (and procedure (rvalue/procedure? procedure)) + (list (procedure-label procedure)) + '())))))) (define-integrable (rvalue/block? rvalue) (eq? (tagged-vector/tag rvalue) block-tag)) diff --git a/src/compiler/base/ctypes.scm b/src/compiler/base/ctypes.scm index 52f2e2ff2..5137f516a 100644 --- a/src/compiler/base/ctypes.scm +++ b/src/compiler/base/ctypes.scm @@ -59,19 +59,17 @@ USA. (make-scfg application '()))) (define-vector-tag-unparser application-tag - (lambda (state application) - ((case (application-type application) - ((COMBINATION) - (standard-unparser (symbol->string 'COMBINATION) false)) - ((RETURN) - (standard-unparser (symbol->string 'RETURN) - (lambda (state return) - (unparse-object state (return/operand return))))) - (else - (standard-unparser (symbol->string 'APPLICATION) - (lambda (state application) - (unparse-object state (application-type application)))))) - state application))) + (simple-unparser-method + (lambda (application) + (case (application-type application) + ((COMBINATION) "LIAR:combination") + ((RETURN) "LIAR:return") + (else "LIAR:application"))) + (lambda (application) + (case (application-type application) + ((COMBINATION) '()) + ((RETURN) (list (return/operand return))) + (else (list (application-type application))))))) (define-integrable (application-block application) (reference-context/block (application-context application))) diff --git a/src/compiler/base/enumer.scm b/src/compiler/base/enumer.scm index fe00fc2c0..844ea5ee7 100644 --- a/src/compiler/base/enumer.scm +++ b/src/compiler/base/enumer.scm @@ -38,9 +38,9 @@ USA. (define-structure (enumerand (conc-name enumerand/) (print-procedure - (standard-unparser (symbol->string 'ENUMERAND) - (lambda (state enumerand) - (unparse-object state (enumerand/name enumerand)))))) + (simple-unparser-method "LIAR:enumerand" + (lambda (enumerand) + (list (enumerand/name enumerand)))))) (enumeration false read-only true) (name false read-only true) (index false read-only true)) diff --git a/src/compiler/base/lvalue.scm b/src/compiler/base/lvalue.scm index 4ee0f93f8..dac9b4f7a 100644 --- a/src/compiler/base/lvalue.scm +++ b/src/compiler/base/lvalue.scm @@ -98,9 +98,9 @@ USA. (variable-normal-offset variable))) (define-vector-tag-unparser variable-tag - (standard-unparser (symbol->string 'VARIABLE) - (lambda (state variable) - (unparse-object state (variable-name variable))))) + (simple-unparser-method "LIAR:variable" + (lambda (variable) + (list (variable-name variable))))) (define-integrable (lvalue/variable? lvalue) (eq? (tagged-vector/tag lvalue) variable-tag)) diff --git a/src/compiler/base/object.scm b/src/compiler/base/object.scm index dbb581758..f7181730e 100644 --- a/src/compiler/base/object.scm +++ b/src/compiler/base/object.scm @@ -46,11 +46,10 @@ USA. (let ((root-tag (%make-vector-tag false 'OBJECT false false))) (set-vector-tag-%unparser! root-tag - (lambda (state object) - ((standard-unparser - (symbol->string (vector-tag-name (tagged-vector/tag object))) - false) - state object))) + (simple-unparser-method + (lambda (object) + (string "LIAR:" (vector-tag-name (tagged-vector/tag object)))) + #f)) (named-lambda (make-vector-tag parent name enumeration) (let ((tag (%make-vector-tag (or parent root-tag) @@ -149,12 +148,6 @@ USA. (else (error "Not a tagged vector" object)))) -(define (standard-unparser name unparser) - (let ((name (string-append (symbol->string 'LIAR) ":" name))) - (if unparser - (unparser/standard-method name unparser) - (unparser/standard-method name)))) - (define (tagged-vector/unparse state vector) (parameterize* (list (cons param:unparser-radix 16)) (lambda () diff --git a/src/compiler/base/proced.scm b/src/compiler/base/proced.scm index 71e00471b..41fd8f7b4 100644 --- a/src/compiler/base/proced.scm +++ b/src/compiler/base/proced.scm @@ -104,19 +104,20 @@ USA. procedure)) (define-vector-tag-unparser procedure-tag - (lambda (state procedure) - ((let ((type - (enumeration/index->name continuation-types - (procedure-type procedure)))) - (if (eq? type 'PROCEDURE) - (standard-unparser (symbol->string 'PROCEDURE) - (lambda (state procedure) - (unparse-label state (procedure-label procedure)))) - (standard-unparser (symbol->string (procedure-label procedure)) - (lambda (state procedure) - procedure - (unparse-object state type))))) - state procedure))) + (let ((get-type + (lambda (procedure) + (enumeration/index->name continuation-types + (procedure-type procedure))))) + (simple-unparser-method + (lambda (procedure) + (if (eq? (get-type procedure) 'PROCEDURE) + "LIAR:procedure" + (string "LIAR:" (procedure-label procedure)))) + (lambda (procedure) + (let ((type (get-type procedure))) + (if (eq? type 'PROCEDURE) + (list (procedure-label procedure)) + (list type))))))) (define-integrable (unparse-label state label) (unparse-string state (symbol->string label))) diff --git a/src/compiler/base/rvalue.scm b/src/compiler/base/rvalue.scm index 673ddaccd..c068f55b8 100644 --- a/src/compiler/base/rvalue.scm +++ b/src/compiler/base/rvalue.scm @@ -96,9 +96,9 @@ USA. constant)))) (define-vector-tag-unparser constant-tag - (standard-unparser (symbol->string 'CONSTANT) - (lambda (state constant) - (unparse-object state (constant-value constant))))) + (simple-unparser-method "LIAR:constant" + (lambda (constant) + (list (constant-value constant))))) (define-integrable (rvalue/constant? rvalue) (eq? (tagged-vector/tag rvalue) constant-tag)) @@ -114,9 +114,9 @@ USA. (make-rvalue reference-tag block lvalue safe?)) (define-vector-tag-unparser reference-tag - (standard-unparser (symbol->string 'REFERENCE) - (lambda (state reference) - (unparse-object state (variable-name (reference-lvalue reference)))))) + (simple-unparser-method "LIAR:reference" + (lambda (reference) + (list (variable-name (reference-lvalue reference)))))) (define-integrable (rvalue/reference? rvalue) (eq? (tagged-vector/tag rvalue) reference-tag)) @@ -150,9 +150,9 @@ USA. (make-rvalue unassigned-test-tag block lvalue)) (define-vector-tag-unparser unassigned-test-tag - (standard-unparser (symbol->string 'UNASSIGNED-TEST) - (lambda (state unassigned-test) - (unparse-object state (unassigned-test-lvalue unassigned-test))))) + (simple-unparser-method "LIAR:unassigned-test" + (lambda (unassigned-test) + (list (unassigned-test-lvalue unassigned-test))))) (define-integrable (rvalue/unassigned-test? rvalue) (eq? (tagged-vector/tag rvalue) unassigned-test-tag)) diff --git a/src/compiler/base/subprb.scm b/src/compiler/base/subprb.scm index c2533673b..313587b97 100644 --- a/src/compiler/base/subprb.scm +++ b/src/compiler/base/subprb.scm @@ -114,14 +114,13 @@ known that the continuation need not be used. (constructor virtual-continuation/%make) (conc-name virtual-continuation/) (print-procedure - (standard-unparser (symbol->string 'VIRTUAL-CONTINUATION) - (lambda (state continuation) + (simple-unparser-method "LIAR:virtual-continuation" + (lambda (continuation) (let ((type (virtual-continuation/type continuation))) (if type - (unparse-object - state - (enumeration/index->name continuation-types - type)))))))) + (list (enumeration/index->name continuation-types + type)) + '())))))) context parent type diff --git a/src/compiler/rtlbase/rtlobj.scm b/src/compiler/rtlbase/rtlobj.scm index f258bbe99..dd2f339e0 100644 --- a/src/compiler/rtlbase/rtlobj.scm +++ b/src/compiler/rtlbase/rtlobj.scm @@ -33,9 +33,9 @@ USA. (constructor make-rtl-expr (rgraph label entry-edge debugging-info)) (print-procedure - (standard-unparser (symbol->string 'RTL-EXPR) - (lambda (state expression) - (unparse-object state (rtl-expr/label expression)))))) + (simple-unparser-method "LIAR:rtl-expr" + (lambda (expression) + (list (rtl-expr/label expression)))))) (rgraph false read-only true) (label false read-only true) (entry-edge false read-only true) @@ -53,10 +53,9 @@ USA. debugging-info next-continuation-offset stack-leaf?)) (print-procedure - (standard-unparser (symbol->string 'RTL-PROCEDURE) - (lambda (state procedure) - (unparse-object state - (rtl-procedure/label procedure)))))) + (simple-unparser-method "LIAR:rtl-procedure" + (lambda (procedure) + (list (rtl-procedure/label procedure)))))) (rgraph false read-only true) (label false read-only true) (entry-edge false read-only true) @@ -88,11 +87,9 @@ USA. next-continuation-offset debugging-info)) (print-procedure - (standard-unparser (symbol->string 'RTL-CONTINUATION) - (lambda (state continuation) - (unparse-object - state - (rtl-continuation/label continuation)))))) + (simple-unparser-method "LIAR:rtl-continuation" + (lambda (continuation) + (list (rtl-continuation/label continuation)))))) (rgraph false read-only true) (label false read-only true) (entry-edge false read-only true) diff --git a/src/compiler/rtlbase/valclass.scm b/src/compiler/rtlbase/valclass.scm index 6a7e045ee..cbad13a8d 100644 --- a/src/compiler/rtlbase/valclass.scm +++ b/src/compiler/rtlbase/valclass.scm @@ -32,9 +32,9 @@ USA. (conc-name value-class/) (constructor %make-value-class (name parent)) (print-procedure - (unparser/standard-method 'VALUE-CLASS - (lambda (state class) - (unparse-object state (value-class/name class)))))) + (simple-unparser-method 'VALUE-CLASS + (lambda (class) + (list (value-class/name class)))))) (name false read-only true) (parent false read-only true) (children '()) diff --git a/src/compiler/rtlopt/rcseht.scm b/src/compiler/rtlopt/rcseht.scm index e832a1a25..f405ca52d 100644 --- a/src/compiler/rtlopt/rcseht.scm +++ b/src/compiler/rtlopt/rcseht.scm @@ -47,8 +47,7 @@ USA. (define-structure (element (constructor %make-element) (constructor make-element (expression)) - (print-procedure - (standard-unparser (symbol->string 'ELEMENT) false))) + (print-procedure (simple-unparser-method "LIAR:element" #f))) (expression false read-only true) (cost false) (in-memory? false) diff --git a/src/compiler/rtlopt/rcserq.scm b/src/compiler/rtlopt/rcserq.scm index 280379d07..f58b3aff8 100644 --- a/src/compiler/rtlopt/rcserq.scm +++ b/src/compiler/rtlopt/rcserq.scm @@ -32,7 +32,7 @@ USA. (define-structure (quantity (copier quantity-copy) (print-procedure - (standard-unparser (symbol->string 'QUANTITY) false))) + (simple-unparser-method "LIAR:quantity" #f))) (number false read-only true) (first-register false) (last-register false)) diff --git a/src/compiler/rtlopt/rdflow.scm b/src/compiler/rtlopt/rdflow.scm index 592265b1d..fc067b6d5 100644 --- a/src/compiler/rtlopt/rdflow.scm +++ b/src/compiler/rtlopt/rdflow.scm @@ -72,9 +72,9 @@ USA. (conc-name rnode/) (constructor make-rnode (register)) (print-procedure - (unparser/standard-method 'RNODE - (lambda (state rnode) - (unparse-object state (rnode/register rnode)))))) + (simple-unparser-method 'RNODE + (lambda (rnode) + (list (rnode/register rnode)))))) (register false read-only true) (forward-links '()) (backward-links '()) diff --git a/src/cref/object.scm b/src/cref/object.scm index 8cc588a1e..2f593a50e 100644 --- a/src/cref/object.scm +++ b/src/cref/object.scm @@ -51,10 +51,9 @@ USA. (constructor make-package (name parent)) (conc-name package/) (print-procedure - (standard-unparser-method 'PACKAGE - (lambda (package port) - (write-char #\space port) - (write (package/name package) port))))) + (simple-unparser-method 'PACKAGE + (lambda (package) + (list (package/name package)))))) (name #f read-only #t) (files '()) parent @@ -108,13 +107,10 @@ USA. (constructor %make-binding (package name value-cell new?)) (conc-name binding/) (print-procedure - (standard-unparser-method 'BINDING - (lambda (binding port) - (write-char #\space port) - (write (binding/name binding) port) - (write-char #\space port) - (write (package/name (binding/package binding)) - port))))) + (simple-unparser-method 'BINDING + (lambda (binding) + (list (binding/name binding) + (package/name (binding/package binding))))))) (package #f read-only #t) (name #f read-only #t) (value-cell #f read-only #t) @@ -173,13 +169,10 @@ USA. (constructor %make-reference (package name)) (conc-name reference/) (print-procedure - (standard-unparser-method 'REFERENCE - (lambda (reference port) - (write-char #\space port) - (write (reference/name reference) port) - (write-char #\space port) - (write (package/name (reference/package reference)) - port))))) + (simple-unparser-method 'REFERENCE + (lambda (reference) + (list (reference/name reference) + (package/name (reference/package reference))))))) (package #f read-only #t) (name #f read-only #t) (expressions '()) diff --git a/src/edwin/bufwin.scm b/src/edwin/bufwin.scm index d40f154ef..db9696268 100644 --- a/src/edwin/bufwin.scm +++ b/src/edwin/bufwin.scm @@ -501,12 +501,12 @@ USA. (define-structure (outline (constructor %make-outline) (print-procedure - (unparser/standard-method 'OUTLINE - (lambda (state outline) - (unparse-string state "index: ") - (unparse-object state (outline-index-length outline)) - (unparse-string state " y: ") - (unparse-object state (outline-y-size outline)))))) + (standard-unparser-method 'OUTLINE + (lambda (outline port) + (write-string "index: " port) + (write (outline-index-length outline) port) + (write-string " y: " port) + (write (outline-y-size outline) port))))) ;; The number of characters in the text line. This is exclusive of ;; the newlines at the line's beginning and end, if any. index-length @@ -569,16 +569,16 @@ USA. (define-structure (o3 (constructor %make-o3) (print-procedure - (unparser/standard-method 'O3 - (lambda (state o3) - (unparse-string state "index: ") - (unparse-object state (o3-index o3)) - (unparse-string state " y: ") - (unparse-object state (o3-y o3)) + (standard-unparser-method 'O3 + (lambda (o3 port) + (write-string "index: " port) + (write (o3-index o3) port) + (write-string " y: " port) + (write (o3-y o3) port) (if (outline? (o3-outline o3)) (begin - (unparse-string state " ") - (unparse-object state (o3-outline o3)))))))) + (write-string " " port) + (write (o3-outline o3) port))))))) outline index y) diff --git a/src/edwin/comman.scm b/src/edwin/comman.scm index 2c7fef752..8efa08794 100644 --- a/src/edwin/comman.scm +++ b/src/edwin/comman.scm @@ -31,9 +31,9 @@ USA. (define-structure (command (constructor %make-command ()) (print-procedure - (unparser/standard-method 'COMMAND - (lambda (state command) - (unparse-object state (command-name command)))))) + (simple-unparser-method 'COMMAND + (lambda (command) + (list (command-name command)))))) name %description interactive-specification @@ -103,9 +103,9 @@ USA. (define-structure (variable (constructor %make-variable ()) (print-procedure - (unparser/standard-method 'VARIABLE - (lambda (state variable) - (unparse-object state (variable-name variable)))))) + (simple-unparser-method 'VARIABLE + (lambda (variable) + (list (variable-name variable)))))) name %description %value diff --git a/src/edwin/display.scm b/src/edwin/display.scm index d35828b48..8026735b2 100644 --- a/src/edwin/display.scm +++ b/src/edwin/display.scm @@ -33,10 +33,9 @@ USA. (conc-name display-type/) (constructor %make-display-type) (print-procedure - (unparser/standard-method 'DISPLAY-TYPE - (lambda (state display-type) - (unparse-object state - (display-type/name display-type)))))) + (simple-unparser-method 'DISPLAY-TYPE + (lambda (display-type) + (list (display-type/name display-type)))))) (name false read-only true) (multiple-screens? false read-only true) (operation/available? false read-only true) diff --git a/src/edwin/keyparse.scm b/src/edwin/keyparse.scm index 3ee896f80..dcb28a0ba 100644 --- a/src/edwin/keyparse.scm +++ b/src/edwin/keyparse.scm @@ -120,10 +120,9 @@ USA. (keyword-constructor make-keyparser-fragment) (conc-name keyparser-fragment/) (print-procedure - (standard-unparser-method 'KEYPARSER-FRAGMENT - (lambda (fragment port) - (write-char #\space port) - (write (keyparser-fragment/keyword fragment) port))))) + (simple-unparser-method 'KEYPARSER-FRAGMENT + (lambda (fragment) + (list (keyparser-fragment/keyword fragment)))))) ;; Keyword that introduces the structure. (keyword #f read-only #t) @@ -326,10 +325,9 @@ See \\[complete-keyword]." (define-structure (keyparser-stack-entry (conc-name keyparser-stack-entry/) (print-procedure - (standard-unparser-method 'KEYPARSER-STACK-ENTRY - (lambda (entry port) - (write-char #\space port) - (write (keyparser-stack-entry/keyword entry) port))))) + (simple-unparser-method 'KEYPARSER-STACK-ENTRY + (lambda (entry) + (list (keyparser-stack-entry/keyword entry)))))) (pattern #f read-only #t) (index #f read-only #t) (start #f read-only #t)) diff --git a/src/edwin/modes.scm b/src/edwin/modes.scm index e44b69c8a..29e0e58f9 100644 --- a/src/edwin/modes.scm +++ b/src/edwin/modes.scm @@ -33,11 +33,12 @@ USA. (name major? display-name super-mode %description initialization comtabs)) (print-procedure - (unparser/standard-method 'MODE - (lambda (state mode) - (unparse-object state (mode-name mode)) - (if (not (mode-major? mode)) - (unparse-string state " (minor)")))))) + (simple-unparser-method 'MODE + (lambda (mode) + (cons (mode-name mode) + (if (mode-major? mode) + '() + (list '(minor)))))))) (name #f read-only #t) major? display-name diff --git a/src/edwin/struct.scm b/src/edwin/struct.scm index 332d10bc7..ae4dbcf35 100644 --- a/src/edwin/struct.scm +++ b/src/edwin/struct.scm @@ -306,17 +306,14 @@ USA. (define-structure (mark (constructor make-temporary-mark) (print-procedure - (unparser/standard-method 'MARK - (lambda (state mark) - (unparse-object state - (or (mark-buffer mark) - (mark-group mark))) - (unparse-string state " ") - (unparse-object state (mark-index mark)) - (unparse-string state - (if (mark-left-inserting? mark) - " left" - " right")))))) + (simple-unparser-method 'MARK + (lambda (mark) + (list (or (mark-buffer mark) + (mark-group mark)) + (mark-index mark) + (if (mark-left-inserting? mark) + 'left + 'right)))))) ;; The microcode file "edwin.h" depends on the definition of this ;; structure. (group #f read-only #t) diff --git a/src/edwin/window.scm b/src/edwin/window.scm index c592c2d48..4e5468802 100644 --- a/src/edwin/window.scm +++ b/src/edwin/window.scm @@ -364,16 +364,16 @@ USA. (vector-set! inferior 4 redisplay-flags)) (unparser/set-tagged-vector-method! %inferior-tag - (unparser/standard-method 'INFERIOR - (lambda (state inferior) - (unparse-object state (inferior-window inferior)) - (unparse-string state " x,y=(") - (unparse-object state (inferior-x-start inferior)) - (unparse-string state ",") - (unparse-object state (inferior-y-start inferior)) - (unparse-string state ")") + (standard-unparser-method 'INFERIOR + (lambda (inferior port) + (write (inferior-window inferior) port) + (write-string " x,y=(" port) + (write (inferior-x-start inferior) port) + (write-string "," port) + (write (inferior-y-start inferior) port) + (write-string ")" port) (if (inferior-needs-redisplay? inferior) - (unparse-string state " needs-redisplay"))))) + (write-string " needs-redisplay" port))))) (define (inferior-copy inferior) (%make-inferior (inferior-window inferior) diff --git a/src/gdbm/gdbm.scm b/src/gdbm/gdbm.scm index 9a6c5142f..02a68f8ff 100644 --- a/src/gdbm/gdbm.scm +++ b/src/gdbm/gdbm.scm @@ -234,11 +234,9 @@ USA. (define-structure (gdbf (constructor make-gdbf) (print-procedure - (standard-unparser-method - 'GDBF - (lambda (gdbf port) - (write-char #\space port) - (write (gdbf-filename gdbf) port))))) + (simple-unparser-method 'GDBF + (lambda (gdbf) + (list (gdbf-filename gdbf)))))) ;; Note that communicating through this malloced-per-GDBM_FILE ;; helper struct assumes there are no callbacks possible during gdbm ;; operations (via which this procedure could be called multiple diff --git a/src/imail/imail-core.scm b/src/imail/imail-core.scm index d8a02c795..43c9ff3e4 100644 --- a/src/imail/imail-core.scm +++ b/src/imail/imail-core.scm @@ -967,10 +967,9 @@ USA. (safe-accessors #t) (constructor #f) (print-procedure - (standard-unparser-method 'HEADER-FIELD - (lambda (header port) - (write-char #\space port) - (write (header-field-name header) port))))) + (simple-unparser-method 'HEADER-FIELD + (lambda (header) + (list (header-field-name header)))))) (name #f read-only #t) (value #f read-only #t)) diff --git a/src/imail/imail-mime.scm b/src/imail/imail-mime.scm index 8aabc1392..a2bb0172c 100644 --- a/src/imail/imail-mime.scm +++ b/src/imail/imail-mime.scm @@ -752,10 +752,9 @@ USA. (define-structure (mime-encoding (conc-name mime-encoding/) (print-procedure - (standard-unparser-method 'MIME-ENCODING - (lambda (encoding output-port) - (write-char #\space output-port) - (write (mime-encoding/name encoding) output-port)))) + (simple-unparser-method 'MIME-ENCODING + (lambda (encoding) + (list (mime-encoding/name encoding))))) (constructor %make-mime-encoding)) (name #f read-only #t) (identity? #f read-only #t) diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm index 80997d75e..495e3523a 100644 --- a/src/runtime/boot.scm +++ b/src/runtime/boot.scm @@ -30,20 +30,16 @@ USA. (declare (usual-integrations)) (define (standard-unparser-method name unparser) - (make-method name - (and unparser - (lambda (state object) - (with-current-unparser-state state - (lambda (port) - (unparser object port))))))) + (make-method name unparser)) (define (simple-unparser-method name method) (standard-unparser-method name - (lambda (object port) - (for-each (lambda (object) - (write-char #\space port) - (write object port)) - (method object))))) + (and method + (lambda (object port) + (for-each (lambda (object) + (write-char #\space port) + (write object port)) + (method object)))))) (define (simple-parser-method procedure) (lambda (objects lose) @@ -51,33 +47,37 @@ USA. (procedure (cddr objects))) (lose)))) -(define (unparser/standard-method name #!optional unparser) - (make-method name - (and (not (default-object? unparser)) - unparser - (lambda (state object) - (unparse-char state #\space) - (unparser state object))))) - (define (make-method name unparser) + (general-unparser-method + (lambda (object port) + (let ((hash-string (number->string (hash object)))) + (if (get-param:unparse-with-maximum-readability?) + (begin + (write-string "#@" port) + (write-string hash-string port)) + (begin + (write-string "#[" port) + (let loop ((name name)) + (cond ((string? name) (write-string name port)) + ((procedure? name) (loop (name object))) + (else (write name port)))) + (write-char #\space port) + (write-string hash-string port) + (if unparser (unparser object port)) + (write-char #\] port))))))) + +(define (general-unparser-method unparser) (lambda (state object) - (let ((port (unparser-state/port state)) - (hash-string (number->string (hash object)))) - (if (get-param:unparse-with-maximum-readability?) - (begin - (write-string "#@" port) - (write-string hash-string port)) - (begin - (write-string "#[" port) - (if (string? name) - (write-string name port) - (with-current-unparser-state state - (lambda (port) - (write name port)))) - (write-char #\space port) - (write-string hash-string port) - (if unparser (unparser state object)) - (write-char #\] port)))))) + (with-current-unparser-state state + (lambda (port) + (unparser object port))))) + +(define (bracketed-unparser-method unparser) + (general-unparser-method + (lambda (object port) + (write-string "#[" port) + (unparser object port) + (write-char #\] port)))) (define (unparser-method? object) (and (procedure? object) diff --git a/src/runtime/gdbm.scm b/src/runtime/gdbm.scm index f3f645371..f9c4723b9 100644 --- a/src/runtime/gdbm.scm +++ b/src/runtime/gdbm.scm @@ -118,10 +118,9 @@ USA. opt val))) (define-structure (gdbf - (print-procedure (standard-unparser-method 'GDBF - (lambda (gdbf port) - (write-char #\space port) - (write (gdbf-filename gdbf) port))))) + (print-procedure (simple-unparser-method 'GDBF + (lambda (gdbf) + (list (gdbf-filename gdbf)))))) descriptor (filename #f read-only #t)) diff --git a/src/runtime/graphics.scm b/src/runtime/graphics.scm index 0b513b1a8..d0dfc93f3 100644 --- a/src/runtime/graphics.scm +++ b/src/runtime/graphics.scm @@ -53,10 +53,9 @@ USA. operation/set-line-style custom-operations)) (print-procedure - (standard-unparser-method 'GRAPHICS-TYPE - (lambda (type port) - (write-char #\space port) - (write (graphics-device-type/name type) port))))) + (simple-unparser-method 'GRAPHICS-TYPE + (lambda (type) + (list (graphics-device-type/name type)))))) (name false read-only true) (operation/available? false read-only true) (operation/clear false read-only true) diff --git a/src/runtime/packag.scm b/src/runtime/packag.scm index 4c2c73cbe..94a75dafa 100644 --- a/src/runtime/packag.scm +++ b/src/runtime/packag.scm @@ -75,10 +75,9 @@ USA. (set! package-tag tag) (for-each (lambda (p) (%record-set! p 0 tag)) *packages*)) (set-record-type-unparser-method! rtd - (standard-unparser-method 'PACKAGE - (lambda (package port) - (write-char #\space port) - (write (package/name package) port)))))) + (simple-unparser-method 'PACKAGE + (lambda (package) + (list (package/name package))))))) (define (name->package name) (find-package name #f)) diff --git a/src/runtime/port.scm b/src/runtime/port.scm index 853a5ca0b..80688081e 100644 --- a/src/runtime/port.scm +++ b/src/runtime/port.scm @@ -52,18 +52,16 @@ USA. (discretionary-flush-output #f read-only #t)) (set-record-type-unparser-method! - (lambda (state type) - ((standard-unparser-method - (if (port-type/supports-input? type) - (if (port-type/supports-output? type) - 'I/O-PORT-TYPE - 'INPUT-PORT-TYPE) - (if (port-type/supports-output? type) - 'OUTPUT-PORT-TYPE - 'PORT-TYPE)) - #f) - state - type))) + (standard-unparser-method + (lambda (type) + (if (port-type/supports-input? type) + (if (port-type/supports-output? type) + 'I/O-PORT-TYPE + 'INPUT-PORT-TYPE) + (if (port-type/supports-output? type) + 'OUTPUT-PORT-TYPE + 'PORT-TYPE))) + #f)) (define (guarantee-port-type object #!optional caller) (if (not (port-type? object)) @@ -497,9 +495,6 @@ USA. (cond ((port/operation port 'WRITE-SELF) => (lambda (operation) (standard-unparser-method name operation))) - ((port/operation port 'PRINT-SELF) - => (lambda (operation) - (unparser/standard-method name operation))) (else (standard-unparser-method name #f)))) state diff --git a/src/runtime/record.scm b/src/runtime/record.scm index 619c6ba05..f123f0aa0 100644 --- a/src/runtime/record.scm +++ b/src/runtime/record.scm @@ -103,10 +103,9 @@ USA. (write-char #\space port) (display (%record-type-name type) port)))) ((eq? tag (built-in-dispatch-tag 'DISPATCH-TAG)) - (standard-unparser-method 'DISPATCH-TAG - (lambda (tag port) - (write-char #\space port) - (write (dispatch-tag-contents tag) port)))) + (simple-unparser-method 'DISPATCH-TAG + (lambda (tag) + (list (dispatch-tag-contents tag))))) (else record-method)))))) (set! record-entity-unparser (make-generic-procedure 1 'RECORD-ENTITY-UNPARSER)) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index a79798544..05104d2e3 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -138,10 +138,12 @@ USA. (files "boot") (parent (runtime)) (export () + bracketed-unparser-method default-object default-object? error:not-unparser-method gc-space-status + general-unparser-method guarantee-unparser-method interrupt-bit/after-gc interrupt-bit/gc @@ -162,7 +164,6 @@ USA. simple-unparser-method standard-unparser-method unparser-method? - unparser/standard-method with-absolutely-no-interrupts with-limited-interrupts without-interrupts) @@ -2147,9 +2148,11 @@ USA. (export () (eq-hash-table-type key-weak-eq-hash-table-type) (eqv-hash-table-type key-weak-eqv-hash-table-type) + (hash-table-clear! hash-table/clear!) (hash-table-delete! hash-table/remove!) (hash-table-equivalence-function hash-table/key=?) (hash-table-hash-function hash-table/key-hash) + (hash-table-intern! hash-table/intern!) (hash-table-keys hash-table/key-list) (hash-table-ref/default hash-table/get) (hash-table-set! hash-table/put!) diff --git a/src/runtime/urtrap.scm b/src/runtime/urtrap.scm index 025403693..7a60cef8f 100644 --- a/src/runtime/urtrap.scm +++ b/src/runtime/urtrap.scm @@ -33,13 +33,11 @@ USA. (type vector) (named '|#[(runtime reference-trap)reference-trap]|) (print-procedure - (standard-unparser-method 'REFERENCE-TRAP - (lambda (trap port) - (write-char #\space port) - (write (let ((kind (reference-trap-kind trap))) + (simple-unparser-method 'REFERENCE-TRAP + (lambda (trap) + (list (let ((kind (reference-trap-kind trap))) (or (reference-trap-kind-name kind) - kind)) - port))))) + kind))))))) (kind #f read-only #t) (extra #f read-only #t)) diff --git a/src/runtime/win32-registry.scm b/src/runtime/win32-registry.scm index 8dfca62e8..b6408ccb6 100644 --- a/src/runtime/win32-registry.scm +++ b/src/runtime/win32-registry.scm @@ -138,10 +138,9 @@ USA. (constructor %make-registry-key (parent name handle)) (predicate win32-registry/key?) (print-procedure - (standard-unparser-method 'REGISTRY-KEY - (lambda (key port) - (write-char #\space port) - (write (registry-key-name key) port))))) + (simple-unparser-method 'REGISTRY-KEY + (lambda (key) + (list (registry-key-name key)))))) (name #f read-only #t) (parent #f read-only #t) (handle #f) @@ -163,10 +162,9 @@ USA. (define-structure (registry-value (print-procedure - (standard-unparser-method 'REGISTRY-VALUE - (lambda (key port) - (write-char #\space port) - (write (registry-value-name key) port))))) + (simple-unparser-method 'REGISTRY-VALUE + (lambda (key) + (list (registry-value-name key)))))) (name #f read-only #t) (type #f)) diff --git a/src/runtime/x11graph.scm b/src/runtime/x11graph.scm index 543862422..cdf9985bf 100644 --- a/src/runtime/x11graph.scm +++ b/src/runtime/x11graph.scm @@ -221,10 +221,9 @@ USA. (conc-name x-display/) (constructor make-x-display (name xd)) (print-procedure - (standard-unparser-method 'X-DISPLAY - (lambda (display port) - (write-char #\space port) - (write (x-display/name display) port))))) + (simple-unparser-method 'X-DISPLAY + (lambda (display) + (list (x-display/name display)))))) (name #f read-only #t) xd (window-finalizer (make-gc-finalizer (ucode-primitive x-close-window 1) diff --git a/src/sf/object.scm b/src/sf/object.scm index 76e84d2a2..254c9d91c 100644 --- a/src/sf/object.scm +++ b/src/sf/object.scm @@ -190,11 +190,9 @@ USA. (conc-name variable/) (constructor variable/make (block name flags)) (print-procedure - (standard-unparser-method - 'variable - (lambda (var port) - (write-string " " port) - (write (variable/name var) port))))) + (simple-unparser-method 'variable + (lambda (var) + (list (variable/name var)))))) block name flags) @@ -601,11 +599,9 @@ USA. (conc-name reference/) (constructor reference/make) (print-procedure - (standard-unparser-method - 'reference - (lambda (ref port) - (write-string " to " port) - (write (variable/name (reference/variable ref)) port))))) + (simple-unparser-method 'reference + (lambda (ref) + (list (variable/name (reference/variable ref))))))) (scode #f read-only #t) block variable) diff --git a/src/sf/pthmap.scm b/src/sf/pthmap.scm index 396c36ab0..c099bc512 100644 --- a/src/sf/pthmap.scm +++ b/src/sf/pthmap.scm @@ -41,7 +41,7 @@ USA. (unparser/set-tagged-pair-method! pathname-map/tag - (unparser/standard-method "PATHNAME-MAP")) + (standard-unparser-method "PATHNAME-MAP" #f)) (declare (integrate-operator node/make)) diff --git a/src/sos/class.scm b/src/sos/class.scm index f817aaf86..25ca74e7e 100644 --- a/src/sos/class.scm +++ b/src/sos/class.scm @@ -33,13 +33,12 @@ USA. (constructor %make-class (name direct-superclasses direct-slots)) (print-procedure - (standard-unparser-method 'CLASS - (lambda (class port) + (simple-unparser-method 'CLASS + (lambda (class) (let ((name (class-name class))) (if name - (begin - (write-char #\space port) - (write name port)))))))) + (list name) + '())))))) (name #f read-only #t) (direct-superclasses #f read-only #t) (direct-slots #f read-only #t) diff --git a/src/sos/printer.scm b/src/sos/printer.scm index 33e3365a7..966897310 100644 --- a/src/sos/printer.scm +++ b/src/sos/printer.scm @@ -107,10 +107,7 @@ USA. (and (let ((class (dispatch-tag-contents (cadr tags)))) (and (class? class) (subclass? class ))) - (lambda (state instance) - (with-current-unparser-state state - (lambda (port) - (write-instance instance port))))))) + (general-unparser-method write-instance)))) (add-generic-procedure-generator pp-description (lambda (generic tags) diff --git a/src/win32/module.scm b/src/win32/module.scm index 7964d31ba..c53b98c47 100644 --- a/src/win32/module.scm +++ b/src/win32/module.scm @@ -44,9 +44,9 @@ USA. (conc-name module/) (constructor %make-module) (print-procedure - (unparser/standard-method 'MODULE - (lambda (state module) - (unparse-object state (module/load-name module)))))) + (simple-unparser-method 'MODULE + (lambda (module) + (list (module/load-name module)))))) load-name handle entries ;; a protection list of all the functions from this module diff --git a/src/xml/xml-names.scm b/src/xml/xml-names.scm index e18648727..24e8d1539 100644 --- a/src/xml/xml-names.scm +++ b/src/xml/xml-names.scm @@ -92,10 +92,9 @@ USA. (expanded combo-name-expanded)) (set-record-type-unparser-method! - (standard-unparser-method 'XML-NAME - (lambda (name port) - (write-char #\space port) - (write (combo-name-qname name) port)))) + (simple-unparser-method 'XML-NAME + (lambda (name) + (list (combo-name-qname name))))) (define-record-type (make-expanded-name uri local combos) diff --git a/src/xml/xml-struct.scm b/src/xml/xml-struct.scm index c160307b4..6e3109879 100644 --- a/src/xml/xml-struct.scm +++ b/src/xml/xml-struct.scm @@ -461,11 +461,9 @@ USA. (let ((root (symbol-append 'XML- name))) `(SET-RECORD-TYPE-UNPARSER-METHOD! ,(close-syntax (symbol-append '< root '>) environment) - (STANDARD-UNPARSER-METHOD ',root - (LAMBDA (,name PORT) - (WRITE-CHAR #\SPACE PORT) - (WRITE (,(close-syntax accessor environment) ,name) - PORT)))))) + (SIMPLE-UNPARSER-METHOD ',root + (LAMBDA (,name) + (LIST (,(close-syntax accessor environment) ,name))))))) (ill-formed-syntax form))))) (define-xml-printer processing-instructions xml-processing-instructions-name) -- 2.25.1