home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / top / util.t < prev   
Encoding:
Text File  |  1988-02-05  |  7.7 KB  |  224 lines
  1. (herald (orbit_top util)
  2.   (env t (orbit_top defs)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Messages
  28. ;;;==========================================================================
  29.  
  30. (lset *noise-stream*   t)  ;So NOISE works at top level.
  31. (lset *noise-flag*     t)
  32. (lset *debug-flag*     t)
  33. (lset *noise+error*    t)                                     
  34. (lset *noise+terminal* t)                                     
  35.  
  36. (define (bug f . rest)
  37.   (apply error (list f "~%  (compiler error)") rest))
  38.  
  39. (define (orbit-warning f . rest)
  40.   (apply format *noise+error* (list "~%;** Warning: " f) rest))
  41.  
  42. (define (noise f . rest)
  43.   (apply format (if *noise-flag* *noise+terminal* *noise-stream*)
  44.                 (list "~&;;; " f) rest))
  45.  
  46. (define (orbit-debug . args)
  47.   (if *debug-flag*
  48.       (apply format (terminal-output) args)))
  49.  
  50. ;;; (PP-CPS node . stream)
  51. ;;;===========================================================================
  52. ;;; Print CPS node tree in linear form.  Stream defaults to terminal output.
  53.  
  54. (define (pp-cps node . stream)
  55.   (pp-cps-1 node 4 (if stream
  56.                        (car stream)
  57.                        (terminal-output))))
  58.  
  59. (define (pp-cps-1 node indent-to stream)
  60.   (let ((z (pp-cps-2 node)))
  61.     (cond ((lambda-node? node)
  62.            (pp-cps-lambda node indent-to stream))
  63.           ((object-node? node)
  64.            (pp-cps-object node indent-to stream)))
  65.     z))
  66.  
  67. (define (pp-cps-lambda node indent-to stream)
  68.   (let ((vars (lambda-all-variables node)))
  69.     (format stream "~S" (object-hash node))
  70.     (set (hpos stream) indent-to)
  71.     (writec stream #\()
  72.     (format stream "~S" (map variable-unique-name vars))
  73.     (set (hpos stream) (fx+ indent-to 18))     ;format sux
  74.     (pretty-print (pp-cps-2 (lambda-body node)) stream)
  75.     (format stream ")~%")
  76.     (pp-cps-list (call-proc+args (lambda-body node)) indent-to stream)))
  77.  
  78. (define (pp-cps-object node indent-to stream)
  79.   (format stream "~S" (object-hash node))
  80.   (set (hpos stream) indent-to)
  81.   (writec stream #\()
  82.   (writec stream #\@)
  83.   (format stream "~D" (object-number node))
  84.   (set (hpos stream) (fx+ indent-to 18))     ;format sux
  85.   (pretty-print `(,(pp-cps-2 (object-proc node))
  86.                   ,(map pp-cps-2 (object-operations node))
  87.                   ,(map pp-cps-2 (object-methods node)))
  88.                 stream)
  89.   (format stream ")~%")
  90.   (pp-cps-list (object-proc-pair node) indent-to stream)
  91.   (pp-cps-list (object-operations node) indent-to stream)
  92.   (pp-cps-list (object-methods node) indent-to stream))
  93.  
  94. (define (pp-cps-list list indent-to stream)
  95.   (walk (lambda (node) (pp-cps-1 node (fx+ indent-to 1) stream))
  96.         list))
  97.  
  98. (define (pp-cps-2 node)
  99.   (cond ((not (node? node))
  100.          `(not-a-node ,node))
  101.         (else
  102.          (xselect (node-variant node)
  103.            ((lambda-node?)
  104.             (lambda-name node))
  105.            ((leaf-node?)
  106.             (case (leaf-variant node)
  107.                   ((literal)
  108.                    `',(literal-value node))
  109.                   ((primop)
  110.                    (if (primop? (primop-value node)) ; Hack for DK's LAP junk.
  111.                        (concatenate-symbol
  112.                         "$"
  113.                         (any-primop-id (primop-value node)))
  114.                        (concatenate-symbol "$_"
  115.                                            (object-hash (primop-value node)))))
  116.                   (else
  117.                    (variable-unique-name (reference-variable node)))))
  118.            ((call-node?)
  119.             (let ((stuff (map pp-cps-2 (call-proc+args node))))
  120.               `(,(car stuff) ,(call-exits node) . ,(cdr stuff))))
  121.            ((object-node?)
  122.             (concatenate-symbol '@ (object-number node)))))))
  123.  
  124. (define (lambda-name node)
  125.   (concatenate-symbol "^"
  126.                       (variable-name (lambda-self-var node))
  127.                       "_"
  128.                       (variable-id (lambda-self-var node))))
  129.  
  130. ;;; Returns a lexically unique name for the variable.
  131.  
  132. (define (variable-unique-name var)
  133.   (cond ((variable? var)
  134.          (let ((name (variable-name var)))
  135.            (cond ((variable-binder var)
  136.                   (concatenate-symbol name "_" (variable-id var)))
  137.                  (else
  138.                   name))))
  139.         ((primop? var)
  140.          (identification var))
  141.         (else
  142.          var)))
  143.  
  144. ;;; Little utilities.
  145. ;;;========================================================================
  146.  
  147. (define (find pred l)
  148.   (iterate loop ((l l))
  149.     (cond ((null? l) nil)
  150.           ((pred (car l)) (car l))
  151.           (else (loop (cdr l))))))
  152.  
  153. (define (filter pred l)
  154.   (iterate loop ((l l) (r '()))
  155.     (cond ((null? l) (reverse! r))
  156.           ((pred (car l)) (loop (cdr l) (cons (car l) r)))
  157.           (else (loop (cdr l) r)))))
  158.  
  159. (define (filter! pred list)
  160.   (iterate filter! ((list list))
  161.     (cond ((null-list? list) '())
  162.           ((pred (car list)) (set (cdr list) (filter! (cdr list))) list)
  163.           (else (filter! (cdr list))))))
  164.  
  165. (define (select-from-table pred table)
  166.   (let ((res '()))
  167.     (table-walk table
  168.                 (lambda (key entry)
  169.                   (if (pred key entry)
  170.                       (push res `(,key . ,entry)))))
  171.     res))
  172.  
  173. (define (table->list table)
  174.   (select-from-table true table))
  175.  
  176. (define (table-push table key val)
  177.   (modify (table-entry table key)
  178.           (lambda (old)
  179.             (if old
  180.                 (cons val old)
  181.                 (list val))))
  182.   val)
  183.  
  184. (define (table-pop table key)
  185.   (pop (table-entry table key)))
  186.  
  187. (define (free-table-push table key val)
  188.   (modify (table-entry table key)
  189.           (lambda (old)
  190.             (if old
  191.                 (cons-from-freelist val old)
  192.                 (cons-from-freelist val '()))))
  193.   val)
  194.  
  195. (define (free-table-pop table key)
  196.   (let ((x (table-entry table key)))
  197.     (cond ((null? x)
  198.            '#f)
  199.           (else
  200.            (set (table-entry table key) (cdr x))
  201.              (let ((y (car x)))
  202.                (return-to-freelist x)
  203.                y)))))
  204.  
  205. (define (merge-lists x y)
  206.   (cond ((null? y) x)
  207.         (else (do ((z x (cdr z))
  208.                    (u y (let ((w (car z)))
  209.                           (if (memq? w u) u (cons w u)))))
  210.                   ((null? z) u)))))
  211.  
  212. (define (partition-list pred l)
  213.   (iterate loop ((l l) (yes '()) (no '()))
  214.     (cond ((null? l)
  215.            (return (reverse! yes) (reverse! no)))
  216.           ((pred (car l))
  217.            (loop (cdr l) (cons (car l) yes) no))
  218.           (else
  219.            (loop (cdr l) yes (cons (car l) no))))))
  220.  
  221.  
  222.  
  223.  
  224.