home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / front_end / front.t < prev    next >
Encoding:
Text File  |  1990-05-07  |  8.2 KB  |  221 lines
  1. (herald (front_end front))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;;                          Main Interface
  27. ;;;============================================================================
  28.  
  29. ;;; Exciting Global Variables
  30.  
  31. (lset *new-env*           nil)   ; The new support environment
  32. (lset *early-binding-env* nil)   ; Early binding environment,
  33. (lset *syntax*            nil)   ;    syntax table,
  34. (lset *shape*             nil)   ;        and shape used in compiling a file.
  35.  
  36. ;;; Bind the variables that need to be available throughout the compilation.
  37.  
  38. (define (front-init early-binding-env cont)
  39.   (bind ((*new-env* (make-definition-env early-binding-env '*new-env*))
  40.          (*early-binding-env* early-binding-env))
  41.     (cont)))
  42.  
  43. ;;; Main entry point.
  44.  
  45. (define (make-code-tree+support exp syntax)
  46.   (receive (nodes shape)
  47.            (file-exps->nodes+shape (cddr (caddr exp))
  48.                                    syntax)
  49.     (return (rebuild nodes) shape)))
  50.  
  51.  
  52. ;;;                       Initialization
  53. ;;;===========================================================================
  54.  
  55. (define (information-filename filename)
  56.   (filename-with-type filename *information-file-extension*))
  57.  
  58. ;;; All the primops used by the compiler itself.  These must be in the base
  59. ;;; primop file
  60.  
  61. (lset primop/lap nil)
  62. (lset primop/lap-template nil)
  63. (lset primop/*primop             nil)
  64. (lset primop/undefined           nil)
  65. (lset primop/undefined-effect    nil)
  66. (lset primop/Y                   nil)
  67. (lset primop/conditional         nil)
  68. (lset primop/test                nil)
  69. (lset primop/true?               nil)
  70. (lset primop/*set-var            nil)
  71. (lset primop/*locative           nil)
  72. (lset primop/*define             nil)
  73. (lset primop/*lset               nil)
  74. (lset primop/*define-constant    nil) ; Can be removed after back_end change
  75. (lset primop/proc+handler        nil)
  76. (lset primop/contents-location   nil)
  77. (lset primop/set-location        nil)
  78. (lset primop/make-cell           nil)
  79. (lset primop/cell-value          nil)
  80. (lset primop/single-set-var      nil)
  81. (lset primop/remove-state-object nil)
  82. (lset primop/computed-goto nil)
  83.  
  84. ;;; The names of the above primops together with flags to indicate which ones
  85. ;;; are exported to STANDARD-SUPPORT-ENV.
  86.  
  87. (define known-primops
  88.   '((lap #f)
  89.     (lap-template #f)
  90.     (*primop             #f)
  91.     (undefined           #t)
  92.     (undefined-effect    #t)
  93.     (Y                   #f)
  94.     (conditional         #f)
  95.     (test                #f)
  96.     (true?               #t)
  97.     (*set-var            #f)
  98.     (*locative           #f)
  99.     (*define             #f)
  100.     (*lset               #f)
  101.     (proc+handler        #f)
  102.     (contents-location   #f)
  103.     (set-location        #f)
  104.     (make-cell           #t)
  105.     (cell-value          #t)
  106.     (remove-state-object #f)
  107.     (computed-goto       #f)
  108.     (single-set-var      #f)))
  109.  
  110. ;;; *BASE-SUPPORT-ENV* is the standard support for the system.
  111. ;;; *STANDARD-SUPPORT-ENV* contains the support for the STANDARD-ENV.
  112.  
  113. ;;; Initialize the compiler.  INIT-MODULE contains loadable definitions of the
  114. ;;; base primops.  MODULES are files whose INF files make up the systems
  115. ;;; standard support.
  116.  
  117. (define (orbit-init init-module . modules)
  118.   (orbit-uninit)
  119.   (bind ((*noise-stream* (terminal-output)))
  120.     (load (module-name->filename init-module) orbit-env)
  121.     (walk (lambda (s)
  122.             (let* ((name (car s))
  123.                    (primop (table-entry primop-table name)))
  124.               (if (not primop)
  125.                   (bug '"no early binding for ~S" name))
  126.               (set (*value orbit-env (concatenate-symbol 'primop/ name))
  127.                    primop)
  128.               (if (not (cadr s))
  129.                   (set (initial-primop-env (car s)) nil))))
  130.           known-primops)
  131.     (define base-early-binding-env
  132.       (make-definition-env false 'base-early-binding-env))
  133.     (instantiate-definition-table base-early-binding-env initial-primop-env)
  134.     (walk (lambda (spec)
  135.             (instantiate-definition-table base-early-binding-env
  136.                                           (get-definition-table spec)))
  137.           modules)
  138.     (let ((table (make-definition-env false 'standard-early-binding-env)))
  139.       (walk (lambda (name)
  140.               (if (base-early-binding-env name)
  141.                   (set (table name) (base-early-binding-env name))))
  142.             *t-exports*)
  143.       (define standard-early-binding-env table)
  144.       (*define standard-env 'standard-early-binding-env
  145.                standard-early-binding-env)
  146.       (*define standard-env 'base-early-binding-env
  147.                base-early-binding-env)
  148.       standard-early-binding-env)))
  149.  
  150.  
  151. ;;; Uninitialize the compiler.
  152.  
  153. (define (orbit-uninit)
  154.   (clean-table definition-tables)
  155.   (clean-table constructed-primops) ; Remove pointers to old nodes
  156.   (clean-table primop-table)
  157.   (walk (lambda (s)
  158.           (set (*value orbit-env (concatenate-symbol 'primop/ (car s)))
  159.                '#f))
  160.         known-primops))
  161.  
  162. ;;; Primops are compiled by calling the compiler recursively.  When
  163. ;;; cross-compiling the primops need to be compiled using the running system's
  164. ;;; constants instead of the target system's.  Since the back end and the
  165. ;;; assembler get these constants from ORBIT-ENV the following unpleasantness
  166. ;;; is necessary.
  167.  
  168. (lset *compile-primops?* t)
  169. (lset *cross-compiling?* nil)
  170. (lset *target-system-constants* nil)
  171. (lset *running-system-constants* nil)
  172.  
  173. (define (primop-compile-init running target)
  174.   (let ((target-table (load-system-constants target))
  175.         (running-table (load-system-constants running)))
  176.     (bind (((print-env-warnings?) nil))
  177.       (walk-table (lambda (ident value)
  178.                     (*lset orbit-env ident value))
  179.                   running-table))
  180.     (set *cross-compiling?* t)
  181.     (set *running-system-constants* running-table)
  182.     (set *target-system-constants* target-table)))
  183.  
  184. (define system-constants-env
  185.   (make-locale standard-env 'system-constants-env))
  186.  
  187. (define system-constants-syntax
  188.   (env-syntax-table system-constants-env))
  189.  
  190. (define (install-system-constants table)
  191.   (walk-table (lambda (ident value)
  192.                 (*set-value orbit-env ident value))
  193.               table))
  194.  
  195. ;;; Load a file using a bogus macro expansion for DEFINE and friends to create
  196. ;;; a table of the files definitions.
  197.  
  198. (define (load-system-constants file)
  199.   (bind (((print-env-warnings?) nil))
  200.     (let* ((table (make-table file))
  201.            (filename (filename-with-type (->filename file) 't))
  202.            (syntax (make-bogus-define table)))
  203.       (set (syntax-table-entry system-constants-syntax 'define)
  204.            syntax)
  205.       (set (syntax-table-entry system-constants-syntax 'define-constant)
  206.            syntax)
  207.       (set (syntax-table-entry system-constants-syntax 'define-integrable)
  208.            syntax)
  209.       (load-quietly filename system-constants-env)
  210.       table)))
  211.  
  212. (define (make-bogus-define table)
  213.   (macro-expander (bogus-define ident value)
  214.     (set (table-entry table ident) value)
  215.     ''#f))
  216.  
  217.  
  218.  
  219.  
  220.  
  221.