diff options
Diffstat (limited to 'support')
| -rw-r--r-- | support/README | 4 | ||||
| -rw-r--r-- | support/compile.scm | 447 | ||||
| -rw-r--r-- | support/format.scm | 683 | ||||
| -rw-r--r-- | support/mumble.txt | 840 | ||||
| -rw-r--r-- | support/pprint.scm | 1788 | ||||
| -rw-r--r-- | support/support.scm | 35 | ||||
| -rw-r--r-- | support/system.scm | 51 | ||||
| -rw-r--r-- | support/utils.scm | 408 |
8 files changed, 4256 insertions, 0 deletions
diff --git a/support/README b/support/README new file mode 100644 index 0000000..6127bc6 --- /dev/null +++ b/support/README @@ -0,0 +1,4 @@ +This directory contains utilities that are layered on top of the basic +mumble support stuff. There should be no T-specific or CL-specific +code in this area. + diff --git a/support/compile.scm b/support/compile.scm new file mode 100644 index 0000000..77e222f --- /dev/null +++ b/support/compile.scm @@ -0,0 +1,447 @@ +;;; compile.scm -- compilation utilities +;;; +;;; author : Sandra Loosemore +;;; date : 24 Oct 1991 +;;; +;;; This file defines a makefile-like compilation system that supports +;;; a hierarchy of dependencies. +;;; The external entry points are define-compilation-unit, load-unit, and +;;; compile-and-load-unit. + + + +;;;===================================================================== +;;; Parsing +;;;===================================================================== + + +;;; Establish global defaults for filenames. + +(define compile.source-filename source-file-type) +(define compile.binary-filename binary-file-type) +(define compile.binary-subdir (string-append lisp-implementation-name "/")) +(define compile.delayed-loads '()) + + +;;; Top level units are stored in this table. +;;; This is really a slight wart on the whole scheme of things; this +;;; is done instead of storing the top-level units in variables because +;;; we were getting unintentional name collisions. + +(define compile.unit-table (make-table)) + +(define-syntax (compile.lookup-unit name) + `(table-entry compile.unit-table ,name)) + +(define (mung-global-units names lexical-units) + (map (lambda (n) + (if (memq n lexical-units) + n + `(compile.lookup-unit ',n))) + names)) + + +;;; Top-level compilation units are defined with define-compilation-unit. +;;; The body can consist of the following clauses: +;;; +;;; (source-filename <filename>) +;;; (binary-filename <filename>) +;;; Specify source and/or binary file names. For nested units, these +;;; are merged with defaults from outer units. If you don't specify +;;; an explicit binary filename, it's inherited from the source file +;;; name. +;;; (require ...) +;;; Specify compile/load dependencies. Arguments are names of other +;;; units/component files; these names have scoping like let*, so a unit +;;; can require previously listed units at the same or outer level. +;;; (unit name ....) +;;; Specifies a nested unit. This can appear multiple times. +;;; If a unit doesn't include any nested units, then it's a leaf +;;; consisting of a single source file. +;;; (load <boolean>) +;;; If supplied and false, the unit isn't loaded unless it is needed +;;; to satisfy a require clause. Used for files containing compilation +;;; support stuff. +;;; (compile <boolean>) +;;; If supplied and false, the unit isn't compiled. Only useful for +;;; leaf nodes. Typically used in combination with (load '#f) to suppress +;;; compilation of stuff only used at compile time. + +(define-syntax (define-compilation-unit name . clauses) + `(begin + (let ((unit ,(compile.process-unit-spec name clauses '#t '()))) + (setf (compile.lookup-unit ',name) unit) + (setf compilation-units (append compilation-units (list unit)))) + ',name)) + + +;;; The basic approach is to turn the compilation unit definition into +;;; a big LET*, and put calls to build the actual unit object inside +;;; of this. +;;; + +(define (compile.process-unit-spec name clauses top-level? lexical-units) + (multiple-value-bind + (source-filename binary-filename require nested-units + load? compile?) + (compile.parse-unit-spec clauses lexical-units) + `(let* ((compile.source-filename ,source-filename) + (compile.binary-filename ,binary-filename) + (compile.unit-require (list ,@require)) + (compile.delayed-loads (append compile.delayed-loads + (compile.select-delayed-loads + compile.unit-require))) + ,@nested-units) + (make compile.unit + (name ',name) + (source-filename compile.source-filename) + (binary-filename compile.binary-filename) + (components (list ,@(map (function car) nested-units))) + (require compile.unit-require) + (top-level? ',top-level?) + (load? ,load?) + (compile? ,compile?) + (delayed-loads compile.delayed-loads))))) + +(define (compile.parse-unit-spec clauses lexical-units) + (let ((source-filename '#f) + (binary-filename '#f) + (require '#f) + (nested-units '()) + (load? ''#t) + (compile? ''#t)) + (dolist (c clauses) + (cond ((not (pair? c)) + (compile.unit-syntax-error c)) + ((eq? (car c) 'source-filename) + (if source-filename + (compile.unit-duplicate-error c) + (setf source-filename (cadr c)))) + ((eq? (car c) 'binary-filename) + (if binary-filename + (compile.unit-duplicate-error c) + (setf binary-filename (cadr c)))) + ((eq? (car c) 'require) + (if require + (compile.unit-duplicate-error c) + (setf require (mung-global-units (cdr c) lexical-units)))) + ((eq? (car c) 'unit) + (push (list (cadr c) + (compile.process-unit-spec (cadr c) (cddr c) + '#f lexical-units)) + nested-units) + (push (cadr c) lexical-units)) + ((eq? (car c) 'load) + (setf load? (cadr c))) + ((eq? (car c) 'compile) + (setf compile? (cadr c))) + (else + (compile.unit-syntax-error c)))) + (values + (if source-filename + `(compile.merge-filenames ,source-filename + compile.source-filename '#f) + 'compile.source-filename) + (if binary-filename + `(compile.merge-filenames ,binary-filename + compile.binary-filename '#f) + (if source-filename + '(compile.merge-filenames compile.binary-filename + compile.source-filename + compile.binary-subdir) + 'compile.binary-filename)) + (or require '()) + (nreverse nested-units) + load? + compile?))) + + +(predefine (error format . args)) + +(define (compile.unit-syntax-error c) + (error "Invalid compilation unit clause ~s." c)) + +(define (compile.unit-duplicate-error c) + (error "Duplicate compilation unit clause ~s." c)) + + + +;;;===================================================================== +;;; Representation and utilities +;;;===================================================================== + +;;; Here are constructors and accessors for unit objects. +;;; Implementationally, the compilation unit has the following slots: +;;; +;;; * The unit name. +;;; * The source file name. +;;; * The binary file name. +;;; * A list of component file/units. +;;; * A list of units/files to require. +;;; * A load timestamp. +;;; * A timestamp to keep track of the newest source file. +;;; * Flags for compile and load. + +(define-struct compile.unit + (predicate compile.unit?) + (slots + (name (type symbol)) + (source-filename (type string)) + (binary-filename (type string)) + (components (type list)) + (require (type list)) + (top-level? (type bool)) + (load? (type bool)) + (compile? (type bool)) + (delayed-loads (type list)) + (load-time (type (maybe integer)) (default '#f)) + (source-time (type (maybe integer)) (default '#f)) + (last-update (type (maybe integer)) (default 0)) + )) + +(define (compile.newer? t1 t2) + (and t1 + t2 + (> t1 t2))) + +(define (compile.select-newest t1 t2) + (if (compile.newer? t1 t2) t1 t2)) + +(define (compile.get-source-time u) + (let ((source-file (compile.unit-source-filename u))) + (if (file-exists? source-file) + (file-write-date source-file) + '#f))) + +(define (compile.get-binary-time u) + (let ((binary-file (compile.unit-binary-filename u))) + (if (file-exists? binary-file) + (file-write-date binary-file) + '#f))) + +(define (compile.load-source u) + (load (compile.unit-source-filename u)) + (setf (compile.unit-load-time u) (current-date))) + +(define (compile.load-binary u) + (load (compile.unit-binary-filename u)) + (setf (compile.unit-load-time u) (current-date))) + +(define (compile.compile-and-load u) + (let ((source-file (compile.unit-source-filename u)) + (binary-file (compile.unit-binary-filename u))) + (compile-file source-file binary-file) + (load binary-file) + (setf (compile.unit-load-time u) (current-date)))) + +(define (compile.do-nothing u) + u) + + +;;;===================================================================== +;;; Runtime support for define-compilation-unit +;;;===================================================================== + +(define (compile.select-delayed-loads require) + (let ((result '())) + (dolist (r require) + (if (not (compile.unit-load? r)) + (push r result))) + (nreverse result))) + +(define (compile.merge-filenames fname1 fname2 add-subdir) + (let ((place1 (filename-place fname1)) + (name1 (filename-name fname1)) + (type1 (filename-type fname1))) + (assemble-filename + (if (string=? place1 "") + (if add-subdir + (string-append (filename-place fname2) add-subdir) + fname2) + place1) + (if (string=? name1 "") fname2 name1) + (if (string=? type1 "") fname2 type1)))) + + + +;;;===================================================================== +;;; Load operation +;;;===================================================================== + +;;; Load-unit and compile-and-load-unit are almost identical. The only +;;; difference is that load-unit will load source files as necessary, while +;;; compile-and-load-unit will compile them and load binaries instead. + +(define (load-unit u) + (compile.update-unit-source-times u '#f (current-date)) + (compile.load-unit-aux u)) + +(define (compile.load-unit-aux u) + (with-compilation-unit () + (compile.load-unit-recursive u '#f))) + +(define (compile-and-load-unit u) + (compile.update-unit-source-times u '#f (current-date)) + (compile.compile-and-load-unit-aux u)) + +(define (compile.compile-and-load-unit-aux u) + (with-compilation-unit () + (compile.load-unit-recursive u '#t))) + + +;;; Load a bunch of compilation units as a group. This is useful because +;;; it can prevent repeated lookups of file timestamps. Basically, the +;;; assumption is that none of the source files will change while the loading +;;; is in progress. +;;; In case of an error, store the units left to be compiled in a global +;;; variable. + +(define remaining-units '()) + +(define (load-unit-list l) + (let ((timestamp (current-date))) + (dolist (u l) + (compile.update-unit-source-times u '#f timestamp)) + (setf remaining-units l) + (dolist (u l) + (compile.load-unit-aux u) + (pop remaining-units)))) + +(define (compile-and-load-unit-list l) + (let ((timestamp (current-date))) + (dolist (u l) + (compile.update-unit-source-times u '#f timestamp)) + (setf remaining-units l) + (dolist (u l) + (compile.compile-and-load-unit-aux u) + (pop remaining-units)))) + + +;;; Walk the compilation unit, updating the source timestamps. + +(define (compile.update-unit-source-times u newest-require timestamp) + (unless (eqv? timestamp (compile.unit-last-update u)) + (setf (compile.unit-last-update u) timestamp) + (dolist (r (compile.unit-require u)) + (if (compile.unit-top-level? r) + (compile.update-unit-source-times r '#f timestamp)) + (setf newest-require + (compile.select-newest newest-require + (compile.unit-source-time r)))) + (let ((components (compile.unit-components u))) + (if (not (null? components)) + (let ((source-time newest-require)) + (dolist (c components) + (compile.update-unit-source-times c newest-require timestamp) + (setf source-time + (compile.select-newest source-time + (compile.unit-source-time c)))) + (setf (compile.unit-source-time u) source-time)) + (setf (compile.unit-source-time u) + (compile.select-newest + newest-require + (compile.get-source-time u))))))) + + +;;; Load a compilation unit. Do this by first loading its require list, +;;; then by recursively loading each of its components, in sequence. +;;; Note that because of the way scoping of units works and the +;;; sequential nature of the load operation, only top-level +;;; units in the require list have to be loaded explicitly. + +(define (compile.load-unit-recursive u compile?) + (let ((components (compile.unit-components u))) + ;; First recursively load dependencies. + ;; No need to update time stamps again here. + (dolist (r (compile.unit-require u)) + (if (compile.unit-top-level? r) + (compile.load-unit-aux r))) + (if (not (null? components)) + ;; Now recursively load subunits. + (dolist (c components) + (unless (not (compile.unit-load? c)) + (compile.load-unit-recursive c compile?))) + ;; For a leaf node, load either source or binary if necessary. + (let ((source-time (compile.unit-source-time u)) + (binary-time (compile.get-binary-time u)) + (load-time (compile.unit-load-time u))) + (cond ((compile.newer? load-time source-time) + ;; The module has been loaded since it was last changed, + ;; but maybe we want to compile it now. + (if (and compile? + (compile.unit-compile? u) + (compile.newer? source-time binary-time)) + (begin + (compile.do-delayed-loads + (compile.unit-delayed-loads u) + compile?) + (compile.compile-and-load u)) + (compile.do-nothing u))) + ((compile.newer? binary-time source-time) + ;; The binary is up-to-date, so load it. + (compile.load-binary u)) + (else + ;; The binary is out-of-date, so either load source or + ;; recompile the binary. + (compile.do-delayed-loads + (compile.unit-delayed-loads u) + compile?) + (if (and compile? (compile.unit-compile? u)) + (compile.compile-and-load u) + (compile.load-source u))) + ))))) + + +(define (compile.do-delayed-loads units compile?) + (dolist (u units) + (compile.load-unit-recursive u compile?))) + + + + +;;;===================================================================== +;;; Extra stuff +;;;===================================================================== + + +;;; Reload a unit without testing to see if any of its dependencies are +;;; out of date. + +(define (reload-unit-source u) + (let ((components (compile.unit-components u))) + (if (not (null? components)) + (dolist (c components) + (reload-unit-source c)) + (compile.load-source u)))) + +(define (reload-unit-binary u) + (let ((components (compile.unit-components u))) + (if (not (null? components)) + (dolist (c components) + (reload-unit-binary c)) + (compile.load-binary u)))) + + +;;; Find a (not necessarily top-level) compilation unit with the given +;;; name. + +(define (find-unit name) + (compile.find-unit-aux name compilation-units)) + +(define (compile.find-unit-aux name units) + (block find-unit-aux + (dolist (u units '#f) + (if (eq? name (compile.unit-name u)) + (return-from find-unit-aux u) + (let* ((components (compile.unit-components u)) + (result (compile.find-unit-aux name components))) + (if result + (return-from find-unit-aux result))))))) + + +;;; Combine the two above: reload a compilation unit. + +(define-syntax (reload name) + `(reload-unit-source + (or (find-unit ',name) + (error "Couldn't find unit named ~s." ',name)))) diff --git a/support/format.scm b/support/format.scm new file mode 100644 index 0000000..c9dbb38 --- /dev/null +++ b/support/format.scm @@ -0,0 +1,683 @@ +;;; format.scm -- format function for Scheme +;;; +;;; author : Sandra Loosemore +;;; date : 29 Oct 1991 +;;; +;;; +;;; This code is adapted from the XP pretty printer originally written +;;; in Common Lisp by Dick Waters. Here is the copyright notice attached +;;; to the original XP source file: +;;; +;;;------------------------------------------------------------------------ +;;; +;;; Copyright 1989,1990 by the Massachusetts Institute of Technology, +;;; Cambridge, Massachusetts. +;;; +;;; Permission to use, copy, modify, and distribute this software and its +;;; documentation for any purpose and without fee is hereby granted, +;;; provided that this copyright and permission notice appear in all +;;; copies and supporting documentation, and that the name of M.I.T. not +;;; be used in advertising or publicity pertaining to distribution of the +;;; software without specific, written prior permission. M.I.T. makes no +;;; representations about the suitability of this software for any +;;; purpose. It is provided "as is" without express or implied warranty. +;;; +;;; M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING +;;; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL +;;; M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR +;;; ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, +;;; WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, +;;; ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS +;;; SOFTWARE. +;;; +;;;------------------------------------------------------------------------ +;;; + + +;;; The stream argument can be #f, in which case a string is returned. +;;; If the stream is #t, (current-output-port) is used. +;;; We compile a string argument into a function and call the function. +;;; The only exception is if the string doesn't contain any ~ escapes; +;;; then we can treat it as a literal and just write it to the stream. + +(define (format stream string-or-fn . args) + (cond ((not stream) + (call-with-output-string + (lambda (stream) + (apply (function format) stream string-or-fn args)))) + (else + (if (eq? stream '#t) + (setf stream (current-output-port))) + (when (string? string-or-fn) + (setf string-or-fn (xp.process-format-string string-or-fn))) + (if (string? string-or-fn) + (write-string string-or-fn stream) + (xp.maybe-initiate-xp-printing string-or-fn stream args)) + '#f))) + +(define xp.format-string-cache (make-table)) + +(define (xp.process-format-string string-or-fn) + (cond ((not (string? string-or-fn)) string-or-fn) + ((not xp.format-string-cache) + (xp.maybe-compile-format-string string-or-fn)) + (else + (when (not (table? xp.format-string-cache)) + (setf xp.format-string-cache (make-table))) + (let ((value + (table-entry xp.format-string-cache string-or-fn))) + (when (not value) + (setf value (xp.maybe-compile-format-string string-or-fn)) + (setf (table-entry xp.format-string-cache string-or-fn) + value)) + value)))) + + +(define (xp.maybe-compile-format-string string) + (let ((length (string-length string))) + (or (xp.simple-format-string? string 0 length) + (let ((fn (xp.parse-format-string string 0 length))) + (lambda (xp args) + (funcall fn xp args args)))))) + + +;;; Try to detect format strings without fancy directives, that can be +;;; written with a call to write-string. +;;; Can do simple transformations e.g. ~% => newline, ~~ => ~, etc. + +(define (xp.simple-format-string? s start end) + (let ((twiddle (string-position #\~ s start end))) + (if (not twiddle) + (if (eqv? start 0) + s + (substring s start end)) + (let ((char (string-ref s (1+ twiddle)))) + (cond ((eqv? char #\%) + (let ((tail (xp.simple-format-string? s (+ twiddle 2) end))) + (if tail + (string-append (substring s start twiddle) + (string #\newline) + tail) + '#f))) + ((eqv? char #\~) + (let ((tail (xp.simple-format-string? s (+ twiddle 2) end))) + (if tail + (string-append (substring s start (1+ twiddle)) + tail) + '#f))) + ((eqv? char #\newline) + (let ((tail (xp.simple-format-string? + s + (xp.skip-whitespace s (+ twiddle 2) end) + end))) + (if tail + (string-append (substring s start twiddle) + tail) + '#f))) + (else + '#f)))))) + +(define (warning string-or-fn . args) + (internal-warning (apply (function format) '#f string-or-fn args))) + +(define (error string-or-fn . args) + (internal-error (apply (function format) '#f string-or-fn args))) + + +;;;===================================================================== +;;; Compiled format +;;;===================================================================== + +;;; Note that compiled format strings always print through xp streams even if +;;; they don't have any xp directives in them. As a result, the compiled code +;;; can depend on the fact that the stream being operated on is an xp +;;; stream not an ordinary one. + + +;;; Parse a format string, returning a function to do the printing. +;;; The function is called with three arguments +;;; * the xp stream +;;; * the original argument list +;;; * the argument list tail +;;; It should return the list of leftover, unprocessed arguments. + +(define (xp.parse-format-string string start end) + (cond ((eqv? start end) + (function xp.format-finish)) + ((eqv? (string-ref string start) #\~) + (xp.parse-format-string-dispatch string start end)) + (else + (let* ((next (or (string-position #\~ string start end) end)) + (literal (substring string start next)) + (count (- next start)) + (continue (xp.parse-format-string string next end)) + (newline? (string-position #\newline literal 0 count))) + (if newline? + (lambda (xp args tail) + (xp.write-string+ literal xp 0 count) + (funcall continue xp args tail)) + (lambda (xp args tail) + (xp.write-string++ literal xp 0 count) + (funcall continue xp args tail))))) + )) + +(define (xp.format-finish xp args tail) + (declare (ignore xp args)) + tail) + + +;;; Functions for handling individual format specifiers are installed +;;; in this table. They are called with these arguments: +;;; * the format string +;;; * the index of the next character +;;; * the index of the end of the format string +;;; * the list of parameters for the format specification +;;; * a boolean indicating whether the colon modifier was present +;;; * a boolean indicating whether the atsign modifier was present +;;; The handler is responsible for calling xp.parse-format-string to parse +;;; the rest of the format string, and returning a function. (This has +;;; to be done by the individual handlers because some of them need to +;;; scan the format string for matching delimiters, etc.) + +;;; *** This probably isn't right, we assume characters can be compared +;;; *** with EQ? and used as table keys. + +(define xp.fn-table (make-table)) + +(define (define-format char function) + (setf (table-entry xp.fn-table (char-upcase char)) function) + (setf (table-entry xp.fn-table (char-downcase char)) function)) + +;;; Parse a ~ sequence from the format string and dispatch to the +;;; appropriate handler. + +(define (xp.parse-format-string-dispatch string start end) + (multiple-value-bind (next params colon? atsign? char) + (xp.parse-format-descriptor string start end) + (let ((fn (table-entry xp.fn-table char))) + (if fn + (funcall fn string next end params colon? atsign?) + (error "Unrecognized format escape ~~~a." char))))) + +(define (xp.parse-format-descriptor string start end) + (multiple-value-bind (params start) + (xp.parse-format-parameters string start end) + (let ((colon? '#f) + (atsign? '#f) + (char '#f)) + (block parse-format-descriptor + (do () + ((xp.check-for-incomplete-format-string string start end)) + (setf char (string-ref string start)) + (incf start) + (cond ((eqv? char #\:) + (setf colon? '#t)) + ((eqv? char #\@) + (setf atsign? '#t)) + (else + (return-from parse-format-descriptor + (values start params colon? atsign? char))) + )))))) + + +;;; *** The stuff for V and # format parameters is disabled because +;;; *** it makes the handler functions hairier. It's rarely used anyway, +;;; *** and you can get the same effect by consing up a format string +;;; *** on the fly if you really need to. + +(define (xp.parse-format-parameters string start end) + (let ((params '()) + (char '#f)) + (incf start) ; skip ~ + (block parse-format-parameters + (do () + ((xp.check-for-incomplete-format-string string start end)) + (setf char (string-ref string start)) + (cond ((char-numeric? char) + (multiple-value-bind (next value) + (xp.parse-format-number string start end 0) + (setf start next) + (push value params))) + ((eqv? char #\') + (push (string-ref string (1+ start)) params) + (setf start (+ start 2))) + ((or (eqv? char #\v) (eqv? char #\V)) + (error "V format parameter not supported.") ;*** + (push 'value params) + (setf start (+ start 1))) + ((eqv? char #\#) + (error "# format parameter not supported.") ;*** + (push 'count params) + (setf start (+ start 1))) + ((eqv? char #\,) + (push '#f params)) + (else + (return-from parse-format-parameters + (values (nreverse params) start)))) + (if (eqv? (string-ref string start) #\,) + (incf start)))))) + +(define (xp.parse-format-number string start end value) + (xp.check-for-incomplete-format-string string start end) + (let* ((char (string-ref string start)) + (weight (string-position char "0123456789" 0 10))) + (if weight + (xp.parse-format-number string (1+ start) end (+ (* value 10) weight)) + (values start value)))) + +(define (xp.check-for-incomplete-format-string string start end) + (if (eqv? start end) + (error "Incomplete format string ~s." string) + '#f)) + + +;;; *** All of these format handlers probably ought to do more checking +;;; *** for the right number of parameters and not having colon? and +;;; *** atsign? supplied when they are not allowed. + +;;; ~A and ~S are the basic format directives. + +(define (xp.format-a string start end params colon? atsign?) + (xp.format-a-s-helper string start end params colon? atsign? '#f)) +(define-format #\a (function xp.format-a)) + +(define (xp.format-s string start end params colon? atsign?) + (xp.format-a-s-helper string start end params colon? atsign? '#t)) +(define-format #\s (function xp.format-s)) + +(define (xp.format-a-s-helper string start end params colon? atsign? escape?) + (declare (ignore colon? atsign?)) ;*** + (let ((continuation (xp.parse-format-string string start end))) + (if (null? params) + ;; Do the simple, common case. + (lambda (xp args tail) + (dynamic-let ((*print-escape* escape?)) + (xp.write+ (car tail) xp)) + (funcall continuation xp args (cdr tail))) + ;; Do the hard case. + (let* ((mincol (or (and (not (null? params)) (pop params)) 0)) + (colinc (or (and (not (null? params)) (pop params)) 1)) + (minpad (or (and (not (null? params)) (pop params)) 0)) + (padchar (or (and (not (null? params)) (pop params)) #\space))) + (declare (ignore mincol colinc minpad padchar)) ;*** +;;; *** I'm confused. It seems like we have to print this to a string +;;; *** and then write the string to the XP stream along with the padding +;;; *** But won't switching to a new stream mess up circularity detection, +;;; *** indentation, etc? + (error "Unimplemented format option ~s!" string)) + ))) + + +;;; ~W -> write + +(define (xp.format-w string start end params colon? atsign?) + (declare (ignore params)) + (let ((continuation (xp.parse-format-string string start end))) + (cond ((and (not colon?) (not atsign?)) + (lambda (xp args tail) + (xp.write+ (car tail) xp) + (funcall continuation xp args (cdr tail)))) + ((and colon? (not atsign?)) + (lambda (xp args tail) + (dynamic-let ((*print-pretty* '#t)) + (xp.write+ (car tail) xp)) + (funcall continuation xp args (cdr tail)))) + ((and (not colon?) atsign?) + (lambda (xp args tail) + (dynamic-let ((*print-level* '#f) + (*print-length* '#f)) + (xp.write+ (car tail) xp)) + (funcall continuation xp args (cdr tail)))) + ((and colon? atsign?) + (lambda (xp args tail) + (dynamic-let ((*print-level* '#f) + (*print-length* '#f) + (*print-pretty* '#t)) + (xp.write+ (car tail) xp)) + (funcall continuation xp args (cdr tail)))) + ))) +(define-format #\w (function xp.format-w)) + + +;;; Here are the directives for printing integers, ~D and friends. + +(define (xp.format-d string start end params colon? atsign?) + (xp.format-d-b-o-x-helper string start end params colon? atsign? 10)) +(define-format #\d (function xp.format-d)) + +(define (xp.format-b string start end params colon? atsign?) + (xp.format-d-b-o-x-helper string start end params colon? atsign? 2)) +(define-format #\b (function xp.format-b)) + +(define (xp.format-o string start end params colon? atsign?) + (xp.format-d-b-o-x-helper string start end params colon? atsign? 8)) +(define-format #\o (function xp.format-o)) + +(define (xp.format-x string start end params colon? atsign?) + (xp.format-d-b-o-x-helper string start end params colon? atsign? 16)) +(define-format #\x (function xp.format-x)) + +(define (xp.format-d-b-o-x-helper string start end params colon? atsign? radix) + (let ((continuation (xp.parse-format-string string start end))) + (if (and (null? params) (not colon?) (not atsign?)) + ;; Do the simple, common case. + (lambda (xp args tail) + (dynamic-let ((*print-escape* '#f) + (*print-radix* '#f) + (*print-base* radix)) + (xp.write+ (car tail) xp)) + (funcall continuation xp args (cdr tail))) + ;; Do the hard case. + (let* ((mincol (or (and (not (null? params)) (pop params)) 0)) + (padchar (or (and (not (null? params)) (pop params)) #\space)) + (commachar (or (and (not (null? params)) (pop params)) #\,)) + (commaint (or (and (not (null? params)) (pop params)) 3))) + (declare (ignore mincol padchar commachar commaint)) ;*** + ;; *** I'm too lazy to do this right now. + (error "Unimplemented format option ~s!" string))))) + + +(define (xp.format-r string start end params colon? atsign?) + (if (not (null? params)) + (xp.format-d-b-o-x-helper string start end (cdr params) + colon? atsign? (car params)) + ;; *** The colon? and atsign? modifiers do weird things like + ;; *** printing roman numerals. I'm too lazy to do this until/unless + ;; *** we have a real need for it. + (error "Unimplemented format option ~s!" string))) +(define-format #\r (function xp.format-r)) + + +;;; ~P -> plurals + +(define (xp.format-p string start end params colon? atsign?) + (declare (ignore params)) + (let ((continuation (xp.parse-format-string string start end))) + (cond ((and (not colon?) (not atsign?)) + (lambda (xp args tail) + (if (not (eqv? (car tail) 1)) + (xp.write-char++ #\s xp)) + (funcall continuation xp args (cdr tail)))) + ((and colon? (not atsign?)) + (lambda (xp args tail) + (setf tail (xp.back-up 1 args tail)) + (if (not (eqv? (car tail) 1)) + (xp.write-char++ #\s xp)) + (funcall continuation xp args (cdr tail)))) + ((and (not colon?) atsign?) + (lambda (xp args tail) + (if (eqv? (car tail) 1) + (xp.write-char++ #\y xp) + (begin + (xp.write-char++ #\i xp) + (xp.write-char++ #\e xp) + (xp.write-char++ #\s xp))) + (funcall continuation xp args (cdr tail)))) + ((and colon? atsign?) + (lambda (xp args tail) + (setf tail (xp.back-up 1 args tail)) + (if (eqv? (car tail) 1) + (xp.write-char++ #\y xp) + (begin + (xp.write-char++ #\i xp) + (xp.write-char++ #\e xp) + (xp.write-char++ #\s xp))) + (funcall continuation xp args (cdr tail))))))) +(define-format #\p (function xp.format-p)) + + +;;; ~C -> character + +(define (xp.format-c string start end params colon? atsign?) + (declare (ignore params)) + (let ((continuation (xp.parse-format-string string start end))) + (cond ((and (not colon?) (not atsign?)) + (lambda (xp args tail) + (xp.write-char++ (car tail) xp) + (funcall continuation xp args (cdr tail)))) + ((and (not colon?) atsign?) + (lambda (xp args tail) + (dynamic-let ((*print-escape* '#t)) + (xp.write+ (car tail) xp) + (funcall continuation xp args (cdr tail))))) + (else + ;; *** I don't know how to get at the character names. + (error "Unimplemented format option ~s!" string))))) +(define-format #\c (function xp.format-c)) + + + +;;; Newline directives, ~% and ~& + +(define (xp.format-percent string start end params colon? atsign?) + (xp.format-newline-helper string start end params colon? atsign? + 'unconditional)) +(define-format #\% (function xp.format-percent)) + +(define (xp.format-ampersand string start end params colon? atsign?) + (xp.format-newline-helper string start end params colon? atsign? + 'fresh)) +(define-format #\& (function xp.format-ampersand)) + +(define (xp.format-newline-helper string start end params colon? atsign? kind) + (declare (ignore colon? atsign?)) + (let ((continuation (xp.parse-format-string string start end)) + (n (or (and (not (null? params)) (pop params)) 1))) + (if (eqv? n 1) + (lambda (xp args tail) + (xp.pprint-newline+ kind xp) + (funcall continuation xp args tail)) + (lambda (xp args tail) + (xp.pprint-newline+ kind xp) + (dotimes (i (1- n)) + (xp.pprint-newline+ 'unconditional xp)) + (funcall continuation xp args tail)) + ))) + + +;;; ~_, Conditional newline + +(define (xp.format-underbar string start end params colon? atsign?) + (declare (ignore params)) + (let ((continuation (xp.parse-format-string string start end)) + (kind (if colon? + (if atsign? 'mandatory 'fill) + (if atsign? 'miser 'linear)))) + (lambda (xp args tail) + (xp.pprint-newline+ kind xp) + (funcall continuation xp args tail)))) +(define-format #\_ (function xp.format-underbar)) + + +;;; Random character printing directives, ~| and ~~ + +;;; *** commented out because #\page is not standard scheme +; (define (xp.format-bar string start end params colon? atsign?) +; (xp.format-char-helper string start end params colon? atsign? #\page)) +; (define-format #\| (function xp.format-bar)) + +(define (xp.format-twiddle string start end params colon? atsign?) + (xp.format-char-helper string start end params colon? atsign? #\~)) +(define-format #\~ (function xp.format-twiddle)) + +(define (xp.format-char-helper string start end params colon? atsign? char) + (declare (ignore colon? atsign?)) + (let ((continuation (xp.parse-format-string string start end)) + (n (or (and (not (null? params)) (pop params)) 1))) + (if (eqv? n 1) + (lambda (xp args tail) + (xp.write-char++ char xp) + (funcall continuation xp args tail)) + (lambda (xp args tail) + (dotimes (i n) + (xp.write-char++ char xp)) + (funcall continuation xp args tail))))) + + + +;;; ~<newline> directive (ignore whitespace in format string) + +(define (xp.format-newline string start end params colon? atsign?) + (declare (ignore params)) + (let ((newline? '#f) + (skip? '#f)) + (cond ((and (not colon?) (not atsign?)) ; skip both newline and whitespace + (setf skip? '#t)) + ((and colon? (not atsign?))) ; skip newline, leave whitespace + ((and (not colon?) atsign?) ; do newline, skip whitespace + (setf newline? '#t) + (setf skip? '#t)) + (else + (error "~:@<newline> not allowed."))) + (if skip? + (setf start (xp.skip-whitespace string start end))) + (let ((continuation (xp.parse-format-string string start end))) + (if newline? + (lambda (xp args tail) + (xp.pprint-newline+ 'unconditional xp) + (funcall continuation xp args tail)) + continuation)))) +(define-format #\newline (function xp.format-newline)) + +(define (xp.skip-whitespace string start end) + (if (eqv? start end) + start + (let ((char (string-ref string start))) + (if (and (char-whitespace? char) + (not (eqv? char #\newline))) + (xp.skip-whitespace string (1+ start) end) + start)))) + + + +;;; ~T -> tab + +(define (xp.format-t string start end params colon? atsign?) + (let* ((continuation (xp.parse-format-string string start end)) + (colnum (or (and (not (null? params)) (pop params)) 1)) + (colinc (or (and (not (null? params)) (pop params)) 1)) + (kind (if colon? + (if atsign? 'section-relative 'section) + (if atsign? 'line-relative 'line)))) + (lambda (xp args tail) + (xp.pprint-tab+ kind colnum colinc xp) + (funcall continuation xp args tail)))) +(define-format #\t (function xp.format-t)) + + +;;; ~I -> indent + +(define (xp.format-i string start end params colon? atsign?) + (declare (ignore atsign?)) + (let ((continuation (xp.parse-format-string string start end)) + (kind (if colon? 'current 'block)) + (n (or (and (not (null? params)) (pop params)) 0))) + (lambda (xp args tail) + (pprint-indent kind n) + (funcall continuation xp args tail)))) +(define-format #\i (function xp.format-i)) + + +;;; ~* -> skip or back up over arguments + +(define (xp.format-star string start end params colon? atsign?) + (let ((continuation (xp.parse-format-string string start end)) + (n (or (and (not (null? params)) (pop params)) 1))) + (cond ((and (not colon?) (not atsign?)) + (lambda (xp args tail) + (funcall continuation xp args (list-tail tail n)))) + ((and colon? (not atsign?)) + (lambda (xp args tail) + (funcall continuation xp args (xp.back-up n args tail)))) + ((and (not colon?) atsign?) + (lambda (xp args tail) + (declare (ignore tail)) + (funcall continuation xp args (list-tail args n)))) + (else + (error "~:@* not allowed."))))) +(define-format #\* (function xp.format-star)) + +(define (xp.back-up n head tail) + (if (eq? (list-tail head n) tail) + head + (xp.back-up n (cdr head) tail))) + + +;;; ~? -> indirection +;;; Normally uses two arguments, a string and a list. +;;; With @, only uses a string, takes arguments from the tail. + +(define (xp.format-question string start end params colon? atsign?) + (declare (ignore params colon?)) + (let ((continuation (xp.parse-format-string string start end))) + (if atsign? + (lambda (xp args tail) + (setf tail (apply (function format) xp (car tail) (cdr tail))) + (funcall continuation xp args tail)) + (lambda (xp args tail) + (apply (function format) xp (car tail) (cadr tail)) + (funcall continuation xp args (cddr tail)))))) +(define-format #\? (function xp.format-question)) + + +;;; ~(...~) -> case conversion. + +(define *xp.format-paren-next* '#f) + +(define (xp.format-paren string start end params colon? atsign?) + (declare (ignore params)) + (let* ((handler (dynamic-let ((*xp.format-paren-next* '#t)) + (let ((result (xp.parse-format-string + string start end))) + (if (eq? (dynamic *xp.format-paren-next*) '#t) + (error "~( directive has no matching ~).")) + (setf start (dynamic *xp.format-paren-next*)) + result))) + (continuation (xp.parse-format-string string start end)) + (mode (if colon? + (if atsign? 'up 'cap1) + (if atsign? 'cap0 'down)))) + (lambda (xp args tail) + (xp.push-char-mode xp mode) + (setf tail (funcall handler xp args tail)) + (xp.pop-char-mode xp) + (funcall continuation xp args tail)))) +(define-format #\( (function xp.format-paren)) + +(define (xp.format-paren-end string start end params colon? atsign?) + (declare (ignore string end params colon? atsign?)) + (if (not (dynamic *xp.format-paren-next*)) + (error "~) directive has no matching ~(.")) + (setf (dynamic *xp.format-paren-next*) start) + (function xp.format-finish)) +(define-format #\) (function xp.format-paren-end)) + +;;; ~F -> fixed-width *** unimplemented +;;; ~E -> e-notation *** unimplemented +;;; ~G -> general float *** unimplemented +;;; ~$ -> dollars float *** unimplemented +;;; ~[...~] -> conditional *** unimplemented +;;; ~{...~} -> iteration *** unimplemented +;;; ~<...~> -> justification *** unimplemented +;;; ~; -> clause seperator *** unimplemented +;;; ~^ -> up and out *** unimplemented +;;; ~/.../ -> hook *** unimplemented + +(define (xp.unimplemented-format string start end params colon? atsign?) + (declare (ignore start end params colon? atsign?)) + (error "Unimplemented format directive in ~s." string)) + +(define-format #\f (function xp.unimplemented-format)) +(define-format #\e (function xp.unimplemented-format)) +(define-format #\g (function xp.unimplemented-format)) +(define-format #\$ (function xp.unimplemented-format)) +(define-format #\[ (function xp.unimplemented-format)) +(define-format #\] (function xp.unimplemented-format)) +(define-format #\{ (function xp.unimplemented-format)) +(define-format #\} (function xp.unimplemented-format)) +(define-format #\< (function xp.unimplemented-format)) +(define-format #\> (function xp.unimplemented-format)) +(define-format #\; (function xp.unimplemented-format)) +(define-format #\^ (function xp.unimplemented-format)) +(define-format #\/ (function xp.unimplemented-format)) + diff --git a/support/mumble.txt b/support/mumble.txt new file mode 100644 index 0000000..0ca2f40 --- /dev/null +++ b/support/mumble.txt @@ -0,0 +1,840 @@ +Syntax +------ + +(quote x) + +(function name) + You must use this to reference a global function, as in CL. (There + isn't a local function namespace.) + +(lambda lambda-list . body) + Equivalent to #'(lambda ...) in Common Lisp. + The lambda-list can be dotted, as in Scheme. CL lambda-list keywords + are not supported. + +function call + Order of evaluation is unspecified, as in Scheme. + You have to use FUNCALL if the function is bound with let. + +(funcall function . args) + As in Common Lisp, but might be a macro. (The function is guaranteed + to be a true function, not a symbol.) + +(apply procedure . args) + As in Common Lisp/Scheme. + +(map procedure . lists) + As in Scheme. Equivalent to MAPCAR in CL. + +(for-each procedure . lists) + As in Scheme. Equivalent to MAPC in CL. + +(every procedure . lists) +(some procedure . lists) +(notany procedure . lists) +(notevery procedure . lists) + As in CL, but only work on lists. + +(procedure? object) + As in Scheme, but can return an arbitrary truth value instead of just #t. + Note that we never use symbols or quoted lambda expressions as functions. + +(if test then . maybe-else) +(when test . body) +(unless test . body) + +(cond . tests) + As in Scheme, but the = syntax isn't supported. When no test is true, the + result is undefined. + +(case value . cases) + As in Scheme. + Stylistically, use this only when the case labels are symbols. + +(and . expressions) +(or . expressions) + +(not value) + As in Scheme but can return an arbitrary truth value instead of #t. + +(set! variable value) + As in Scheme; this doesn't return a useful value. Use setf instead. + +(setf place value) + Similar to SETF in Common Lisp. Returns value. + See define-setf below. Places that are macro calls are expanded + if they don't have their own setter. + Here is a list of the built-in setters: + dynamic + car + cdr + list-ref + string-ref + vector-ref + table-entry + +(let bindings . body) +(let* bindings . body) +(letrec bindings . body) + Note that each binding clause must be a list of the form (var init); + you can't just supply var or (var) as in Common Lisp. Also remember + that the order of evaluation for the init-forms is not specified for + let/letrec. + The Scheme named LET construct is not supported. + +(flet bindings . body) +(labels bindings . body) + As in Common Lisp. + +(dynamic-let bindings . body) +(dynamic name) + As in Eulisp. Dynamic-let is equivalent to bind in T, or LET in + Common Lisp with all of the variables declared special. As a matter + of style, use dynamic to reference the value rather than just the name. + +(begin . body) + Like PROGN in Common Lisp. + +(block name . body) +(return-from name result) + The intersection of the Eulisp and Common Lisp definitions. The "name" + may be bound as a lexical variable, but you should only refer to it + inside a return-from. + Don't depend on named functions (etc) establishing implicit blocks, + as they do in CL. + +(do bindings-and-steppers (end-test . results) . body) + As in Scheme. It doesn't necessarily establish an implicit BLOCK + as in CL so you can't RETURN from the loop. + +(dolist (variable init . maybe-result) . body) +(dotimes (variable init . maybe-result) . body) + As in CL, except you can't RETURN from the loop. + +(values . values) +(multiple-value-bind variables values-expression . body) + As in Common Lisp, except that the values-expression must explicitly + return multiple values. + +(let/cc variable . body) + As in EuLisp. This is the same as catch in T. The continuation + has dynamic extent within the body. + You call the continuation with an arbitrary number of arguments, which + are the multiple values to be returned. + +(unwind-protect protected-form . body) + +(declare ...) + Similar to Common Lisp declare. Declarations are allowed only in the + standard places that Common Lisp permits (in particular, at the + beginning of binding forms). For now, only the following declarations + are permitted: + + (ignore . variables) + (ignorable . variables) + (type type-spec . variables) -- see info on type-specs below. + + + + +Definitions +----------- + +(define pattern . value) + As in Scheme. + +(define-integrable pattern . value) + Like DEFINE, but also tells the compiler to try to inline the value. + +(define-syntax (name . lambda-list) . body) + Similar to the equivalent T functionality. The lambda-list does not + support destructuring, as does Common Lisp's DEFMACRO. + The macro definition is made both when the file is loaded and when it + is compiled. + +(define-local-syntax (name . lambda-list) . body) + Again, similar to the T functionality. In Common Lisp, equivalent to + a DEFMACRO wrapped in (eval-when (compile) ...). + +(define-setf getter-name setter-name) + Similar to the short form of DEFSETF in Common Lisp, except that the + calling convention for the setter differs: the value is passed as the + first argument rather than as the last. The setter must return this + value. + +(predefine pattern) + This is a forward definition for a function or variable. It doesn't + actually make a definition; its purpose is to try to get rid of compiler + warnings about calls to functions that haven't been defined yet. It can + be a no-op if the underlying Lisp system doesn't provide any way to do + this. + +(redefine pattern . value) + Like DEFINE, but hints to the compiler not to complain if this + function/variable was previously defined somewhere else. + +(redefine-syntax (name . lambda-list) . body) + Like DEFINE-SYNTAX, but hints to the compiler not to complain if this + macro was previously defined somewhere else. + + +Equivalence +----------- + +(eq? x1 x2) +(eqv? x1 x2) +(equal? x1 x2) + As in Scheme but can return an arbitrary truth value instead of #t. + Note that equal? is not the same as EQUAL in CL because it descends vectors. + eqv? is different from the T equiv? because it doesn't descent strings. + + +Lists +----- + +(pair? x) + As in Scheme but can return an arbitrary truth value instead of #t. + +(cons x y) +(list . values) +(make-list length . maybe-init) + +(cxxxxr x) + +(null? x) +(list? x) + As in Scheme but can return an arbitrary truth value instead of #t. + Note that this is a check for a proper (null-terminated) list, not + like LISTP in CL. + +(length x) +(append list . more-lists) +(nconc list . more-lists) + +(reverse x) +(nreverse x) + +(list-tail list n) + Like NTHCDR in Common Lisp. + +(list-ref list n) + Like NTH in Common Lisp. + +(last list) +(butlast list) + As in Common Lisp. + +(memq object list) +(memv object list) +(member object list) + +(assq object list) +(assv object list) +(assoc object list) + +(push item place) +(pop place) + As in Common Lisp. + +(list-copy list) + + +Symbols +------- + +(symbol? object) +(symbol->string object) +(string->symbol object) +(gensym . maybe-prefix) +(gensym? object) + +(symbol-append . symbols) + + +Characters +---------- + +(char? object) + As in Scheme, but can return an arbitrary truth value instead of just #t. + +(char=? c1 c2) +(char<? c1 c2) +(char>? c1 c2) +(char<=? c1 c2) +(char>=? c1 c2) + As in Scheme, except that they can return an arbitrary truth value + instead of just #t. + +(char-ci=? c1 c2) +(char-ci<? c1 c2) +(char-ci>? c1 c2) +(char-ci<=? c1 c2) +(char-ci>=? c1 c2) + As in Scheme, except that they can return an arbitrary truth value + instead of just #t. + +(char-alphabetic? c) +(char-numeric? c) +(char-whitespace? c) +(char-upper-case? c) +(char-lower-case? c) + +(char->integer c) +(integer->char n) + +(char-upcase c) +(char-downcase c) + +(char-name c) + As in Common Lisp. + +(char->digit c . maybe-radix) + Returns nil or the "weight" of the character as a fixnum in the given + radix (defaults to 10). + + +Strings +------- + +(string? object) + As in Scheme, but can return an arbitrary truth value instead of just #t. + +(make-string length . maybe-init) + +(string char . more-chars) + +(string-length string) +(string-ref string index) + +(string=? s1 s2) +(string<? s1 s2) +(string>? s1 s2) +(string<=? s1 s2) +(string>=? s1 s2) + As in Scheme, but can return an arbitrary truth value instead of just #t. + +(string-ci=? s1 s2) +(string-ci<? s1 s2) +(string-ci>? s1 s2) +(string-ci<=? s1 s2) +(string-ci>=? s1 s2) + As in Scheme, but can return an arbitrary truth value instead of just #t. + +(substring string start end) +(string-append string . more-strings) + +(string->list string) +(list->string list) + +(string-copy string) + +(string-upcase string) +(string-downcase string) + + +Vectors +------- + +(vector? object) + As in Scheme, but can return an arbitrary truth value instead of just #t. + +(make-vector length . maybe-init) +(vector object . more-objects) + +(vector-length vector) +(vector-ref vector index) +(vector->list vector) +(list->vector list) + +(vector-copy vector) + + +Numbers +------- + +(number? object) + As in Scheme, but can return an arbitrary truth value instead of just #t. + +(integer? object) +(rational? object) +(float? object) + These test the representation of a number, not its mathematical + properties. They're equivalent to the CL integerp, rationalp, and floatp + predicates. We ignore complex numbers for now. + +(exact->inexact number) + Convert an exact-rational to a float. + +(= x1 x2) +(< x1 x2) +(> x1 x2) +(<= x1 x2) +(>= x1 x2) + As in Scheme, except they can return an arbitrary truth value. + They're restricted to being binary operators because that's all + that's supported in T. + +(zero? x) +(positive? x) +(negative? x) + As in Scheme, except they can return an arbitrary truth value. + +(min number . more-numbers) +(max number . more-numbers) + +(+ . numbers) +(* . numbers) +(- n1 . more-numbers) +(/ n1 . more-numbers) + As in Scheme. + +(quotient n1 n2) +(remainder n1 n2) +(modulo n1 n2) + quotient rounds towards zero. + remainder has the sign of the second argument, modulo has the sign of + the first argument. + +(floor x) +(ceiling x) +(truncate x) +(round x) + As in Scheme. These return a number of the same type as the argument. + +(floor->exact x) +(ceiling->exact x) +(truncate->exact x) +(round->exact x) + Like the above, but return an exact-integer result. Borrowed from + MIT Scheme. + +(1+ n) +(1- n) +(incf place . maybe-delta) +(decf place . maybe-delta) + As in Common Lisp. + +(number->string number . maybe-radix) +(string->number string . maybe-radix) + As in Scheme. + +(expt base power) + As in Common Lisp. [our only use is when both args are integers] + + +Tables +------ + +(table? object) +(make-table) +(table-entry table key) +(table-for-each proc table) +(copy-table table) + More or less as in T. For now we only bother with tables that use + eq? as the comparison function -- mostly symbols are used as keys. + + +I/O +--- + +(call-with-input-file string proc) +(call-with-output-file string proc) + As in Scheme. The proc is called with one argument, the port. + +(call-with-input-string string proc) +(call-with-output-string proc) + Similar, but for reading/writing to a string stream string. + Call-with-output-string returns the string. + +(input-port? object) +(output-port? object) + As in Scheme, but can return an arbitrary truth value. + +(current-input-port) +(current-output-port) + +(open-input-file filename) +(open-output-file filename) + +(close-input-port port) +(close-output-port port) + +(read . maybe-port) +(read-char . maybe-port) +(peek-char . maybe-port) +(read-line . maybe-port) + +(eof-object? object) + + +Printer +------- + +(internal-write object port) +(internal-output-width port) +(internal-output-position port) +(internal-write-char char port) +(internal-write-string string port start end) +(internal-newline port) +(internal-fresh-line port) +(internal-finish-output port) +(internal-force-output port) +(internal-clear-output port) +(internal-write-to-string object) +(internal-warning string) +(internal-error string) + These are all internal hooks. Don't use them directly if you can + avoid it. + +(write object . maybe-stream) +(print object . maybe-stream) +(prin1 object . maybe-stream) +(princ object . maybe-stream) +(pprint object . maybe-stream) +(prin1-to-string object) +(princ-to-string object) +(write-char char . maybe-stream) +(write-string string . maybe-stream-start-end) +(write-line string . maybe-stream-start-end) +(terpri . maybe-stream) +(fresh-line . maybe-stream) +(finish-output . maybe-stream) +(force-output . maybe-stream) +(clear-output . maybe-stream) + These are the standard Common Lisp print functions. All of them + accept either a port or an XP stream as a stream argument. + +(display object . maybe-stream) + Same as princ; for Scheme compatibility. +(newline object . maybe-stream) + Same as terpri; for Scheme compatibility. + + +*print-escape* +*print-shared* +*print-circle* +*print-pretty* +*print-level* +*print-length* + These are the standard Common Lisp printer control variables. The + functions listed above obey them. + +*print-base* +*print-radix* +*print-case* +*print-readably* + These are more standard Common Lisp printer control variables, but + support for them hasn't been implemented yet. Maybe some day. + +*print-dispatch* + This is the hook for user customization of the printer. Its value is a + function that is passed an object as an argument, and returns another + function that takes a stream and the object as arguments. + +*print-structure* + If true, use standard structure printing syntax (overriding any special + print function for the structure type). + +*print-structure-slots* + If true, recursively print structure slots when using standard structure + printing syntax; otherwise just print the structure type name. + + +(standard-print-dispatch object) + This function is the initial value of *print-dispatch*. + +*print-right-margin* +*print-miser-width* +*print-lines* +*default-right-margin* +*last-abbreviated-printing* + These are the XP pretty-printer control variables. For more information + about the pretty-printer, read the XP document. + +(pprint-newline kind . maybe-stream) + The kind argument can be one of LINEAR, FILL, MISER, or MANDATORY. + +(pprint-logical-block (stream-symbol list . more-options) . body) + This is a macro. The body should contain code for printing a logical + block to the stream stream-symbol. + + The format of the options is (stream-symbol list prefix suffix per-line?). + + The list argument can be used with the pprint-pop macro. + + The prefix is a string that is printed as the initial prefix of the logical + block. If per-line? is true, then the prefix is printed on every line. + The suffix is a string that is printed at the end of the logical block. + + You can use this macro even when not pretty-printing, to get support + for *print-length* and *print-level*. In that case, you should have + the body forms put out only a minimal amount of whitespace. + +(pprint-pop) + Returns the next item from the list specified to an enclosing + pprint-logical-block. Checks for circular list tails and *print-length* + abbreviation. + +(pprint-exit-if-list-exhausted) + Can be used inside pprint-logical-block to see if the list is empty. + Causes the block to be exited if so. + +(pprint-indent relative-to n . maybe-stream) + Specify the indentation level to use for a logical block. + The relative-to argument can be either BLOCK or CURRENT. + +(pprint-tab kind colnum colinc . maybe-stream) + Specify tabbing. The kind argument can be one of LINE, SECTION, + LINE-RELATIVE, or SECTION-RELATIVE. + +(pprint-fill stream list . maybe-colon-atsign) +(pprint-linear stream list . maybe-colon-atsign) +(pprint-tabular stream list . maybe-colon-atsign-tabsize) + Pretty-print list to the stream in the given style. + + +(format stream string-or-fn . args) + The standard Common Lisp format, except that some of the more esoteric + directives are unimplemented. (Specifically, watch out for specifying + field widths or using # or V parameters; most of the numeric formatting + options are unimplemented, as are complicated directives like ~{...~}.) + + The stream parameter can be #f to output to a string, or #t to output + to the (current-output-port). + + The string-or-fn argument can be a function as well as a string containing + embedded directives. The function is applied to the stream and the args. + +(warning string-or-fn . args) +(error string-or-fn . args) + + + +System Interface +---------------- + +(macroexpand-1 form . maybe-env) +(macroexpand form . maybe-env) + As in Common Lisp. Since we don't have lexical macros and don't allow + syntax to be shadowed by local bindings, you can omit the environment + argument. These functions are provided mostly for debugging purposes. + +(eval form . maybe-compile) + As in Common Lisp. If the optional argument is supplied and is true, + try to compile the code in memory, not interpret it. + +(load filename) + +*code-quality* + A number between 0 and 3. 0 = minimal compilation, 1 = for debugging, + 2 = low safety, high speed, fast compilation, 3 = go all out. + +(compile-file source-filename . maybe-binary-filename) + +(with-compilation-unit options . forms) + This is the ANSI CL macro. We don't use any options. + +(filename-place filename) +(filename-name filename) +(filename-type filename) + We use a rather simplistic file system model. Filenames are strings + with place (or directory), name, and type components. These functions + pick apart filename strings. You shouldn't have to mess with string + operations on the components directly. + +(assemble-filename place-filename name-filename type-filename) + Build a new filename by combining the appropriate parts of the argument + filenames. + +source-file-type +binary-file-type + These constants hold appropriate default types for source and + compiled files. By convention, source-file-type is ".scm" but + the binary-file-type depends on the underlying Lisp system. + +(file-exists? filename) + Returns true if the file exists. + +(file-write-date filename) +(current-date) + Dates are represented as integers relative to an arbitrary base. These + functions are mostly useful for recording timestamps. + +(get-run-time) + Return run time as a floating-point number relative to an arbitrary base. + Useful for doing timings. + +(getenv name) + Explicitly expand an environment variable. (Environment variables that + appear as filename prefixes are expanded automagically by the functions + that open files.) + +(cd filename) + Change the current directory. + + +(exit) + Go away. + + +Reader Support +-------------- + +' => quote +` => backquote; also , and ,@ +#t and #f + + +Random Stuff +------------ + +lisp-implementation-name + returns a string identifying the underlying lisp implementation; e.g. + "lucid", "t", etc. + +(identify-system) + return a longer string indentifying the lisp version and machine type. + +left-to-right-evaluation + True if the underlying Lisp always evaluates function arguments + left-to-right; false otherwise. + +(gc-messages onoff) + Turn garbage collection messages on/off, if possible. + +(identity x) + The identity function. + + + +Type specifiers +--------------- + +t +procedure +pair +null +list, (list element-type) +symbol +char +string +vector +number +integer +rational +float +fixnum, int +table, (table key-type value-type) +(enum . values) +(tuple . component-types) +bool +alist, (alist key-type value-type) +(maybe type) +struct +type-descriptor +slot-descriptor + These are the standard type specifiers. + +the + As in Common Lisp. +subtype? + Equivalent to CL subtypep +is-type? + Equivalent to CL typep +typecase + As in Common Lisp, also recognizes "else" clause. + + + +Structures +---------- + +(struct? object) + Returns true if the object is a struct. +(struct-type-descriptor object) + Returns the type descriptor of a struct object. + +name, slots, parent-type, printer + Slots of type-descriptor object. + +(td-name td) +(td-slots td) +(td-parent-type td) +(td-printer td) + Accessors for type-descriptors. + +name, type, default, getter + Slots of slot-descriptor object. + +(sd-name sd) +(sd-type sd) +(sd-default sd) +(sd-getter sd) + Accessors for slot-descriptors. +(sd-getter-function sd) + Returns a function which can be used to access a slot (as opposed to + the symbol that names the function). + +(lookup-type-descriptor type-name) +(lookup-slot-descriptor type-name slot-name) + Name to descriptor mappings. + + +(make type . initializers) + The type must name a struct type; it is not evaluated. + The initializers are of the form (slot-name value-form). + +(struct-slot type slot object) + Generalized slot access. Type and slot are symbols. If both are + quoted, can be used with SETF. + +(with-slots type slot-names object . body) + Binds the specified slots of object to local variables with the + same names. Bindings are read-only. Type is not evaluated. + +(update-slots type object . initializers) + Modifies the slots of object. Syntax of initializers is as for make. + Type is not evaluated. + +(define-struct name + (include parent-type-name) + (type-template subtype-of-type-descriptor) + (prefix prefix-symbol) + (predicate predicate-name) + (slots + (slot-name + (type type) + (default init-form) + (bit #t) + (read-only? #t) + (uninitialized? #t)) + ...)) + + Defines name as a subtype of struct with the given slots. + All fields are optional. + + Include specifies the immediate supertype. All accessors on the supertype + work on the newly defined type. It defaults to struct. + + Type-template specifies the metaclass. It can be used to attach + additional information to the type descriptor. It defaults to + type-descriptor. + + Prefix can be used to specify an alternate prefix for accessors. The + default is name-. + + Predicate can be used to create a predicate function. The default is + not to create one. + + If no default is specified for a slot, it's expected to have an + explicit initializer supplied with MAKE. You'll get a compilation + warning otherwise, unless you specify the uninitialized? option instead. + + Bit is a hint for optimizing internal representation. + + Read-only? says not to create a SETFer for the slot. + + +(define-struct-printer struct-name printer-function) + Specifies a printer function to use when *print-structure* is false. + diff --git a/support/pprint.scm b/support/pprint.scm new file mode 100644 index 0000000..9b28ec8 --- /dev/null +++ b/support/pprint.scm @@ -0,0 +1,1788 @@ +;;; pprint.scm -- xp pretty-printer in Scheme +;;; +;;; author : Sandra Loosemore +;;; date : 29 Oct 1991 +;;; +;;; +;;; This code is adapted from the XP pretty printer originally written +;;; in Common Lisp by Dick Waters. Here is the copyright notice attached +;;; to the original XP source file: +;;; +;;;------------------------------------------------------------------------ +;;; +;;; Copyright 1989,1990 by the Massachusetts Institute of Technology, +;;; Cambridge, Massachusetts. +;;; +;;; Permission to use, copy, modify, and distribute this software and its +;;; documentation for any purpose and without fee is hereby granted, +;;; provided that this copyright and permission notice appear in all +;;; copies and supporting documentation, and that the name of M.I.T. not +;;; be used in advertising or publicity pertaining to distribution of the +;;; software without specific, written prior permission. M.I.T. makes no +;;; representations about the suitability of this software for any +;;; purpose. It is provided "as is" without express or implied warranty. +;;; +;;; M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING +;;; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL +;;; M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR +;;; ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, +;;; WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, +;;; ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS +;;; SOFTWARE. +;;; +;;;------------------------------------------------------------------------ +;;; + + +;;;===================================================================== +;;; Variables +;;;===================================================================== + + +;;; External variables. These may be specially bound by user code. + +(define *print-escape* '#t) +(define *print-circle* '#f) +(define *print-level* '#f) +(define *print-length* '#f) +(define *print-base* 10) +(define *print-radix* '#f) + + +(define *print-shared* '#f) +(define *print-pretty* '#f) +(define *print-right-margin* '#f) +(define *print-miser-width* 40) +(define *print-lines* '#f) +(define *default-right-margin* 70) +(define *last-abbreviated-printing* + (lambda maybe-stream + (declare (ignore maybe-stream)) + '#f)) + +(define *print-dispatch* '#f) ; initialized later +(define *print-structure* '#f) +(define *print-structure-slots* '#t) + + +;;; *** These variables aren't really supported, but they should be. + +(define *print-readably* '#f) +(define *print-case* 'upcase) + + + +;;; Internal variables. These are all specially rebound when we initiate +;;; printing to an XP stream. + +(define *xp.current-level* 0) +(define *xp.current-length* 0) +(define *xp.abbreviation-happened* '#f) +(define *xp.locating-circularities* '#f) +(define *xp.parents* '()) +(define *xp.circularity-hash-table* '#f) +(define *xp.line-limit-abbreviation-exit* + (lambda values + (declare (ignore values)) + (error "No line limit abbreviation exit in this extent."))) + + + +;;;===================================================================== +;;; Dispatching +;;;===================================================================== + +;;; Since Scheme doesn't have type specifiers or named structures, +;;; the dispatch mechanism defined for the Common Lisp XP won't work +;;; very well. A more general alternative might be to maintain a +;;; sorted list of <priority predicate printer> tuples, but having to +;;; try each of these in sequence could get very slow. +;;; +;;; What I've decided to to instead is to have the value of +;;; *print-dispatch* be a user-defined dispatcher +;;; function: given an object, it should return a function to print it, +;;; or #f. In the latter case, the object is printed in some default +;;; way. +;;; +;;; The standard dispatcher function is defined towards the bottom +;;; of this file. If you are writing your own dispatcher, you should +;;; probably call this function as the fall-through case. + +(define (xp.get-printer object) + (funcall (dynamic *print-dispatch*) object)) + + +;;;===================================================================== +;;; Internal data structures +;;;===================================================================== + +(define-integrable xp.block-stack-entry-size 1) +(define-integrable xp.prefix-stack-entry-size 5) +(define-integrable xp.queue-entry-size 7) +(define-integrable xp.buffer-entry-size 1) +(define-integrable xp.prefix-entry-size 1) +(define-integrable xp.suffix-entry-size 1) + +(define-integrable xp.block-stack-min-size (* 35 xp.block-stack-entry-size)) +(define-integrable xp.prefix-stack-min-size (* 30 xp.prefix-stack-entry-size)) +(define-integrable xp.queue-min-size (* 75 xp.queue-entry-size)) +(define-integrable xp.buffer-min-size 256) +(define-integrable xp.prefix-min-size 256) +(define-integrable xp.suffix-min-size 256) + + +;;; The xp stream structure. +;;; Fields without defaults are initialized by xp.initialize-xp, below. + +(define-struct xp + (prefix xp.) + (predicate xp.xp-structure-p) + (slots + (base-stream (type t) (default '#f)) + (linel (type fixnum) (default 0)) + (line-limit (type (maybe fixnum)) (default '#f)) + (line-no (type fixnum) (default 0)) + (char-mode (type (enum #f up down cap0 cap1 capw)) (default '#f)) + (char-mode-counter (type fixnum) (default 0)) + ;; number of logical blocks at qright that are started but not ended. + (depth-in-blocks (type fixnum) (default 0)) + ;; This stack is pushed and popped in accordance with the way blocks + ;; are nested at the moment they are entered into the queue. + (block-stack (type vector) (default (make-vector xp.block-stack-min-size))) + ;; Pointer into block-stack vector. + (block-stack-ptr (type fixnum) (default 0)) + ;; This is a string that builds up the line images that will be printed out. + (buffer (type string) (default (make-string xp.buffer-min-size))) + ;; The output character position of the first character in the buffer; + ;; nonzero only if a partial line has been output. + (charpos (type fixnum) (default 0)) + ;; The index in the buffer where the next character is to be inserted. + (buffer-ptr (type fixnum) (default 0)) + ;; This is used in computing total lengths. It is changed to reflect + ;; all shifting and insertion of prefixes so that total length computes + ;; things as they would be if they were all on one line. + (buffer-offset (type fixnum) (default 0)) + ;; The queue of action descriptors. The value is a vector. + (queue (type vector) (default (make-vector xp.queue-min-size))) + ;; Index of next queue entry to dequeue. + (qleft (type fixnum) (default 0)) + ;; Index of last entry queued; queue is empty when (> qleft qright). + (qright (type fixnum) (default 0)) + ;; This stores the prefix that should be used at the start of the line. + (prefix (type string) (default (make-string xp.buffer-min-size))) + ;; This stack is pushed and popped in accordance with the way blocks + ;; are nested at the moment things are taken off the queue and printed. + (prefix-stack (type vector) (default (make-vector xp.prefix-stack-min-size))) + ;; Index into prefix-stack. + (prefix-stack-ptr (type fixnum) (default 0)) + ;; This stores the suffixes that have to be pritned to close of the + ;; current open blocks. For convenience in popping, the whole suffix + ;; is stored in reverse order. + (suffix (type string) (default (make-string xp.buffer-min-size))) + )) + + +(define (xp.make-xp-structure) + (make xp)) + + +;;; Positions within the buffer are kept in three ways: +;;; * Buffer position (eg BUFFER-PTR) +;;; * Line position (eg (+ BUFFER-PTR CHARPOS)). +;;; Indentations are stored in this form. +;;; * Total position if all on one line (eg (+ BUFFER-PTR BUFFER-OFFSET)) +;;; Positions are stored in this form. + +(define-local-syntax (xp.lp<-bp xp . maybe-ptr) + (let ((ptr (if (not (null? maybe-ptr)) + (car maybe-ptr) + `(xp.buffer-ptr ,xp)))) + `(+ ,ptr (xp.charpos ,xp)))) + +(define-local-syntax (xp.tp<-bp xp) + `(+ (xp.buffer-ptr ,xp) (xp.buffer-offset ,xp))) + +(define-local-syntax (xp.bp<-lp xp ptr) + `(- ,ptr (xp.charpos ,xp))) + +(define-local-syntax (xp.bp<-tp xp ptr) + `(- ,ptr (xp.buffer-offset ,xp))) + +(define-local-syntax (xp.lp<-tp xp ptr) + `(xp.lp<-bp ,xp (xp.bp<-tp ,xp ,ptr))) + + +;;; Define some macros for growing the various stacks in the xp-structure. + +(define-local-syntax (xp.check-block-stack-size xp ptr) + `(setf (xp.block-stack ,xp) + (xp.grow-vector (xp.block-stack ,xp) ,ptr xp.block-stack-entry-size))) + +(define-local-syntax (xp.check-prefix-size xp ptr) + `(setf (xp.prefix ,xp) + (xp.grow-string (xp.prefix ,xp) ,ptr xp.prefix-entry-size))) + +(define-local-syntax (xp.check-prefix-stack-size xp ptr) + `(setf (xp.prefix-stack ,xp) + (xp.grow-vector (xp.prefix-stack ,xp) ,ptr xp.prefix-stack-entry-size))) + +(define-local-syntax (xp.check-queue-size xp ptr) + `(setf (xp.queue ,xp) + (xp.grow-vector (xp.queue ,xp) ,ptr xp.queue-entry-size))) + +(define-local-syntax (xp.check-buffer-size xp ptr) + `(setf (xp.buffer ,xp) + (xp.grow-string (xp.buffer ,xp) ,ptr xp.buffer-entry-size))) + +(define-local-syntax (xp.check-suffix-size xp ptr) + `(setf (xp.suffix ,xp) + (xp.grow-string (xp.suffix ,xp) ,ptr xp.suffix-entry-size))) + +(define (xp.grow-vector old ptr entry-size) + (let ((end (vector-length old))) + (if (> ptr (- end entry-size)) + (let ((new (make-vector (+ ptr 50)))) + (dotimes (i end) + (setf (vector-ref new i) (vector-ref old i))) + new) + old))) + +(define (xp.grow-string old ptr entry-size) + (let ((end (string-length old))) + (if (> ptr (- end entry-size)) + (let ((new (make-string (+ ptr 50)))) + (dotimes (i end) + (setf (string-ref new i) (string-ref old i))) + new) + old))) + + + +;;; Things for manipulating the block stack. + +(define-local-syntax (xp.section-start xp) + `(vector-ref (xp.block-stack ,xp) (xp.block-stack-ptr ,xp))) + +(define (xp.push-block-stack xp) + (incf (xp.block-stack-ptr xp) xp.block-stack-entry-size) + (xp.check-block-stack-size xp (xp.block-stack-ptr xp))) + +(define (xp.pop-block-stack xp) + (decf (xp.block-stack-ptr xp) xp.block-stack-entry-size)) + + +;;; Prefix stack manipulations + +(define-local-syntax (xp.prefix-ptr xp) + `(vector-ref (xp.prefix-stack ,xp) (xp.prefix-stack-ptr ,xp))) +(define-local-syntax (xp.suffix-ptr xp) + `(vector-ref (xp.prefix-stack ,xp) (+ (xp.prefix-stack-ptr ,xp) 1))) +(define-local-syntax (non-blank-prefix-ptr xp) + `(vector-ref (xp.prefix-stack ,xp) (+ (xp.prefix-stack-ptr ,xp) 2))) +(define-local-syntax (initial-prefix-ptr xp) + `(vector-ref (xp.prefix-stack ,xp) (+ (xp.prefix-stack-ptr ,xp) 3))) +(define-local-syntax (xp.section-start-line xp) + `(vector-ref (xp.prefix-stack ,xp) (+ (xp.prefix-stack-ptr ,xp) 4))) + +(define (xp.push-prefix-stack xp) + (let ((old-prefix 0) + (old-suffix 0) + (old-non-blank 0)) + (when (not (negative? (xp.prefix-stack-ptr xp))) + (setf old-prefix (xp.prefix-ptr xp)) + (setf old-suffix (xp.suffix-ptr xp)) + (setf old-non-blank (non-blank-prefix-ptr xp))) + (incf (xp.prefix-stack-ptr xp) xp.prefix-stack-entry-size) + (xp.check-prefix-stack-size xp (xp.prefix-stack-ptr xp)) + (setf (xp.prefix-ptr xp) old-prefix) + (setf (xp.suffix-ptr xp) old-suffix) + (setf (non-blank-prefix-ptr xp) old-non-blank))) + +(define (xp.pop-prefix-stack xp) + (decf (xp.prefix-stack-ptr xp) xp.prefix-stack-entry-size)) + + +;;; The queue entries have several parts: +;;; QTYPE one of :NEWLINE/:IND/:START-BLOCK/:END-BLOCK +;;; QKIND :LINEAR/:MISER/:FILL/:MANDATORY or :UNCONDITIONAL/:FRESH +;;; or :BLOCK/:CURRENT +;;; QPOS total position corresponding to this entry +;;; QDEPTH depth in blocks of this entry. +;;; QEND offset to entry marking end of section this entry starts. +;; (NIL until known.) +;;; Only :start-block and non-literal :newline entries can start sections. +;;; QOFFSET offset to :END-BLOCK for :START-BLOCK (NIL until known). +;;; QARG for :IND indentation delta +;;; for :START-BLOCK suffix in the block if any. +;;; or if per-line-prefix then cons of suffix and +;;; per-line-prefix. +;;; for :END-BLOCK suffix for the block if any. + +(define-local-syntax (xp.qtype xp index) + `(vector-ref (xp.queue ,xp) ,index)) +(define-local-syntax (xp.qkind xp index) + `(vector-ref (xp.queue ,xp) (1+ ,index))) +(define-local-syntax (xp.qpos xp index) + `(vector-ref (xp.queue ,xp) (+ ,index 2))) +(define-local-syntax (xp.qdepth xp index) + `(vector-ref (xp.queue ,xp) (+ ,index 3))) +(define-local-syntax (xp.qend xp index) + `(vector-ref (xp.queue ,xp) (+ ,index 4))) +(define-local-syntax (xp.qoffset xp index) + `(vector-ref (xp.queue ,xp) (+ ,index 5))) +(define-local-syntax (xp.qarg xp index) + `(vector-ref (xp.queue ,xp) (+ ,index 6))) + +;;; we shift the queue over rather than using a circular queue because +;;; that works out to be a lot faster in practice. Note, short printout +;;; does not ever cause a shift, and even in long printout, the queue is +;;; shifted left for free every time it happens to empty out. + +(define (xp.enqueue xp type kind . maybe-arg) + (incf (xp.qright xp) xp.queue-entry-size) + (when (> (xp.qright xp) (- xp.queue-min-size xp.queue-entry-size)) + (vector-replace (xp.queue xp) (xp.queue xp) 0 (xp.qleft xp) (xp.qright xp)) + (setf (xp.qright xp) (- (xp.qright xp) (xp.qleft xp))) + (setf (xp.qleft xp) 0)) + (xp.check-queue-size xp (xp.qright xp)) + (setf (xp.qtype xp (xp.qright xp)) type) + (setf (xp.qkind xp (xp.qright xp)) kind) + (setf (xp.qpos xp (xp.qright xp)) (xp.tp<-bp xp)) + (setf (xp.qdepth xp (xp.qright xp)) (xp.depth-in-blocks xp)) + (setf (xp.qend xp (xp.qright xp)) '#f) + (setf (xp.qoffset xp (xp.qright xp)) '#f) + (setf (xp.qarg xp (xp.qright xp)) (car maybe-arg))) + +(define-local-syntax (xp.qnext index) `(+ ,index xp.queue-entry-size)) + + + +;;; Print routine for xp structures +;;; *** this is broken, it uses unimplemented format options. + +(define *xp.describe-xp-streams-fully* '#f) + +(define (xp.describe-xp xp . maybe-stream) + (let ((s (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (format s "#<XP stream ") + (if (not (xp.base-stream xp)) + (format s "not currently in use") + (begin + (format s "outputting to ~S" (xp.base-stream xp)) + (format s "~&buffer= ~S" + (substring (xp.buffer xp) 0 (max (xp.buffer-ptr xp) 0))) + (if (not (dynamic *xp.describe-xp-streams-fully*)) + (format s " ...") + (begin + (format s "~& pos _123456789_123456789_123456789_123456789") + (format s "~&depth-in-blocks= ~D linel= ~D line-no= ~D line-limit= ~D" + (xp.depth-in-blocks xp) (xp.linel xp) + (xp.line-no xp) (xp.line-limit xp)) + (when (or (xp.char-mode xp) (not (zero? (xp.char-mode-counter xp)))) + (format s "~&char-mode= ~S char-mode-counter= ~D" + (xp.char-mode xp) (xp.char-mode-counter xp))) + (unless (negative? (xp.block-stack-ptr xp)) + (format s "~§ion-start") + (do ((save (xp.block-stack-ptr xp))) + ((negative? (xp.block-stack-ptr xp)) + (setf (xp.block-stack-ptr xp) save)) + (format s " ~D" (xp.section-start xp)) + (xp.pop-block-stack xp))) + (format s "~&linel= ~D charpos= ~D buffer-ptr= ~D buffer-offset= ~D" + (xp.linel xp) (xp.charpos xp) + (xp.buffer-ptr xp) (xp.buffer-offset xp)) + (unless (negative? (xp.prefix-stack-ptr xp)) + (format s "~&prefix= ~S" + (substring (xp.prefix xp) 0 (max (xp.prefix-ptr xp) 0))) + (format s "~&suffix= ~S" + (substring (xp.suffix xp) 0 (max (xp.suffix-ptr xp) 0)))) + (unless (> (xp.qleft xp) (xp.qright xp)) + (format s "~&ptr type kind pos depth end offset arg") + (do ((p (xp.qleft xp) (xp.qnext p))) + ((> p (xp.qright xp))) + (format s "~&~4A~13A~15A~4A~6A~4A~7A~A" + (/ (- p (xp.qleft xp)) xp.queue-entry-size) + (xp.qtype xp p) + (if (memq (xp.qtype xp p) '(newline ind)) + (xp.qkind xp p) + "") + (xp.bp<-tp xp (xp.qpos xp p)) + (xp.qdepth xp p) + (if (not (memq (xp.qtype xp p) + '(newline start-block))) + "" + (and (xp.qend xp p) + (/ (- (+ p (xp.qend xp p)) (xp.qleft xp)) + xp.queue-entry-size))) + (if (not (eq? (xp.qtype xp p) 'start-block)) + "" + (and (xp.qoffset xp p) + (/ (- (+ p (xp.qoffset xp p)) (xp.qleft xp)) + xp.queue-entry-size))) + (if (not (memq (xp.qtype xp p) + '(ind start-block end-block))) + "" + (xp.qarg xp p))))) + (unless (negative? (xp.prefix-stack-ptr xp)) + (format s "~&initial-prefix-ptr prefix-ptr suffix-ptr non-blank start-line") + (do ((save (xp.prefix-stack-ptr xp))) + ((negative? (xp.prefix-stack-ptr xp)) + (setf (xp.prefix-stack-ptr xp) save)) + (format s "~& ~19A~11A~11A~10A~A" + (initial-prefix-ptr xp) + (xp.prefix-ptr xp) + (xp.suffix-ptr xp) + (non-blank-prefix-ptr xp) + (xp.section-start-line xp)) + (xp.pop-prefix-stack xp))))))) + (format s ">"))) + + + +;;; Allocation of XP structures + +;;; This maintains a list of XP structures. We save them +;;; so that we don't have to create new ones all of the time. +;;; We have separate objects so that many can be in use at once +;;; (e.g. for printing to multiple streams). + +(define xp.free-xps '()) + +(define (xp.get-pretty-print-stream stream) + (xp.initialize-xp + (if (not (null? xp.free-xps)) + (pop xp.free-xps) + (xp.make-xp-structure)) + stream)) + + +;;; If you call this, the xp-stream gets efficiently recycled. + +(define (xp.free-pretty-print-stream xp) + (setf (xp.base-stream xp) '#f) + (if (not (memq xp xp.free-xps)) + (push xp xp.free-xps))) + + +;;; This is called to initialize things when you start pretty printing. + +(define (xp.initialize-xp xp stream) + (setf (xp.base-stream xp) stream) + (setf (xp.linel xp) + (max 0 + (cond ((dynamic *print-right-margin*)) + ((internal-output-width stream)) + (else (dynamic *default-right-margin*))))) + (setf (xp.line-limit xp) (dynamic *print-lines*)) + (setf (xp.line-no xp) 1) + (setf (xp.char-mode xp) '#f) + (setf (xp.char-mode-counter xp) 0) + (setf (xp.depth-in-blocks xp) 0) + (setf (xp.block-stack-ptr xp) 0) + (setf (xp.charpos xp) (or (internal-output-position stream) 0)) + (setf (xp.section-start xp) 0) + (setf (xp.buffer-ptr xp) 0) + (setf (xp.buffer-offset xp) (xp.charpos xp)) + (setf (xp.qleft xp) 0) + (setf (xp.qright xp) (- xp.queue-entry-size)) + (setf (xp.prefix-stack-ptr xp) (- xp.prefix-stack-entry-size)) + xp) + + + +;;; The char-mode stuff is a bit tricky. +;;; one can be in one of the following modes: +;;; NIL no changes to characters output. +;;; :UP CHAR-UPCASE used. +;;; :DOWN CHAR-DOWNCASE used. +;;; :CAP0 capitalize next alphanumeric letter then switch to :DOWN. +;;; :CAP1 capitalize next alphanumeric letter then switch to :CAPW +;;; :CAPW downcase letters. When a word break letter found, switch to :CAP1. +;;; It is possible for ~(~) to be nested in a format string, but note that +;;; each mode specifies what should happen to every letter. Therefore, inner +;;; nested modes never have any effect. You can just ignore them. + +(define (xp.push-char-mode xp new-mode) + (if (zero? (xp.char-mode-counter xp)) + (setf (xp.char-mode xp) new-mode)) + (incf (xp.char-mode-counter xp))) + +(define (xp.pop-char-mode xp) + (decf (xp.char-mode-counter xp)) + (if (zero? (xp.char-mode-counter xp)) + (setf (xp.char-mode xp) '#f))) + + +;;; Assumes is only called when char-mode is non-nil + +(define (xp.handle-char-mode xp char) + (case (xp.char-mode xp) + ((CAP0) + (cond ((not (or (char-alphabetic? char) (char-numeric? char))) char) + (else (setf (xp.char-mode xp) 'DOWN) (char-upcase char)))) + ((CAP1) + (cond ((not (or (char-alphabetic? char) (char-numeric? char))) char) + (else (setf (xp.char-mode xp) 'CAPW) (char-upcase char)))) + ((CAPW) + (cond ((or (char-alphabetic? char) (char-numeric? char)) + (char-downcase char)) + (else (setf (xp.char-mode xp) 'CAP1) char))) + ((UP) + (char-upcase char)) + (else + (char-downcase char)))) ;DOWN + + +;;; All characters output are passed through the handler above. However, +;;; it must be noted that on-each-line prefixes are only processed in the +;;; context of the first place they appear. They stay the same later no +;;; matter what. Also non-literal newlines do not count as word breaks. + +;;; This handles the basic outputting of characters. note + suffix means that +;;; the stream is known to be an XP stream, all inputs are mandatory, and no +;;; error checking has to be done. Suffix ++ additionally means that the +;;; output is guaranteed not to contain a newline char. + +(define (xp.write-char+ char xp) + (if (eqv? char #\newline) + (xp.pprint-newline+ 'unconditional xp) + (xp.write-char++ char xp))) + +(define (xp.write-string+ mystring xp start end) + (let ((next-newline (string-position #\newline mystring start end))) + (if next-newline + (begin + (xp.write-string++ mystring xp start next-newline) + (xp.pprint-newline+ 'unconditional xp) + (xp.write-string+ mystring xp (1+ next-newline) end)) + (xp.write-string++ mystring xp start end)))) + + +;;; note this checks (> BUFFER-PTR LINEL) instead of (> (xp.lp<-bp) LINEL) +;;; this is important so that when things are longer than a line they +;;; end up getting printed in chunks of size LINEL. + +(define (xp.write-char++ char xp) + (when (> (xp.buffer-ptr xp) (xp.linel xp)) + (xp.force-some-output xp)) + (let ((new-buffer-end (1+ (xp.buffer-ptr xp)))) + (xp.check-buffer-size xp new-buffer-end) + (if (xp.char-mode xp) (setf char (xp.handle-char-mode xp char))) + (setf (string-ref (xp.buffer xp) (xp.buffer-ptr xp)) char) + (setf (xp.buffer-ptr xp) new-buffer-end))) + +(define (xp.force-some-output xp) + (xp.attempt-to-output xp '#f '#f) + (when (> (xp.buffer-ptr xp) (xp.linel xp)) ;only if printing off end of line + (xp.attempt-to-output xp '#t '#t))) + +(define (xp.write-string++ mystring xp start end) + (when (> (xp.buffer-ptr xp) (xp.linel xp)) + (xp.force-some-output xp)) + (xp.write-string+++ mystring xp start end)) + + +;;; never forces output; therefore safe to call from within xp.output-line. + +(define (xp.write-string+++ mystring xp start end) + (let ((new-buffer-end (+ (xp.buffer-ptr xp) (- end start)))) + (xp.check-buffer-size xp new-buffer-end) + (do ((buffer (xp.buffer xp)) + (i (xp.buffer-ptr xp) (1+ i)) + (j start (1+ j))) + ((= j end)) + (let ((char (string-ref mystring j))) + (if (xp.char-mode xp) (setf char (xp.handle-char-mode xp char))) + (setf (string-ref buffer i) char))) + (setf (xp.buffer-ptr xp) new-buffer-end))) + + +(define (xp.pprint-tab+ kind colnum colinc xp) + (let ((indented? '#f) + (relative? '#f)) + (case kind + ((section) (setf indented? '#t)) + ((line-relative) (setf relative? '#t)) + ((section-relative) (setf indented? '#t) (setf relative? '#t))) + (let* ((current + (if (not indented?) + (xp.lp<-bp xp) + (- (xp.tp<-bp xp) (xp.section-start xp)))) + (new + (if (zero? colinc) + (if relative? (+ current colnum) (max colnum current)) + (cond (relative? + (* colinc + (quotient (+ current colnum colinc -1) colinc))) + ((> colnum current) colnum) + (else + (+ colnum + (* colinc + (quotient (+ current (- colnum) colinc) + colinc))))))) + (end (- new current))) + (when (positive? end) + (if (xp.char-mode xp) (xp.handle-char-mode xp #\space)) + (let ((end (+ (xp.buffer-ptr xp) end))) + (xp.check-buffer-size xp end) + (string-fill (xp.buffer xp) #\space (xp.buffer-ptr xp) end) + (setf (xp.buffer-ptr xp) end)))))) + + +;;; note following is smallest number >= x that is a multiple of colinc +;;; (* colinc (quotient (+ x (1- colinc)) colinc)) + + +(define (xp.pprint-newline+ kind xp) + (xp.enqueue xp 'newline kind) + (do ((ptr (xp.qleft xp) (xp.qnext ptr))) ;find sections we are ending + ((not (< ptr (xp.qright xp)))) ;all but last + (when (and (not (xp.qend xp ptr)) + (not (> (xp.depth-in-blocks xp) (xp.qdepth xp ptr))) + (memq (xp.qtype xp ptr) '(newline start-block))) + (setf (xp.qend xp ptr) (- (xp.qright xp) ptr)))) + (setf (xp.section-start xp) (xp.tp<-bp xp)) + (when (and (memq kind '(fresh unconditional)) (xp.char-mode xp)) + (xp.handle-char-mode xp #\newline)) + (when (memq kind '(fresh unconditional mandatory)) + (xp.attempt-to-output xp '#t '#f))) + + +(define (xp.start-block xp prefix-string on-each-line? suffix-string) + (xp.write-prefix-suffix prefix-string xp) + (if (and (xp.char-mode xp) on-each-line?) + (setf prefix-string + (substring (xp.buffer xp) + (- (xp.buffer-ptr xp) (string-length prefix-string)) + (xp.buffer-ptr xp)))) + (xp.push-block-stack xp) + (xp.enqueue xp 'start-block '#f + (if on-each-line? (cons suffix-string prefix-string) suffix-string)) + (incf (xp.depth-in-blocks xp)) ;must be after enqueue + (setf (xp.section-start xp) (xp.tp<-bp xp))) + + +(define (xp.end-block xp suffix) + (unless (and (dynamic *xp.abbreviation-happened*) + (eqv? (dynamic *xp.abbreviation-happened*) + (dynamic *print-lines*))) + (xp.write-prefix-suffix suffix xp) + (decf (xp.depth-in-blocks xp)) + (xp.enqueue xp 'end-block '#f suffix) + (block foundit + (do ((ptr (xp.qleft xp) (xp.qnext ptr))) ;look for start of block we are ending + ((not (< ptr (xp.qright xp)))) ;all but last + (when (and (= (xp.depth-in-blocks xp) (xp.qdepth xp ptr)) + (eq? (xp.qtype xp ptr) 'start-block) + (not (xp.qoffset xp ptr))) + (setf (xp.qoffset xp ptr) (- (xp.qright xp) ptr)) + (return-from foundit '#f))) ;can only be 1 + ) + (xp.pop-block-stack xp))) + +(define (xp.write-prefix-suffix mystring xp) + (when mystring + (xp.write-string++ mystring xp 0 (string-length mystring)))) + +(define (xp.pprint-indent+ kind n xp) + (xp.enqueue xp 'ind kind n)) + + +;;; attempt-to-output scans the queue looking for things it can do. +;;; it keeps outputting things until the queue is empty, or it finds +;;; a place where it cannot make a decision yet. +;;; If flush-out? is T and force-newlines? is NIL then the buffer, +;;; prefix-stack, and queue will be in an inconsistent state after the call. +;;; You better not call it this way except as the last act of outputting. + + +(define-local-syntax (xp.maybe-too-large xp Qentry) + `(let ((limit (xp.linel ,xp))) + (when (eqv? (xp.line-limit ,xp) (xp.line-no ,xp)) ;prevents suffix overflow + (decf limit 2) ;3 for " .." minus 1 for space (heuristic) + (when (not (negative? (xp.prefix-stack-ptr ,xp))) + (decf limit (xp.suffix-ptr ,xp)))) + (cond ((xp.qend ,xp ,Qentry) + (> (xp.lp<-tp ,xp (xp.qpos ,xp (+ ,Qentry (xp.qend ,xp ,Qentry)))) limit)) + ((or force-newlines? (> (xp.lp<-bp ,xp) limit)) + '#t) + (else ;wait until later to decide. + (return-from attempt-to-output '#f))))) + +(define-local-syntax (xp.misering? xp) + `(and (dynamic *print-miser-width*) + (<= (- (xp.linel ,xp) (initial-prefix-ptr ,xp)) + (dynamic *print-miser-width*)))) + +(define (xp.attempt-to-output xp force-newlines? flush-out?) + (block attempt-to-output + (do () + ((> (xp.qleft xp) (xp.qright xp)) + (setf (xp.qleft xp) 0) + (setf (xp.qright xp) (- xp.queue-entry-size))) ;saves shifting + (case (xp.qtype xp (xp.qleft xp)) + ((ind) + (unless (xp.misering? xp) + (xp.set-indentation-prefix + xp + (case (xp.qkind xp (xp.qleft xp)) + ((block) + (+ (initial-prefix-ptr xp) (xp.qarg xp (xp.qleft xp)))) + (else ; current + (+ (xp.lp<-tp xp (xp.qpos xp (xp.qleft xp))) + (xp.qarg xp (xp.qleft xp))))))) + (setf (xp.qleft xp) (xp.qnext (xp.qleft xp)))) + ((start-block) + (cond ((xp.maybe-too-large xp (xp.qleft xp)) + (xp.push-prefix-stack xp) + (setf (initial-prefix-ptr xp) (xp.prefix-ptr xp)) + (xp.set-indentation-prefix + xp (xp.lp<-tp xp (xp.qpos xp (xp.qleft xp)))) + (let ((arg (xp.qarg xp (xp.qleft xp)))) + (when (pair? arg) (xp.set-prefix xp (cdr arg))) + (setf (initial-prefix-ptr xp) (xp.prefix-ptr xp)) + (cond ((not (list? arg)) (xp.set-suffix xp arg)) + ((car arg) (xp.set-suffix xp (car arg))))) + (setf (xp.section-start-line xp) (xp.line-no xp))) + (else (incf (xp.qleft xp) (xp.qoffset xp (xp.qleft xp))))) + (setf (xp.qleft xp) (xp.qnext (xp.qleft xp)))) + ((end-block) + (xp.pop-prefix-stack xp) + (setf (xp.qleft xp) (xp.qnext (xp.qleft xp)))) + (else ; newline + (when (case (xp.qkind xp (xp.qleft xp)) + ((fresh) (not (zero? (xp.lp<-bp xp)))) + ((miser) (xp.misering? xp)) + ((fill) (or (xp.misering? xp) + (> (xp.line-no xp) (xp.section-start-line xp)) + (xp.maybe-too-large xp (xp.qleft xp)))) + (else '#t)) ;(linear unconditional mandatory) + (xp.output-line xp (xp.qleft xp)) + (xp.setup-for-next-line xp (xp.qleft xp))) + (setf (xp.qleft xp) (xp.qnext (xp.qleft xp))))))) + (when flush-out? (xp.flush xp))) + + +;;; this can only be called last! + +(define (xp.flush xp) + (unless (dynamic *xp.locating-circularities*) + (internal-write-string (xp.buffer xp) (xp.base-stream xp) 0 (xp.buffer-ptr xp))) + (incf (xp.buffer-offset xp) (xp.buffer-ptr xp)) + (incf (xp.charpos xp) (xp.buffer-ptr xp)) + (setf (xp.buffer-ptr xp) 0)) + + +;;; This prints out a line of stuff. + +(define (xp.output-line xp Qentry) + (let* ((out-point (xp.bp<-tp xp (xp.qpos xp Qentry))) + (last-non-blank (string-position-not-from-end + #\space (xp.buffer xp) 0 out-point)) + (end (cond ((memq (xp.qkind xp Qentry) '(fresh unconditional)) + out-point) + (last-non-blank (1+ last-non-blank)) + (else 0))) + (line-limit-exit (and (xp.line-limit xp) + (not (> (xp.line-limit xp) (xp.line-no xp)))))) + (when line-limit-exit + (setf (xp.buffer-ptr xp) end) ;truncate pending output. + (xp.write-string+++ " .." xp 0 3) + (string-nreverse (xp.suffix xp) 0 (xp.suffix-ptr xp)) + (xp.write-string+++ (xp.suffix xp) xp 0 (xp.suffix-ptr xp)) + (setf (xp.qleft xp) (xp.qnext (xp.qright xp))) + (setf (dynamic *xp.abbreviation-happened*) (dynamic *print-lines*)) + (funcall (dynamic *xp.line-limit-abbreviation-exit*) '#t)) + (incf (xp.line-no xp)) + (unless (dynamic *xp.locating-circularities*) + (internal-write-string (xp.buffer xp) (xp.base-stream xp) 0 end) + (newline (xp.base-stream xp))))) + +(define (xp.setup-for-next-line xp Qentry) + (let* ((out-point (xp.bp<-tp xp (xp.qpos xp Qentry))) + (prefix-end + (cond ((memq (xp.qkind xp Qentry) '(unconditional fresh)) + (non-blank-prefix-ptr xp)) + (else (xp.prefix-ptr xp)))) + (change (- prefix-end out-point))) + (setf (xp.charpos xp) 0) + (when (positive? change) ;almost never happens + (xp.check-buffer-size xp (+ (xp.buffer-ptr xp) change))) + (string-replace (xp.buffer xp) (xp.buffer xp) + prefix-end out-point (xp.buffer-ptr xp)) + (string-replace (xp.buffer xp) (xp.prefix xp) 0 0 prefix-end) + (incf (xp.buffer-ptr xp) change) + (decf (xp.buffer-offset xp) change) + (when (not (memq (xp.qkind xp Qentry) '(unconditional fresh))) + (setf (xp.section-start-line xp) (xp.line-no xp))))) + +(define (xp.set-indentation-prefix xp new-position) + (let ((new-ind (max (non-blank-prefix-ptr xp) new-position))) + (setf (xp.prefix-ptr xp) (initial-prefix-ptr xp)) + (xp.check-prefix-size xp new-ind) + (when (> new-ind (xp.prefix-ptr xp)) + (string-fill (xp.prefix xp) #\space (xp.prefix-ptr xp) new-ind)) + (setf (xp.prefix-ptr xp) new-ind))) + +(define (xp.set-prefix xp prefix-string) + (let ((end (string-length prefix-string))) + (string-replace (xp.prefix xp) prefix-string + (- (xp.prefix-ptr xp) end) 0 end)) + (setf (non-blank-prefix-ptr xp) (xp.prefix-ptr xp))) + +(define (xp.set-suffix xp suffix-string) + (let* ((end (string-length suffix-string)) + (new-end (+ (xp.suffix-ptr xp) end))) + (xp.check-suffix-size xp new-end) + (do ((i (1- new-end) (1- i)) + (j 0 (1+ j))) + ((= j end)) + (setf (string-ref (xp.suffix xp) i) (string-ref suffix-string j))) + (setf (xp.suffix-ptr xp) new-end))) + + +;;;===================================================================== +;;; Basic interface functions +;;;===================================================================== + +;;; The internal functions in this file +;;; use the '+' forms of these functions directly (which is faster) because, +;;; they do not need error checking of fancy stream coercion. The '++' forms +;;; additionally assume the thing being output does not contain a newline. + +(define (write object . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (cond ((xp.xp-structure-p stream) + (xp.write+ object stream)) + ((xp.get-printer object) + (xp.initiate-xp-printing + (lambda (s o) (xp.write+ o s)) + stream + object)) + (else + (internal-write object stream))))) + +(define (xp.maybe-initiate-xp-printing fn stream . args) + (if (xp.xp-structure-p stream) + (apply fn stream args) + (apply (function xp.initiate-xp-printing) fn stream args))) + +(define (xp.initiate-xp-printing fn stream . args) + (dynamic-let ((*xp.abbreviation-happened* + '#f) + (*xp.locating-circularities* + (if (dynamic *print-circle*) + 0 + '#f)) + (*xp.circularity-hash-table* + (if (dynamic *print-circle*) + (make-table) + '#f)) + (*xp.parents* + (if (not (dynamic *print-shared*)) + (list '#f) + '())) ;*** is this right? + (*xp.current-level* + 0) + (*xp.current-length* + 0)) + (let ((result (xp.xp-print fn stream args))) + (when (dynamic *xp.abbreviation-happened*) + (setf args (list-copy args)) + (setf (dynamic *last-abbreviated-printing*) + (lambda maybe-stream + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + stream))) + (apply (function xp.maybe-initiate-xp-printing) + fn stream args))))) + result))) + +(define (xp.xp-print fn stream args) + (let ((result (xp.do-xp-printing fn stream args))) + (when (dynamic *xp.locating-circularities*) + (setf (dynamic *xp.locating-circularities*) '#f) + (setf (dynamic *xp.abbreviation-happened*) '#f) + (setf (dynamic *xp.parents*) '()) + (setf result (xp.do-xp-printing fn stream args))) + result)) + +(define (xp.do-xp-printing fn stream args) + (let ((xp (xp.get-pretty-print-stream stream)) + (result '#f)) + (dynamic-let ((*xp.current-level* 0)) + (let/cc catch + (dynamic-let ((*xp.line-limit-abbreviation-exit* catch)) + (xp.start-block xp '#f '#f '#f) + (setf result (apply fn xp args)) + (xp.end-block xp '#f))) + (when (and (dynamic *xp.locating-circularities*) + (zero? (dynamic *xp.locating-circularities*)) ;No circularities. + (= (xp.line-no xp) 1) ;Didn't suppress line. + (zero? (xp.buffer-offset xp))) ;Didn't suppress partial line. + (setf (dynamic *xp.locating-circularities*) '#f)) ;print what you have got. + (when (let/cc catch + (dynamic-let ((*xp.line-limit-abbreviation-exit* catch)) + (xp.attempt-to-output xp '#f '#t) + '#f)) + (xp.attempt-to-output xp '#t '#t)) + (xp.free-pretty-print-stream xp) + result))) + + +(define (xp.write+ object xp) + (dynamic-let ((*xp.parents* (dynamic *xp.parents*))) + (unless (and (dynamic *xp.circularity-hash-table*) + (eq? (xp.circularity-process xp object '#f) 'subsequent)) + (when (and (dynamic *xp.circularity-hash-table*) (pair? object)) + ;; Must do this to avoid additional circularity detection by + ;; pprint-logical-block; otherwise you get stuff like #1=#1#. + (setf object (cons (car object) (cdr object)))) + (funcall (or (xp.get-printer object) (function xp.print-default)) + object + xp)) + object)) + + + +(define (xp.print-default object xp) + (let ((stuff (internal-write-to-string object))) + (xp.write-string+ stuff xp 0 (string-length stuff)))) + + +;;; It is vital that this function be called EXACTLY once for each occurrence +;;; of each thing in something being printed. +;;; Returns nil if printing should just continue on. +;;; Either it is not a duplicate, or we are in the first pass and do not +;;; know. +;;; returns :FIRST if object is first occurrence of a DUPLICATE. +;;; (This can only be returned on a second pass.) +;;; After an initial code (printed by this routine on the second pass) +;;; printing should continue on for the object. +;;; returns :SUBSEQUENT if second or later occurrence. +;;; Printing is all taken care of by this routine. + +;;; Note many (maybe most) lisp implementations have characters and small +;;; numbers represented in a single word so that the are always eq when +;;; they are equal and the reader takes care of properly sharing them +;;; (just as it does with symbols). Therefore, we do not want circularity +;;; processing applied to them. However, some kinds of numbers +;;; (e.g., bignums) undoubtedly are complex structures that the reader +;;; does not share. However, they cannot have circular pointers in them +;;; and it is therefore probably a waste to do circularity checking on them. +;;; In any case, it is not clear that it easy to tell exactly what kinds of +;;; numbers a given implementation is going to have the reader +;;; automatically share. + +(define (xp.circularity-process xp object interior-cdr?) + (unless (or (number? object) + (char? object) + (and (symbol? object) (not (gensym? object)))) + (let ((id (table-entry (dynamic *xp.circularity-hash-table*) object))) + (if (dynamic *xp.locating-circularities*) + ;; This is the first pass. + (cond ((not id) ;never seen before + (when (not (null? (dynamic *xp.parents*))) + (push object (dynamic *xp.parents*))) + (setf (table-entry (dynamic *xp.circularity-hash-table*) object) + 0) + '#f) + ((zero? id) ;possible second occurrence + (cond ((or (null? (dynamic *xp.parents*)) + (memq object (dynamic *xp.parents*))) + (setf (table-entry + (dynamic *xp.circularity-hash-table*) object) + (incf (dynamic *xp.locating-circularities*))) + 'subsequent) + (else '#f))) + (else 'subsequent));third or later occurrence + ;; This is the second pass. + (cond ((or (not id) ;never seen before (note ~@* etc. conses) + (zero? id));no duplicates + '#f) + ((positive? id) ; first occurrence + (cond (interior-cdr? + (decf (dynamic *xp.current-level*)) + (xp.write-string++ ". #" xp 0 3)) + (else (xp.write-char++ #\# xp))) + (xp.print-integer id xp) + (xp.write-char++ #\= xp) + (setf (table-entry (dynamic *xp.circularity-hash-table*) object) + (- id)) + 'first) + (else + (if interior-cdr? + (xp.write-string++ ". #" xp 0 3) + (xp.write-char++ #\# xp)) + (xp.print-integer(- id) xp) + (xp.write-char++ #\# xp) + 'subsequent)))))) + + +;;; Here are all the standard Common Lisp printing functions. + +(define (print object . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (dynamic-let ((*print-escape* '#t)) + (terpri stream) + (write object stream) + (write-char #\space stream) + object))) + +(define (prin1 object . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (dynamic-let ((*print-escape* '#t)) + (write object stream) + object))) + +(define (princ object . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (dynamic-let ((*print-escape* '#f)) + (write object stream) + object))) + +(define (display object . maybe-stream) + (apply (function princ) object maybe-stream)) + + +(define (pprint object . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (dynamic-let ((*print-escape* '#t) + (*print-pretty* '#t)) + (terpri stream) + (write object stream) + (values)))) + +(define (prin1-to-string object) + (call-with-output-string + (lambda (stream) + (dynamic-let ((*print-escape* '#t)) + (write object stream))))) + +(define (princ-to-string object) + (call-with-output-string + (lambda (stream) + (dynamic-let ((*print-escape* '#f)) + (write object stream))))) + + + +(define (write-char char . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (if (xp.xp-structure-p stream) + (xp.write-char+ char stream) + (internal-write-char char stream)) + char)) + +(define (write-string mystring . maybe-stream-start-end) + (let* ((stream (if (not (null? maybe-stream-start-end)) + (car maybe-stream-start-end) + (current-output-port))) + (start (if (not (null? (cdr maybe-stream-start-end))) + (cadr maybe-stream-start-end) + 0)) + (end (if (not (null? (cddr maybe-stream-start-end))) + (caddr maybe-stream-start-end) + (string-length mystring)))) + (if (xp.xp-structure-p stream) + (xp.write-string+ mystring stream start end) + (internal-write-string mystring stream start end)) + mystring)) + +(define (write-line mystring . maybe-stream-start-end) + (let* ((stream (if (not (null? maybe-stream-start-end)) + (car maybe-stream-start-end) + (current-output-port))) + (start (if (not (null? (cdr maybe-stream-start-end))) + (cadr maybe-stream-start-end) + 0)) + (end (if (not (null? (cddr maybe-stream-start-end))) + (caddr maybe-stream-start-end) + (string-length mystring)))) + (if (xp.xp-structure-p stream) + (begin + (xp.write-string+ mystring stream start end) + (xp.pprint-newline+ 'unconditional stream)) + (begin + (internal-write-string mystring stream start end) + (internal-newline stream))) + mystring)) + +(define (terpri . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (if (xp.xp-structure-p stream) + (xp.pprint-newline+ 'unconditional stream) + (internal-newline stream)) + '#f)) + +(define (newline . maybe-stream) + (apply (function terpri) maybe-stream)) + + +;;; This has to violate the XP data abstraction and fool with internal +;;; stuff, in order to find out the right info to return as the result. + +(define (fresh-line . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (cond ((xp.xp-structure-p stream) + (xp.attempt-to-output stream '#t '#t) ;ok because we want newline + (when (not (zero? (xp.lp<-bp stream))) + (xp.pprint-newline+ 'fresh stream) + '#t)) + (else + (internal-fresh-line stream))))) + + +;;; Each of these causes the stream to be pessimistic and insert +;;; newlines wherever it might have to, when forcing the partial output +;;; out. This is so that things will be in a consistent state if +;;; output continues to the stream later. + +(define (finish-output . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (if (xp.xp-structure-p stream) + (xp.attempt-to-output stream '#t '#t) + (internal-finish-output stream)) + '#f)) + +(define (force-output . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (if (xp.xp-structure-p stream) + (xp.attempt-to-output stream '#t '#t) + (internal-force-output stream)) + '#f)) + +(define (clear-output . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (if (xp.xp-structure-p stream) + (dynamic-let ((*xp.locating-circularities* 0)) ;hack to prevent visible output + (xp.attempt-to-output stream '#t '#t) + (internal-clear-output stream))) + '#f)) + + + + +;;;===================================================================== +;;; Functional interface to dynamic formatting +;;;===================================================================== + +;;; The internal functions in this file, and the (formatter "...") expansions +;;; use the '+' forms of these functions directly (which is faster) because, +;;; they do not need error checking or fancy stream coercion. The '++' forms +;;; additionally assume the thing being output does not contain a newline. + +(define-syntax (pprint-logical-block stream-symbol-stuff . body) + (let* ((stream-symbol (car stream-symbol-stuff)) + (mylist (cadr stream-symbol-stuff)) + (rest (cddr stream-symbol-stuff)) + (prefix (if (not (null? rest)) (pop rest) "")) + (suffix (if (not (null? rest)) (pop rest) "")) + (per-line? (if (not (null? rest)) (pop rest) '#f))) + `(xp.maybe-initiate-xp-printing + (lambda (,stream-symbol) + (let ((+l ,mylist) + (+p ,prefix) + (+s ,suffix) + (+x ,stream-symbol)) + (xp.pprint-logical-block+ (+x +l +p +s ,per-line? '#t '#f) + ,@body + '#f))) + ,stream-symbol))) + + +;;; Assumes var and args must be variables. Other arguments must be literals +;;; or variables. + +(define-syntax (xp.pprint-logical-block+ stuff . body) + (let* ((var (pop stuff)) + (args (pop stuff)) + (prefix (pop stuff)) + (suffix (pop stuff)) + (per-line? (pop stuff))) + `(unless (xp.check-abbreviation ,var ,args) + (dynamic-let ((*xp.current-level* (1+ (dynamic *xp.current-level*))) + (*xp.current-length* -1) + (*xp.parents* (dynamic *xp.parents*))) + (block logical-block + (if (dynamic *print-pretty*) + (xp.start-block ,var ,prefix ,per-line? ,suffix) + (xp.write-prefix-suffix ,prefix ,var)) + (unwind-protect + (begin ,@body) + (if (dynamic *print-pretty*) + (xp.end-block ,var ,suffix) + (xp.write-prefix-suffix ,suffix ,var)))))) + )) + +(define (xp.check-abbreviation xp object) + (cond ((and (dynamic *print-level*) + (>= (dynamic *xp.current-level*) + (dynamic *print-level*))) + (xp.write-char++ #\# XP) + (setf (dynamic *xp.abbreviation-happened*) '#t) + '#t) + ((and (dynamic *xp.circularity-hash-table*) + (eq? (xp.circularity-process xp object '#f) 'subsequent)) + '#t) + (else '#f))) + + +(define-syntax (pprint-pop) + `(xp.pprint-pop+ +l +x)) + +(define-syntax (xp.pprint-pop+ args xp) + `(if (xp.pprint-pop-check+ ,args ,xp) + (return-from logical-block '#f) + (if (null? ,args) '() (pop ,args)))) + +(define (xp.pprint-pop-check+ args xp) + (incf (dynamic *xp.current-length*)) + (cond ((not (or (pair? args) (null? args))) + ;; must be first to supersede length abbreviation + (xp.write-string++ ". " xp 0 2) + (xp.write+ args xp) + '#t) + ((and (dynamic *print-length*) + (not (< *xp.current-length* (dynamic *print-length*)))) + ;; must supersede circularity check + (xp.write-string++ "..." xp 0 3) + (setf (dynamic *xp.abbreviation-happened*) '#t) + '#t) + ((and (dynamic *xp.circularity-hash-table*) + (not (zero? *xp.current-length*))) + (case (xp.circularity-process xp args '#t) + ((first) + (xp.write+ (cons (car args) (cdr args)) xp) '#t) + ((subsequent) + '#t) + (else + '#f))) + (else + '#f))) + +(define-syntax (pprint-exit-if-list-exhausted) + `(xp.pprint-exit-if-list-exhausted+ +l)) + +(define-syntax (xp.pprint-exit-if-list-exhausted+ mylist) + `(if (null? ,mylist) (return-from logical-block '#f))) + + +(define (pprint-newline kind . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (when (not (memq kind '(linear miser fill mandatory))) + (error "Invalid KIND argument ~A to PPRINT-NEWLINE" kind)) + (when (and (xp.xp-structure-p stream) (dynamic *print-pretty*)) + (xp.pprint-newline+ kind stream)) + '#f)) + +(define (pprint-indent relative-to n . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (when (not (memq relative-to '(block current))) + (error "Invalid KIND argument ~A to PPRINT-INDENT" relative-to)) + (when (and (xp.xp-structure-p stream) (dynamic *print-pretty*)) + (xp.pprint-indent+ relative-to n stream)) + '#f)) + +(define (pprint-tab kind colnum colinc . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (when (not (memq kind '(line section line-relative section-relative))) + (error "Invalid KIND argument ~A to PPRINT-TAB" kind)) + (when (and (xp.xp-structure-p stream) (dynamic *print-pretty*)) + (xp.pprint-tab+ kind colnum colinc stream)) + '#f)) + + + + +;;;===================================================================== +;;; Standard print dispatch function +;;;===================================================================== + + +(define (xp.print-null object xp) + (declare (ignore object)) + (xp.write-string+ "()" xp 0 2)) + +(define (xp.print-true object xp) + (declare (ignore object)) + (xp.write-string+ "#t" xp 0 2)) + +(define (xp.print-false object xp) + (declare (ignore object)) + (xp.write-string+ "#f" xp 0 2)) + +(define (xp.print-symbol object xp) + (if (dynamic *print-escape*) + (xp.print-default object xp) + (let ((mystring (symbol->string object))) + (xp.write-string+ mystring xp 0 (string-length mystring))))) + +(define (xp.print-number object xp) + (if (and (integer? object) + (eqv? (dynamic *print-base*) 10) + (not (dynamic *print-radix*))) + (begin + (when (negative? object) + (xp.write-char++ #\- xp) + (setf object (- object))) + (xp.print-integer object xp)) + (xp.print-default object xp))) + +(define (xp.print-integer n xp) + (let ((quot (quotient n 10)) + (rem (remainder n 10))) + (unless (zero? quot) + (xp.print-integer quot xp)) + (xp.write-char++ (string-ref "0123456789" rem) xp))) + +(define (xp.print-string object xp) + (if (dynamic *print-escape*) + (begin + (xp.write-char++ #\" xp) + (do ((i 0 (1+ i)) + (n (string-length object))) + ((= i n)) + (let ((c (string-ref object i))) + (if (or (char=? c #\") (char=? c #\\)) + (xp.write-char++ #\\ xp)) + (xp.write-char++ c xp))) + (xp.write-char++ #\" xp)) + (xp.write-string+ object xp 0 (string-length object)))) + +(define (xp.print-character object xp) + (if (dynamic *print-escape*) + (let ((name (char-name object))) + (xp.write-char++ #\# xp) + (xp.write-char++ #\\ xp) + (if name + (xp.write-string++ name xp 0 (string-length name)) + (xp.write-char++ object xp))) + (xp.write-char+ object xp))) + +(define (xp.print-vector object xp) + (let* ((pretty? (dynamic *print-pretty*)) + (end (vector-length object))) + (pprint-logical-block (xp '() "#(" ")") + (do ((i 0 (1+ i))) + ((eqv? i end) '#f) + (when (not (eqv? i 0)) + (xp.write-char++ #\space xp) + (if pretty? + (xp.pprint-newline+ 'fill xp))) + (pprint-pop) + (xp.write+ (vector-ref object i) xp) + )))) + +(define (xp.print-table object xp) + (let ((pretty? (dynamic *print-pretty*))) + (pprint-logical-block (xp '() "#<Table" ">") + (table-for-each + (lambda (key value) + (xp.write-char++ #\space xp) + (if pretty? + (xp.pprint-newline+ 'fill xp)) + (pprint-pop) + (xp.write+ (cons key value) xp)) + object)))) + +(define (xp.print-pair object xp) + (if (dynamic *print-pretty*) + (xp.pretty-print-list object xp) + (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f) + (do () + ((null? object) '#f) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (when (not (null? object)) (xp.write-char++ #\space xp)))))) + +(define (xp.print-struct object xp) + (if (dynamic *print-structure*) + (print-structure-default object xp) + (funcall (get-structure-printer (struct-type-descriptor object)) + object xp))) + +(define (get-structure-printer td) + (or (td-printer td) + (if (eq? (td-name td) 'struct) + (function print-structure-default) + (get-structure-printer (td-parent-type td))))) + + + +(define (print-structure-default object xp) + (let* ((td (struct-type-descriptor object)) + (slots (td-slots td)) + (pretty? (dynamic *print-pretty*))) + (pprint-logical-block (xp '() "#<Struct " ">") + (prin1 (td-name td) xp) + (when (dynamic *print-structure-slots*) + (dolist (s slots) + (write-char #\space xp) + (if pretty? (pprint-newline 'fill xp)) + (pprint-pop) + (prin1 (sd-name s) xp) + (write-char #\space xp) + (write (funcall (sd-getter-function s) object) xp))) + ))) + + +;;; This table can't be initialized until after all the functions +;;; have been defined. + +(define *standard-print-dispatch-table* + (list (cons (function null?) (function xp.print-null)) + (cons (lambda (x) (eq? x '#t)) (function xp.print-true)) + (cons (function not) (function xp.print-false)) + (cons (function symbol?) (function xp.print-symbol)) + (cons (function number?) (function xp.print-number)) + (cons (function pair?) (function xp.print-pair)) + (cons (function string?) (function xp.print-string)) + (cons (function char?) (function xp.print-character)) + (cons (function struct?) (function xp.print-struct)) + (cons (function vector?) (function xp.print-vector)) + (cons (function table?) (function xp.print-table)))) + +(define (standard-print-dispatch object) + (standard-print-dispatch-aux + object (dynamic *standard-print-dispatch-table*))) + +(define (standard-print-dispatch-aux object table) + (cond ((null? table) (function xp.print-default)) + ((funcall (car (car table)) object) + (cdr (car table))) + (else + (standard-print-dispatch-aux object (cdr table))))) + +(setf (dynamic *print-dispatch*) (function standard-print-dispatch)) + + + +;;;===================================================================== +;;; Pretty printing formats for code +;;;===================================================================== + + +;;; The standard prettyprinters for lists dispatch off the CAR of the list. + +(define *xp.pair-dispatch-table* (make-table)) + +(define (xp.pretty-print-list object xp) + (funcall (or (table-entry (dynamic *xp.pair-dispatch-table*) (car object)) + (if (symbol? (car object)) (function xp.fn-call) '#f) + (lambda (object xp) + (pprint-fill xp object))) + object + xp)) + + +;;; Must use pprint-logical-block (no +) in the following three, because they +;;; are exported functions. +;;; *** Note that the argument order on these is backwards; that's the +;;; *** way it is in Common Lisp.... + +(define (pprint-linear s object . moreargs) + (let* ((colon? (if (not (null? moreargs)) (pop moreargs) '#t)) + (atsign? (if (not (null? moreargs)) (pop moreargs) '#f))) + (declare (ignore atsign?)) + (pprint-logical-block (s object (if colon? "(" "") (if colon? ")" "")) + (pprint-exit-if-list-exhausted) + (do () ('#f) + (xp.write+ (pprint-pop) s) + (pprint-exit-if-list-exhausted) + (xp.write-char++ #\space s) + (xp.pprint-newline+ 'linear s))))) + +(define (pprint-fill s object . moreargs) + (let* ((colon? (if (not (null? moreargs)) (pop moreargs) '#t)) + (atsign? (if (not (null? moreargs)) (pop moreargs) '#f))) + (declare (ignore atsign?)) + (pprint-logical-block (s object (if colon? "(" "") (if colon? ")" "")) + (pprint-exit-if-list-exhausted) + (do () ('#f) + (xp.write+ (pprint-pop) s) + (pprint-exit-if-list-exhausted) + (xp.write-char++ #\space s) + (xp.pprint-newline+ 'fill s))))) + +(define (pprint-tabular s object . moreargs) + (let* ((colon? (if (not (null? moreargs)) (pop moreargs) '#t)) + (atsign? (if (not (null? moreargs)) (pop moreargs) '#f)) + (tabsize (or (and (not (null? moreargs)) (pop moreargs)) 16))) + (declare (ignore atsign?)) + (pprint-logical-block (s object (if colon? "(" "") (if colon? ")" "")) + (pprint-exit-if-list-exhausted) + (do () ('#f) + (xp.write+ (pprint-pop) s) + (pprint-exit-if-list-exhausted) + (xp.write-char++ #\space s) + (xp.pprint-tab+ 'section-relative 0 tabsize s) + (xp.pprint-newline+ 'fill s))))) + + +(define (xp.fn-call object xp) + ;; (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>") + (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (xp.pprint-exit-if-list-exhausted+ object) + (xp.write-char++ #\space xp) + (xp.pprint-indent+ 'current 0 xp) + (xp.pprint-newline+ 'miser xp) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (do () + ((null? object) '#f) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'linear xp) + (xp.write+ (xp.pprint-pop+ object xp) xp)))) + + +;;; Although idiosyncratic, I have found this very useful to avoid large +;;; indentations when printing out code. + +(define (xp.alternative-fn-call object xp) + (if (> (string-length (symbol->string (car object))) 12) + ;; (formatter "~:<~1I~@{~W~^ ~_~}~:>") + (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f) + (xp.pprint-indent+ 'block 1 xp) + (when (not (null? object)) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (do () + ((null? object) '#f) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'linear xp) + (xp.write+ (xp.pprint-pop+ object xp) xp)))) + (xp.fn-call object xp))) + + +(define (xp.bind-list object xp . args) + (declare (ignore args)) + ;; (formatter "~:<~@{~:/xp:pprint-fill/~^ ~_~}~:>") + (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f) + (when (not (null? object)) + (pprint-fill xp (xp.pprint-pop+ object xp) '#t '#f) + (do () + ((null? object) '#f) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'linear xp) + (pprint-fill xp (xp.pprint-pop+ object xp) '#t '#f))))) + +(define (xp.fbind-list object xp . args) + (declare (ignore args)) + ;; (formatter "~:<~@{~:/xp:pprint-fill/~^ ~_~}~:>") + (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f) + (when (not (null? object)) + (pprint-fill xp (xp.pprint-pop+ object xp) '#t '#f) + (do () + ((null? object) '#f) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'linear xp) + (xp.block-like (xp.pprint-pop+ object xp) xp))))) + + +(define (xp.block-like object xp . args) + (declare (ignore args)) + ;; (formatter "~:<~1I~^~W~^ ~@_~W~^~@{ ~_~W~^~}~:>") + (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f) + (xp.pprint-indent+ 'block 1 xp) + (xp.pprint-exit-if-list-exhausted+ object) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (xp.pprint-exit-if-list-exhausted+ object) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'miser xp) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (xp.pprint-exit-if-list-exhausted+ object) + (do () + ((null? object) '#f) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'linear xp) + (xp.write+ (xp.pprint-pop+ object xp) xp)))) + + +(define (xp.print-fancy-fn-call object xp template) + (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (xp.pprint-indent+ 'current 1 xp) + (do ((i 0 (1+ i)) + (in-first-section '#t)) + ((null? object) '#f) + (xp.write-char++ #\space xp) + (when (eqv? i (car template)) + (xp.pprint-indent+ 'block (cadr template) xp) + (setf template (cddr template)) + (setf in-first-section '#f)) + (pprint-newline (cond ((zero? i) 'miser) + (in-first-section 'fill) + (else 'linear)) + xp) + (xp.write+ (xp.pprint-pop+ object xp) xp)))) + +(define (xp.let-print object xp) + ;; (formatter "~:<~1I~W~^ ~@_~/xp:xp.bind-list/~^~@{ ~_~W~^~}~:>") + (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f) + (xp.pprint-indent+ 'block 1 xp) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (xp.pprint-exit-if-list-exhausted+ object) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'miser xp) + (xp.bind-list (xp.pprint-pop+ object xp) xp '#f '#f) + (xp.pprint-exit-if-list-exhausted+ object) + (do () + ((null? object) '#f) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'linear xp) + (xp.write+ (xp.pprint-pop+ object xp) xp)))) + +(define (xp.flet-print object xp) + (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f) + (xp.pprint-indent+ 'block 1 xp) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (xp.pprint-exit-if-list-exhausted+ object) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'miser xp) + (xp.fbind-list (xp.pprint-pop+ object xp) xp '#f '#f) + (xp.pprint-exit-if-list-exhausted+ object) + (do () + ((null? object) '#f) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'linear xp) + (xp.write+ (xp.pprint-pop+ object xp) xp)))) + +(define (xp.cond-print object xp) + ;; (formatter "~:<~W~^ ~:I~@_~@{~:/xp:pprint-linear/~^ ~_~}~:>") + (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (xp.pprint-exit-if-list-exhausted+ object) + (xp.write-char++ #\space xp) + (xp.pprint-indent+ 'current 0 xp) + (xp.pprint-newline+ 'miser xp) + (pprint-linear xp (xp.pprint-pop+ object xp) '#t '#f) + (do () + ((null? object) '#f) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'linear xp) + (pprint-linear xp (xp.pprint-pop+ object xp) '#t '#f)))) + +(define (xp.do-print object xp) + ;; (formatter "~:<~W~^ ~:I~@_~/xp:xp.bind-list/~^ ~_~:/xp:pprint-linear/ ~1I~^~@{ ~_~W~^~}~:>") + (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (xp.pprint-exit-if-list-exhausted+ object) + (xp.write-char++ #\space xp) + (xp.pprint-indent+ 'current 0 xp) + (xp.pprint-newline+ 'miser xp) + (xp.bind-list (xp.pprint-pop+ object xp) xp '#f '#f) + (xp.pprint-exit-if-list-exhausted+ object) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'linear xp) + (pprint-linear xp (xp.pprint-pop+ object xp) '#t '#f) + (xp.write-char++ #\space xp) + (xp.pprint-indent+ 'block 1 xp) + (do () + ((null? object) '#f) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'linear xp) + (xp.write+ (xp.pprint-pop+ object xp) xp)))) + +(define (xp.mvb-print object xp) + (xp.print-fancy-fn-call object xp '(1 3 2 1))) + +(define (xp.setf-print object xp) + ;; (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~:_~W~^ ~_~}~:>") + (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (xp.pprint-exit-if-list-exhausted+ object) + (xp.write-char++ #\space xp) + (xp.pprint-indent+ 'current 0 xp) + (xp.pprint-newline+ 'miser xp) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (do () + ((null? object) '#f) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'fill xp) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (when (not (null? object)) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'linear xp) + (xp.write+ (xp.pprint-pop+ object xp) xp))))) + +(define (xp.quote-print object xp) + (if (and (pair? (cdr object)) (null? (cddr object))) + (begin + (xp.write-char++ #\' xp) + (xp.write+ (cadr object) xp)) + (pprint-fill xp object))) + +(define (xp.up-print object xp) + (xp.print-fancy-fn-call object xp '(0 3 1 1))) + + +;;; Install printers for built-in macros and special forms into the +;;; standard dispatch table. + +(define-local-syntax (define-printer symbol function) + `(setf (table-entry (dynamic *xp.pair-dispatch-table*) ',symbol) + (function ,function))) + + +;;; *** Missing support for backquote here. + +(define-printer quote xp.quote-print) +(define-printer lambda xp.block-like) +(define-printer when xp.block-like) +(define-printer unless xp.block-like) +(define-printer cond xp.cond-print) +(define-printer case xp.block-like) +(define-printer setf xp.setf-print) +(define-printer set! xp.setf-print) +(define-printer let xp.let-print) +(define-printer let* xp.let-print) +(define-printer letrec xp.let-print) +(define-printer flet xp.flet-print) +(define-printer labels xp.flet-print) +(define-printer dynamic-let xp.let-print) +(define-printer block xp.block-like) +(define-printer do xp.do-print) +(define-printer dolist xp.block-like) +(define-printer dotimes xp.block-like) +(define-printer multiple-value-bind xp.mvb-print) +(define-printer let/cc xp.block-like) +(define-printer unwind-protect xp.up-print) +(define-printer define xp.block-like) +(define-printer define-syntax xp.block-like) +(define-printer define-local-syntax xp.block-like) +(define-printer pprint-logical-block xp.block-like) +(define-printer xp.pprint-logical-block+ xp.block-like) + +;;; Here are some hacks for struct macros. + +(define-printer update-slots xp.mvb-print) +(define-printer make xp.block-like) diff --git a/support/support.scm b/support/support.scm new file mode 100644 index 0000000..bdecc4f --- /dev/null +++ b/support/support.scm @@ -0,0 +1,35 @@ +;;; support.scm -- load support files shared by all systems +;;; +;;; author : Sandra Loosemore +;;; date : 28 Oct 1991 +;;; +;;; + + +;;; Keep track of all compilation units defined. +;;; This has to go here and not in compile.scm because we don't want this +;;; list reinitialized every time that file is loaded. + +(define compilation-units '()) + + +;;; Load this file first; it defines the basic compilation system support. +;;; It doesn't matter if this ends up loading source because we'll compile +;;; and reload it below. + +(load "$Y2/support/compile.scm") + + +;;; Define a real compilation unit for shared support files. + +(define-compilation-unit support + (source-filename "$Y2/support/") + (unit compile (source-filename "compile.scm")) + (unit utils (source-filename "utils.scm")) + (unit xp + (unit pprint (source-filename "pprint.scm")) + (unit format (source-filename "format.scm") + (require pprint))) + ) + + diff --git a/support/system.scm b/support/system.scm new file mode 100644 index 0000000..ac03b10 --- /dev/null +++ b/support/system.scm @@ -0,0 +1,51 @@ +;;; system.scm -- haskell system setup +;;; +;;; author : Sandra Loosemore +;;; date : 22 Nov 1991 +;;; +;;; This file loads in the compilation unit definition files for all +;;; of the components of the haskell system. +;;; +;;; (The compilation unit facility is defined in support/shared/compile.scm.) + + +;;; First load the files containing module definitions. +;;; *** Add more files to the end of this list. + +(load "$Y2/support/support") +(load "$Y2/ast/ast") +(load "$Y2/top/top") +(load "$Y2/util/haskell-utils") +(load "$Y2/printers/printers") +(load "$Y2/parser/parser") +(load "$Y2/import-export/ie.scm") +(load "$Y2/tdecl/tdecl.scm") +(load "$Y2/derived/derived.scm") +(load "$Y2/prec/prec.scm") +(load "$Y2/depend/depend.scm") +(load "$Y2/type/type.scm") +(load "$Y2/cfn/cfn.scm") +(load "$Y2/flic/flic.scm") +(load "$Y2/backend/backend.scm") +(load "$Y2/runtime/runtime.scm") +(load "$Y2/csys/csys") +(load "$Y2/command-interface/command-interface") + +;;; Define some functions to actually do the work. The compilation unit +;;; facility has conveniently kept a list of all of the unit definitions, +;;; so we can just rip through them in sequence. + +(define (compile-haskell) + (compile-and-load-unit-list compilation-units)) + +(define (recompile-haskell) + (unless (null? remaining-units) + (compile-and-load-unit-list remaining-units))) + + +(define (load-haskell) + (load-unit-list compilation-units)) + +(define (reload-haskell) + (unless (null? remaining-units) + (load-unit-list remaining-units))) diff --git a/support/utils.scm b/support/utils.scm new file mode 100644 index 0000000..ab93f6b --- /dev/null +++ b/support/utils.scm @@ -0,0 +1,408 @@ +;;; utils.scm -- utility functions +;;; +;;; author : Sandra Loosemore +;;; date : 18 Nov 1991 +;;; +;;; This file contains miscellaneous functions that are generally useful. +;;; If you find some missing feature from the base language, this is +;;; a good place to put it. Common Lisp-style sequence functions are +;;; an example of the sort of thing found here. + + +;;;===================================================================== +;;; Sequence functions +;;;===================================================================== + +(define (vector-replace to-vec from-vec to start end) + (declare (type fixnum to start end) + (type vector to-vec from-vec)) + (if (and (eq? to-vec from-vec) + (> to start)) + ;; Right shift in place + (do ((from (1- end) (1- from)) + (to (1- (+ to (- end start))))) + ((< from start) to-vec) + (declare (type fixnum from to)) + (setf (vector-ref to-vec to) (vector-ref from-vec from)) + (decf to)) + ;; Normal case, left-to-right + (do ((from start (1+ from))) + ((= from end) to-vec) + (declare (type fixnum from)) + (setf (vector-ref to-vec to) (vector-ref from-vec from)) + (incf to)))) + +(define (string-replace to-vec from-vec to start end) + (declare (type fixnum to start end) + (type string to-vec from-vec)) + (if (and (eq? to-vec from-vec) + (> to start)) + ;; Right shift in place + (do ((from (1- end) (1- from)) + (to (1- (+ to (- end start))))) + ((< from start) to-vec) + (declare (type fixnum from to)) + (setf (string-ref to-vec to) (string-ref from-vec from)) + (decf to)) + ;; Normal case, left-to-right + (do ((from start (1+ from))) + ((= from end) to-vec) + (declare (type fixnum from)) + (setf (string-ref to-vec to) (string-ref from-vec from)) + (incf to)))) + +(define (string-fill string c start end) + (declare (type fixnum start end) + (type string string) + (type char c)) + (do ((i start (1+ i))) + ((= i end) string) + (declare (type fixnum i)) + (setf (string-ref string i) c))) + +(define (string-position c string start end) + (declare (type fixnum start end) + (type string string) + (type char c)) + (cond ((= start end) '#f) + ((char=? (string-ref string start) c) start) + (else + (string-position c string (1+ start) end)))) + +(define (string-position-not-from-end c string start end) + (declare (type fixnum start end) + (type string string) + (type char c)) + (cond ((= start end) '#f) + ((not (char=? (string-ref string (setf end (1- end))) c)) + end) + (else + (string-position-not-from-end c string start end)))) + +(define (string-nreverse string start end) + (declare (type fixnum start end) + (type string string)) + (do ((i start (1+ i)) + (j (1- end) (1- j))) + ((not (< i j)) string) + (declare (type fixnum i j)) + (let ((c (string-ref string i))) + (setf (string-ref string i) (string-ref string j)) + (setf (string-ref string j) c)))) + + +(define (string-starts? s1 s2) ; true is s1 begins s2 + (and (>= (string-length s2) (string-length s1)) + (string=? s1 (substring s2 0 (string-length s1))))) + + +;;;===================================================================== +;;; Table utilities +;;;===================================================================== + + +(define (table->list table) + (let ((l '())) + (table-for-each + (lambda (key val) (push (cons key val) l)) table) + l)) + +(define (list->table l) + (let ((table (make-table))) + (dolist (p l) + (setf (table-entry table (car p)) (cdr p))) + table)) + + + +;;;===================================================================== +;;; Tuple utilities +;;;===================================================================== + +;;; For future compatibility with a typed language, define 2 tuples with +;;; a few functions: (maybe add 3 tuples someday!) + +(define-integrable (tuple x y) + (cons x y)) + +(define-integrable (tuple-2-1 x) (car x)) ; Flic-like notation +(define-integrable (tuple-2-2 x) (cdr x)) + +(define (map-tuple-2-1 f l) + (map (lambda (x) (tuple (funcall f (tuple-2-1 x)) (tuple-2-2 x))) l)) + +(define (map-tuple-2-2 f l) + (map (lambda (x) (tuple (tuple-2-1 x) (funcall f (tuple-2-2 x)))) l)) + + +;;;===================================================================== +;;; List utilities +;;;===================================================================== + +;;; This does an assq using the second half of the tuple as the key. + +(define (rassq x l) + (if (null? l) + '#f + (if (eq? x (tuple-2-2 (car l))) + (car l) + (rassq x (cdr l))))) + +;;; This is an assoc with an explicit test + +(define (assoc/test test-fn x l) + (if (null? l) + '#f + (if (funcall test-fn x (tuple-2-1 (car l))) + (car l) + (assoc/test test-fn x (cdr l))))) + + + + +;;; Stupid position function works only on lists, uses eqv? + +(define (position item list) + (position-aux item list 0)) + +(define (position-aux item list index) + (declare (type fixnum index)) + (cond ((null? list) + '#f) + ((eqv? item (car list)) + index) + (else + (position-aux item (cdr list) (1+ index))) + )) + + +;;; Destructive delete-if function + +(define (list-delete-if f l) + (list-delete-if-aux f l l '#f)) + +(define (list-delete-if-aux f head next last) + (cond ((null? next) + ;; No more elements. + head) + ((not (funcall f (car next))) + ;; Leave this element and do the next. + (list-delete-if-aux f head (cdr next) next)) + (last + ;; Delete element from middle of list. + (setf (cdr last) (cdr next)) + (list-delete-if-aux f head (cdr next) last)) + (else + ;; Delete element from head of list. + (list-delete-if-aux f (cdr next) (cdr next) last)))) + + +;;; Same as the haskell function + +(define (concat lists) + (if (null? lists) + '() + (append (car lists) (concat (cdr lists))))) + + +;;; This is a quick & dirty list sort function. + +(define (sort-list l compare-fn) + (if (or (null? l) (null? (cdr l))) + l + (insert-sorted compare-fn (car l) (sort-list (cdr l) compare-fn)))) + +(define (insert-sorted compare-fn e l) + (if (null? l) + (list e) + (if (funcall compare-fn e (car l)) + (cons e l) + (cons (car l) (insert-sorted compare-fn e (cdr l)))))) + +(define (find-duplicates l) + (cond ((null? l) + '()) + ((memq (car l) (cdr l)) + (cons (car l) + (find-duplicates (cdr l)))) + (else (find-duplicates (cdr l))))) + +;;; A simple & slow topsort routine. +;;; Input: A list of lists. Each list is a object consed onto the +;;; list of objects it preceeds. +;;; Output: Two values: SORTED / CYCLIC & a list of either sorted objects +;;; or a set of components containing the cycle. + +(define (topsort l) + (let ((changed? '#t) + (sorted '()) + (next '())) + (do () ((not changed?) + (if (null? next) + (values 'sorted (nreverse sorted)) + (values 'cyclic (map (function car) next)))) + (setf changed? '#f) + (setf next '()) + (dolist (x l) + (cond ((topsort-aux (cdr x) sorted) + (push (car x) sorted) + (setf changed? '#t)) + (else + (push x next)))) + (setf l next)))) + + +;;; Returns true if x doesn't contain any elements that aren't in sorted. +;;; equivalent to (null? (set-intersection x sorted)), but doesn't cons +;;; and doesn't traverse the whole list in the failure case. + +(define (topsort-aux x sorted) + (cond ((null? x) + '#t) + ((memq (car x) sorted) + (topsort-aux (cdr x) sorted)) + (else + '#f))) + +(define (set-intersection s1 s2) + (if (null? s1) + '() + (let ((rest (set-intersection (cdr s1) s2))) + (if (memq (car s1) s2) + (cons (car s1) rest) + rest)))) + +;;; remove s2 elements from s1 + +(define (set-difference s1 s2) + (if (null? s1) + '() + (let ((rest (set-difference (cdr s1) s2))) + (if (memq (car s1) s2) + rest + (cons (car s1) rest))))) + + +(define (set-union s1 s2) + (if (null? s2) + s1 + (if (memq (car s2) s1) + (set-union s1 (cdr s2)) + (cons (car s2) (set-union s1 (cdr s2)))))) + + +;;; Destructive list splitter + +(define (split-list list n) + (declare (type fixnum n)) + (let ((tail1 (list-tail list (1- n)))) + (if (null? tail1) + (values list '()) + (let ((tail2 (cdr tail1))) + (setf (cdr tail1) '()) + (values list tail2))))) + + +;;; Some string utils + +(define (mem-string s l) + (and (not (null? l)) (or (string=? s (car l)) + (mem-string s (cdr l))))) + +(define (ass-string k l) + (cond ((null? l) + '#f) + ((string=? k (caar l)) + (car l)) + (else + (ass-string k (cdr l))))) + + +;;;===================================================================== +;;; Syntax extensions +;;;===================================================================== + +;;; The mlet macro combines let* and multiple-value-bind into a single +;;; syntax. + +(define-syntax (mlet binders . body) + (mlet-body binders body)) + +(define (mlet-body binders body) + (if (null? binders) + `(begin ,@body) + (let* ((b (car binders)) + (var (car b)) + (init (cadr b)) + (inner-body (mlet-body (cdr binders) body))) + (if (pair? var) + (multiple-value-bind (new-vars ignore-decl) + (remove-underlines var) + `(multiple-value-bind ,new-vars + ,init ,@ignore-decl ,inner-body)) + `(let ((,var ,init)) ,inner-body))))) + +(define (remove-underlines vars) + (if (null? vars) + (values '() '()) + (multiple-value-bind (rest ignore-decl) (remove-underlines (cdr vars)) + (if (not (eq? (car vars) '_)) + (values (cons (car vars) rest) ignore-decl) + (let ((var (gensym))) + (values (cons var rest) + `((declare (ignore ,var)) ,@ignore-decl))))))) + + + + +;;;===================================================================== +;;; Other utilities +;;;===================================================================== + +(define (add-extension name ext) + (assemble-filename (filename-place name) (filename-name name) ext)) + +(define (time-execution thunk) + (let* ((start-time (get-run-time)) + (res (funcall thunk)) + (end-time (get-run-time))) + (values res (- end-time start-time)))) + +(define (pprint-flatten code . maybe-port) + (pprint-flatten-aux + code + (if (null? maybe-port) (current-output-port) (car maybe-port)))) + +(define (pprint-flatten-aux code port) + (if (and (pair? code) + (eq? (car code) 'begin)) + (dolist (c (cdr code)) + (pprint-flatten-aux c port)) + (pprint*-aux code port))) + +(define (print-flatten code port) + (if (and (pair? code) + (eq? (car code) 'begin)) + (dolist (c (cdr code)) + (print-flatten c port)) + (begin + (internal-write code port) + (internal-newline port)))) + + +;;; Like pprint, but print newline after instead of before. + +(define (pprint* object . maybe-port) + (pprint*-aux + object + (if (null? maybe-port) (current-output-port) (car maybe-port)))) + +(define (pprint*-aux object port) + (dynamic-let ((*print-pretty* '#t)) + (prin1 object port)) + (terpri port)) + +;;; This reads stuff from a string. (Better error checks needed!) + +(define (read-lisp-object str) + (call-with-input-string str (lambda (port) (read port)))) |