home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / sicp / compat.scm < prev    next >
Encoding:
Text File  |  1993-07-17  |  6.1 KB  |  213 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Header: /scheme/sicp/RCS/compat.scm,v 1.4 1991/05/04 21:51:19 jinx Exp $
  4.  
  5. Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
  6.  
  7. This material was developed by the Scheme project at the Massachusetts
  8. Institute of Technology, Department of Electrical Engineering and
  9. Computer Science.  Permission to copy this software, to redistribute
  10. it, and to use it for any purpose is granted, subject to the following
  11. restrictions and understandings.
  12.  
  13. 1. Any copy made of this software must include this copyright notice
  14. in full.
  15.  
  16. 2. Users of this software agree to make their best efforts (a) to
  17. return to the MIT Scheme project any improvements or extensions that
  18. they make, so that these may be included in future releases; and (b)
  19. to inform MIT of noteworthy uses of this software.
  20.  
  21. 3. All materials developed as a consequence of the use of this
  22. software shall duly acknowledge such use, in accordance with the usual
  23. standards of acknowledging credit in academic research.
  24.  
  25. 4. MIT has made no warrantee or representation that the operation of
  26. this software will be error-free, and MIT is under no obligation to
  27. provide any services, by way of maintenance, update, or otherwise.
  28.  
  29. 5. In conjunction with products arising from the use of this material,
  30. there shall be no use of the name of the Massachusetts Institute of
  31. Technology nor of any adaptation thereof in any advertising,
  32. promotional, or sales literature without prior written consent from
  33. MIT in each case. |#
  34.  
  35. ;;;; 6.001 Compatibility Definitions
  36.  
  37. (declare (usual-integrations))
  38.  
  39. ;;; Make rationals print as flonums to create the illusion of not having
  40. ;;; rationals at all, since the Chipmunks don't.
  41.  
  42. (in-package (->environment '(runtime number))
  43.   (define (rat:->string q radix)
  44.     (if (ratnum? q)
  45.     (let ((divided (flo:/ (int:->flonum (ratnum-numerator q))
  46.                   (int:->flonum (ratnum-denominator q)))))
  47.       (if (integer? divided)
  48.           (int:->string divided radix)
  49.           (flo:->string divided radix)))
  50.     (int:->string q radix))))
  51.  
  52. (define (alphaless? symbol1 symbol2)
  53.   (string<? (symbol->string symbol1) (symbol->string symbol2)))
  54.  
  55. (define (and* . args)
  56.   (let and-loop ((args args))
  57.     (or (null? args)
  58.     (and (car args)
  59.          (and-loop (cdr args))))))
  60.  
  61. (define (digit? object)
  62.   (and (exact-nonnegative-integer? object) (<= object 9)))
  63.  
  64. (define (singleton-symbol? object)
  65.   (and (symbol? object)
  66.        (= (string-length (symbol->string object)) 1)))
  67.  
  68. (define (ascii object)
  69.   (cond ((singleton-symbol? object)
  70.      (char->ascii (char-upcase (string-ref (symbol->string object) 0))))
  71.     ((digit? object)
  72.      (char->ascii (string-ref (number->string object) 0)))
  73.     (else
  74.      (error:illegal-datum object 'ASCII))))
  75.  
  76. (define (atom? object)
  77.   (not (pair? object)))
  78.  
  79. (define (or* . args)
  80.   (let or-loop ((args args))
  81.     (and (not (null? args))
  82.      (or (car args)
  83.          (or-loop (cdr args))))))
  84.  
  85. (define char ascii->char)
  86.  
  87. (define nil false)
  88. (define t true)
  89.  
  90. (define (nth n l)
  91.   (list-ref l n))
  92.  
  93. (define (nthcdr n l)
  94.   (list-tail l n))
  95.  
  96. (define (object->string object)
  97.   (cond ((symbol? object) (symbol->string object))
  98.     ((number? object) (number->string object))
  99.     ((string? object) (string-append "\"" object "\""))
  100.     (else
  101.      (with-output-to-string
  102.        (lambda ()
  103.          (write object))))))
  104.  
  105. (define (string->object object)
  106.   (with-input-from-string object
  107.     read))
  108.  
  109. (define (explode object)
  110.   (map (lambda (character)
  111.      (let ((string (char->string character)))
  112.        (or (string->number string)
  113.            (string->symbol string))))
  114.        (string->list
  115.     (object->string object))))
  116.  
  117. (define (implode list)
  118.   (string->object
  119.    (list->string
  120.     (map (lambda (element)
  121.        (cond ((digit? element)
  122.           (string-ref (number->string element) 0))
  123.          ((singleton-symbol? element)
  124.           (string-ref (symbol->string element) 0))
  125.          (else
  126.           (error "Element neither digit nor singleton symbol"
  127.              element))))
  128.      list))))
  129.  
  130. (define (close-channel port)
  131.   (cond ((input-port? port) (close-input-port port))
  132.     ((output-port? port) (close-output-port port))
  133.     (else (error "CLOSE-CHANNEL: Wrong type argument" port))))
  134.  
  135. (define (tyi #!optional port)
  136.   (let ((char
  137.      (read-char
  138.       (if (default-object? port)
  139.           (current-output-port)
  140.           (guarantee-output-port port)))))
  141.     (if (char? char)
  142.     (char->ascii char)
  143.     char)))
  144.  
  145. (define (tyipeek #!optional port)
  146.   (let ((char
  147.      (peek-char
  148.       (if (default-object? port)
  149.           (current-output-port)
  150.           (guarantee-output-port port)))))
  151.     (if (char? char)
  152.     (char->ascii char)
  153.     char)))
  154.  
  155. (define (tyo ascii #!optional port)
  156.   (write-char (ascii->char ascii)
  157.           (if (default-object? port)
  158.           (current-output-port)
  159.           (guarantee-output-port port))))
  160.  
  161. (define (print-depth #!optional newval)
  162.   (let ((newval (if (default-object? newval) false newval)))
  163.     (if (not (or (not newval) (and (exact-integer? newval) (> newval 0))))
  164.     (error:illegal-datum newval 'PRINT-DEPTH))
  165.     (set! *unparser-list-depth-limit* newval)
  166.     unspecific))
  167.  
  168. (define (print-breadth #!optional newval)
  169.   (let ((newval (if (default-object? newval) false newval)))
  170.     (if (not (or (not newval) (and (exact-integer? newval) (> newval 0))))
  171.     (error:illegal-datum newval 'PRINT-BREADTH))
  172.     (set! *unparser-list-breadth-limit* newval)
  173.     unspecific))
  174.  
  175. (define (vector-cons size fill)
  176.   (make-vector size fill))
  177.  
  178. (define (read-from-keyboard)
  179.   (let ((input (read)))
  180.     (if (eq? input 'abort)
  181.     (cmdl-interrupt/abort-nearest)
  182.     input)))
  183.  
  184. (define (student-pp object . args)
  185.   (define (supply what old new)
  186.     (if (eq? old 'NOT-SUPPLIED)
  187.     new
  188.     (error "pp: Overspecified option"
  189.            (list what old new))))
  190.  
  191.   (define (parse-args args port as-code?)
  192.     (cond ((null? args)
  193.        (let ((port 
  194.           (if (eq? port 'NOT-SUPPLIED)
  195.               (current-output-port)
  196.               port)))
  197.          (if (eq? as-code? 'NOT-SUPPLIED)
  198.          (pp object port)
  199.          (pp object port as-code?))))
  200.       ((eq? (car args) 'AS-CODE)
  201.        (parse-args (cdr args)
  202.                port
  203.                (supply 'AS-CODE as-code? true)))
  204.       ((output-port? (car args))
  205.        (parse-args (cdr args)
  206.                (supply 'PORT port (car args))
  207.                as-code?))
  208.       (else
  209.        (error "pp: Unknown option" (car args)))))               
  210.  
  211.   (if (null? args)
  212.       (pp object)
  213.       (parse-args args 'NOT-SUPPLIED 'NOT-SUPPLIED)))