DataMuseum.dk

top - download

    Length: 12246 (0x2fd6)
    Types: TextFile
    Names: »unpars.scm.31«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─ ⟦this⟧ »EUUGD11/gnu-31mar87/scheme/scm/unpars.scm.31« 

TextFile

;;; -*-Scheme-*-
;;;
;;;	Copyright (c) 1984 Massachusetts Institute of Technology
;;;
;;;	This material was developed by the Scheme project at the
;;;	Massachusetts Institute of Technology, Department of
;;;	Electrical Engineering and Computer Science.  Permission to
;;;	copy this software, to redistribute it, and to use it for any
;;;	purpose is granted, subject to the following restrictions and
;;;	understandings.
;;;
;;;	1. Any copy made of this software must include this copyright
;;;	notice in full.
;;;
;;;	2. Users of this software agree to make their best efforts (a)
;;;	to return to the MIT Scheme project any improvements or
;;;	extensions that they make, so that these may be included in
;;;	future releases; and (b) to inform MIT of noteworthy uses of
;;;	this software.
;;;
;;;	3.  All materials developed as a consequence of the use of
;;;	this software shall duly acknowledge such use, in accordance
;;;	with the usual standards of acknowledging credit in academic
;;;	research.
;;;
;;;	4. MIT has made no warrantee or representation that the
;;;	operation of this software will be error-free, and MIT is
;;;	under no obligation to provide any services, by way of
;;;	maintenance, update, or otherwise.
;;;
;;;	5.  In conjunction with products arising from the use of this
;;;	material, there shall be no use of the name of the
;;;	Massachusetts Institute of Technology nor of any adaptation
;;;	thereof in any advertising, promotional, or sales literature
;;;	without prior written consent from MIT in each case.
;;;

;;;; Unparsers

(declare (usual-integrations))
\f


;;; This package contains procedures that convert various kinds of
;;; objects into sequences of characters.  It is defined in terms of
;;; the following procedures:

;;; (*UNPARSE-CHARACTER character)
;;; (*UNPARSE-STRING string)
;;; (*UNPARSE-OBJECT object)

;;; It is intended that the unparser procedures defined here be called
;;; by *UNPARSE-OBJECT, which is a dispatch procedure.  They in turn
;;; refer to *UNPARSE-OBJECT, expecting that it will dispatch to the
;;; correct place.

(define *unparse-character)
(define *unparse-string)
(define *unparse-object)

;;; Control Variables

(define *unparser-radix* #o12)
(define *unparser-precision* 6)
(define *unparser-list-breadth-limit* #!FALSE)
(define *unparser-list-depth* 0)
(define *unparser-list-depth-limit* #!FALSE)

;;; Careful here...  If this variable is already set up when the
;;; unparser is loaded, we will assume it has good stuff in it.

(define *unparser-special-objects*
  (if (lexical-unreferenceable? (the-environment) '*UNPARSER-SPECIAL-OBJECTS*)
      '()
      *unparser-special-objects*))

(define (add-unparser-special-object! key unparser)
  (set! *unparser-special-objects*
	(cons (cons key unparser)
	      *unparser-special-objects*)))

(define unparse-with-brackets)

(define scheme-unparser
  (make-package scheme-unparser ()
\f


;;;; Constants

(define (unparse-default object)
  (unparse-with-brackets
   (lambda ()
     (*unparse-object
      (disjunction (object-type object)
		   `(UNDEFINED-TYPE-CODE ,(primitive-type object))))
     (*unparse-character #\SP)
     (*unparse-object (primitive-datum object)))))

(set! unparse-with-brackets
      (named-lambda (unparse-with-brackets thunk)
	(*unparse-string "#[")
	(thunk)
	(*unparse-character #/])))
 
(define (unparse-null x)
  (if (eq? x '())
      (*unparse-string "()")
      (unparse-default x)))

(define (unparse-true x)
  (if (eq? x #!TRUE)
      (*unparse-string "#!TRUE")
      (unparse-default x)))

(define (unparse-unassigned x)
  (unparse-with-brackets
   (lambda ()
     (*unparse-string "UNASSIGNED"))))

(define (unparse-unbound x)
  (unparse-with-brackets
   (lambda ()
     (*unparse-string "UNBOUND"))))

(define (unparse-symbol s)
  (*unparse-string (symbol-print-name s)))

(define (unparse-string string)
  (*unparse-character #/") ;")
  (*unparse-string string)
  (*unparse-character #/")) ;"))
\f


;;;; Lists and Vectors

(define (unparse-list list)
  (let ((entry (assq (car list) *unparser-special-objects*)))
    (cond (entry
	   ((cdr entry) list))
	  ((conjunction (eq? (car list) 'QUOTE)
			(pair? (cdr list))
			(null? (cddr list)))
	   (*unparse-character #/')
	   (*unparse-object (cadr list)))
	  (else
	   (unparse-list-internal list)))))

(define (unparse-vector vector)
  (if (zero? (vector-size vector))
      (*unparse-string "#()")
      (let ((entry (assq (vector-ref vector 0) *unparser-special-objects*)))
	(cond (entry
	       ((cdr entry) vector))
	      (else
	       (*unparse-character #/#)
	       (unparse-list-internal (vector->list vector)))))))

(define (unparse-list-internal list)
  (if *unparser-list-depth-limit*
      (dynamic-wind
       (lambda ()
	 (set! *unparser-list-depth* (1+ *unparser-list-depth*)))
       (lambda ()
	 (if (> *unparser-list-depth* *unparser-list-depth-limit*)
	     (*unparse-string "...")
	     (sequence (*unparse-character #/()
		       (*unparse-object (car list))
		       (unparse-tail (cdr list) 2)
		       (*unparse-character #/)))))
       (lambda ()
	 (set! *unparser-list-depth* (-1+ *unparser-list-depth*))))
      (sequence (*unparse-character #/()
		(*unparse-object (car list))
		(unparse-tail (cdr list) 2)
		(*unparse-character #/)))))

(define (unparse-tail l n)
  (cond ((pair? l)
	 (*unparse-character #\SP)
	 (*unparse-object (car l))
	 (if (conjunction *unparser-list-breadth-limit*
			  (>= n *unparser-list-breadth-limit*)
			  (cdr l))
	     (*unparse-string " ...")
	     (unparse-tail (cdr l) (1+ n))))
	((not (null? l))
	 (*unparse-string " . ")
	 (*unparse-object l))))
\f


;;;; Procedures and Environments

(define (unparse-compound-procedure procedure)
  (unparse-with-brackets
   (lambda ()
     (*unparse-string "COMPOUND-PROCEDURE ")
     (lambda-components (procedure-lambda procedure)
       (lambda (name required optional rest auxiliary body)
	 (if (eq? name lambda-tag:unnamed)
	     (unparse-number (primitive-datum procedure))
	     (*unparse-object name)))))))

(define (unparse-primitive-procedure proc)
  (unparse-with-brackets
   (lambda ()
     (*unparse-string "PRIMITIVE-PROCEDURE ")
     (*unparse-object (primitive-procedure-name proc)))))

(define (unparse-environment environment)
  (if (lexical-unreferenceable? environment ':PRINT-SELF)
      (unparse-default environment)
      ((access :print-self environment))))
\f


;;;; Numbers, ugh bletch

(define (unparse-number number)
  (unparse-signed-number number))

(define (unparse-signed-number number)
  (if (negative? number)
      (sequence (*unparse-character #/-)
		(unparse-positive-number (- 0 number)))
      (unparse-positive-number number)))

(define (unparse-positive-number x)
  (if (integer? x)
      (unparse-integer x)
       ;; could have used the previous dispatch
      (unparse-float x)))

(define bignum-type
  (microcode-type 'BIG-FIXNUM))

(define listify-bignum
  (make-primitive-procedure 'LISTIFY-BIGNUM))

(define (unparse-integer integer)
  (local-declare
   ((compilable-primitive-function listify-bignum))
   (cond ((zero? integer)
	  (*unparse-character #/0))
	 ((primitive-type? bignum-type integer)
	  (spit-character-values (listify-bignum integer *unparser-radix*)))
	 (else
	  (let loop ((n integer))
	    (if (not (zero? n))
		(let ((q (integer-divide n *unparser-radix*)))
		  (loop (integer-divide-quotient q))
		  (spit-character-value (integer-divide-remainder q)))))))))

(define mantissa-precision-base
  (* (access floating-mantissa-bits implementation-dependencies)
     (log 2)))

(define (mantissa-precision r)
  (round (/ mantissa-precision-base (log r))))

(define (unparse-float x)
  (let ((n (normalize x))
	(precision
	 (disjunction *unparser-precision*
		      (mantissa-precision *unparser-radix*))))
    (let ((digit-info (floating-digits (car n) precision))
	  (initial-exponent (cdr n)))
      (let ((digits (cdr digit-info))
	    (exponent (if (car digit-info)
			  (1+ initial-exponent)
			  initial-exponent)))
	(cond ((conjunction (>= exponent 0)		;type out as 100.3
			    (< exponent precision))
	       (spit-out-big digits exponent))
	      ((conjunction (< exponent 0)		;type out as .0015
			    (<= (- (length digits)
				   (1+ exponent))
				precision))
	       (spit-radix-point)
	       (spit-out-small digits (1+ exponent)))
	      (else					;type out as 9.2E16
	       (spit-out-scientific digits)
	       (unparse-signed-number exponent)))))))
\f


(define (normalize x)
  (let loop ((x x) (count 0))
     (cond ((< x 1)
	    (loop (* x *unparser-radix*)
		  (-1+ count)))
	   ((>= x *unparser-radix*)
	    (loop (/ x *unparser-radix*)
		  (1+ count)))
	   (else
	    (cons x count)))))

(define (floating-digits x initial-precision)
  (let ((radix-1 (-1+ *unparser-radix*)))
    (let loop ((x x)
	       (precision-remaining initial-precision))
	     (if (zero? precision-remaining)
		 '()
		 (let ((digit (floor x)))
		   (let ((more (loop (* (- x digit) *unparser-radix*)
				     (-1+ precision-remaining))))
		     (cond ((eq? more #!TRUE)
			    (if (= digit radix-1)
				(if (= initial-precision
				       precision-remaining)
				    '(#!TRUE 1)
				    #!TRUE)
				(if (= initial-precision precision-remaining)
				    (list #!FALSE (1+ digit))
				    (cons (1+ digit) '()))))
			   ((= initial-precision precision-remaining)
			    (cons #!FALSE (cons digit more)))
			   (more
			    (cons digit more))
			   ((zero? digit)
			    '())
			   ((conjunction (= precision-remaining 1)
					 (= digit radix-1))
			    #!TRUE)
			   (else
			    (cons digit '())))))))))

(define (spit-out-big digits exponent)
  (spit-character-value (car digits))
  (cond ((null? (cdr digits))
	 (fill-out-with-zeros exponent)
	 (spit-radix-point))
	((zero? exponent)
	 (spit-radix-point)
	 (spit-character-values (cdr digits)))
	(else
	 (spit-out-big (cdr digits)
		       (-1+ exponent)))))

(define (fill-out-with-zeros exponent)
  (if (not (zero? exponent))
      (sequence (spit-character-value 0)
		(fill-out-with-zeros (-1+ exponent)))))
\f


(define (spit-out-small digits exponent)
  (if (zero? exponent)
      (spit-character-values digits)
      (sequence (spit-character-value 0)
		(spit-out-small digits (1+ exponent)))))

(define (spit-out-scientific digits)
  (spit-character-value (car digits))
  (spit-radix-point)
  (spit-character-values (cdr digits))
  (*unparse-character #/e))

(define (spit-character-values l)
  (if (not (null? l))
      (sequence (*unparse-character (character-value (car l)))
		(spit-character-values (cdr l)))))

(define (spit-character-value n)
  (*unparse-character (character-value n)))

(define character-value
  (let ((A-10 (- #/A #o12)))
    (named-lambda (character-value digit)
      (+ (if (< digit #o12) #/0 A-10)
	 digit))))

(define (spit-radix-point)
  (*unparse-character #/.))
\f


;;;; Default Unparser

(set! *unparse-object
      (let ((dispatch-vector
	     (let ((dispatch-vector (vector-cons number-of-microcode-types
						 unparse-default)))
	       (define (set-dispatch! type dispatcher)
		 (vector-set! dispatch-vector (microcode-type type) dispatcher))
	       (set-dispatch! 'NULL unparse-null)
	       (set-dispatch! 'TRUE unparse-true)
	       (set-dispatch! 'STRING unparse-string)
	       (set-dispatch! 'LIST
			      (lambda (list)
				((cond ((unassigned-object? list)
					unparse-unassigned)
				       ((unbound-object? list)
					unparse-unbound)
				       (else unparse-list))
				 list)))
	       (set-dispatch! 'VECTOR unparse-vector)
	       (set-dispatch! 'UNINTERNED-SYMBOL unparse-symbol)
	       (set-dispatch! 'INTERNED-SYMBOL unparse-symbol)
	       (set-dispatch! 'PRIMITIVE unparse-primitive-procedure)
	       (set-dispatch! 'PRIMITIVE-EXTERNAL unparse-primitive-procedure)
	       (set-dispatch! 'FIXNUM unparse-number)
	       (set-dispatch! 'BIGNUM unparse-number)
	       (set-dispatch! 'FLONUM unparse-number)
	       (set-dispatch! 'ENVIRONMENT unparse-environment)
	       (set-dispatch! 'PROCEDURE unparse-compound-procedure)
	       (set-dispatch! 'EXTENDED-PROCEDURE unparse-compound-procedure)
	       dispatch-vector)))
	(named-lambda (*unparse-object object)
	  ((vector-ref dispatch-vector (primitive-type object)) object))))

;;; end SCHEME-UNPARSER package.
))