From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001 From: Yale AI Dept Date: Wed, 14 Jul 1993 13:08:00 -0500 Subject: Import to github. --- printers/util.scm | 214 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 214 insertions(+) create mode 100644 printers/util.scm (limited to 'printers/util.scm') diff --git a/printers/util.scm b/printers/util.scm new file mode 100644 index 0000000..498aa25 --- /dev/null +++ b/printers/util.scm @@ -0,0 +1,214 @@ +;;; util.scm -- utilities for printing AST structures +;;; +;;; author : Sandra Loosemore +;;; date : 15 Jan 1992 +;;; +;;; + + +;;; The AST syntax printers are only used if this variable is true. + +(define *print-ast-syntax* '#t) + + +;;; Here's a macro for defining AST printers. + +(define-syntax (define-ast-printer type lambda-list . body) + (let ((printer (symbol-append 'write- type))) + `(begin + (define (,printer ,@lambda-list) ,@body) + (define-struct-printer ,type ,printer)) + )) + + +;;; This variable controls how much indentation to perform on block +;;; bodies. + +(define *print-ast-indent* 2) + + +;;; Begin a logical block with the default indentation. + +(define-syntax (with-ast-block xp-stuff . body) + (let ((xp (car xp-stuff))) + `(pprint-logical-block (,xp '() "" "") + (pprint-indent 'block (dynamic *print-ast-indent*) ,xp) + (pprint-pop) ; prevents unused variable warning + ,@body))) + + +;;; Write a space and maybe a fill line break. + +(define (write-whitespace xp) + (write-char #\space xp) + (pprint-newline 'fill xp)) + + +;;; Write a space and maybe a mandatory line break. + +(define (write-newline xp) + (write-char #\space xp) + (pprint-newline 'mandatory xp)) + + + +;;; Write a list of things separated by delimiters and maybe +;;; surrounded by delimiters. + +(define (write-delimited-list objects xp fn delim prefix suffix) + (pprint-logical-block (xp '() prefix suffix) + (do ((objects objects (cdr objects))) + ((null? objects) '#f) + (pprint-pop) + (funcall fn (car objects) xp) + (when (cdr objects) + (write-string delim xp) + (write-whitespace xp))))) + + +;;; Here's a couple common special cases of the above. + +(define (write-commaized-list objects xp) + (write-delimited-list objects xp (function write) "," "(" ")")) + +(define (write-ordinary-list objects xp) + (write-delimited-list objects xp (function write) "" "" "")) + + +;;; Here's another helper function that's used to implement the layout +;;; rule. The layout rule is only used to format output if *print-pretty* +;;; is true. +;;; *** should do pprint-indent here? + +(define (write-layout-rule objects xp fn) + (pprint-logical-block (xp '() + (if (dynamic *print-pretty*) "" "{") + (if (dynamic *print-pretty*) "" "}")) + (do ((objects objects (cdr objects))) + ((null? objects) '#f) + (pprint-pop) + (funcall fn (car objects) xp) + (when (cdr objects) + (if (dynamic *print-pretty*) + (pprint-newline 'mandatory xp) + (write-string "; " xp)))))) + + +;;; This filters a list of decls, removing the recursive marker added by +;;; dependency analysis. + +(define (remove-recursive-grouping decls) + (cond ((null? decls) '()) + ((is-type? 'recursive-decl-group (car decls)) + (append (recursive-decl-group-decls (car decls)) + (remove-recursive-grouping (cdr decls)))) + (else + (cons (car decls) (remove-recursive-grouping (cdr decls)))))) + +;;; Write where-decls, using the layout rule if appropriate. + +(define (write-wheredecls decls xp) + (when (not (null? decls)) + (write-whitespace xp) + (write-string "where" xp) + (write-whitespace xp) + (write-layout-rule (remove-recursive-grouping decls) xp (function write)))) + + +;;; Write an ordinary variable name. + +(define (write-avarid name xp) + (write-string (symbol->string name) xp)) + + +;;; Constructor name symbols have a funny prefix attached; have to strip +;;; this off, so can't just print the symbol using write-avarid. + +(define (write-aconid name xp) + (let ((s (symbol->string name))) + (write-string (substring s 1 (string-length s)) xp))) + + +;;; There are a couple places where conids and varids are mixed up +;;; together. + +(define (conid? name) + (eqv? (string-ref (symbol->string name) 0) #\;)) + +(define (write-varop-conop name xp) + (if (conid? name) + (write-conop name xp) + (write-varop name xp))) + +(define (write-varid-conid name xp) + (if (conid? name) + (write-conid name xp) + (write-varid name xp))) + + + +;;; Stuff for writing a variable name as either an operator or an ordinary +;;; variable ID. This is necessary because some kinds of symbol names +;;; default to being operators and others default to being ordinary names. +;;; Bleah.... + + +(define (write-varop name xp) + (if (avarid? name) + (begin + (write-char #\` xp) + (write-avarid name xp) + (write-char #\` xp)) + (write-avarid name xp))) + +(define (write-varid name xp) + (if (avarid? name) + (write-avarid name xp) + (begin + (write-char #\( xp) + (write-avarid name xp) + (write-char #\) xp)))) + + +;;; This tests for alphabetic rather than lower-case characters +;;; so that gensym'ed variables with uppercase names don't print funny. + +(define (avarid? name) + (let ((ch (string-ref (symbol->string name) 0))) + (char-alphabetic? ch))) + + +;;; Similar stuff for doing constructor names. Moby bleah.... + +(define (write-conop name xp) + (if (aconid? name) + (begin + (write-char #\` xp) + (write-aconid name xp) + (write-char #\` xp)) + (write-aconid name xp))) + +(define (write-conid name xp) + (if (aconid? name) + (write-aconid name xp) + (begin + (write-char #\( xp) + (write-aconid name xp) + (write-char #\) xp)))) + +(define (aconid? name) + (let ((ch (string-ref (symbol->string name) 1))) + (char-upper-case? ch))) + + +;;; These are officially aconid in the syntax, but they aren't +;;; prefixed so write them using write-avarid instead. Barf. + +(define (write-modid name xp) + (write-avarid name xp)) + +(define (write-tyconid name xp) + (write-avarid name xp)) + +(define (write-tyclsid name xp) + (write-avarid name xp)) -- cgit v1.2.3