home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / front_end / front.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  8.8 KB  |  247 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. (define (orbit-vax-init . directory)
  59.   (orbit-vax-setup (if directory (car directory) '#f))
  60.   (orbit-init 'base
  61.               'constants
  62.               'primops
  63.               'arith
  64.               'locations
  65.               'low
  66.               'predicates
  67.               'open
  68.               'aliases
  69.               'carcdr
  70.           'genarith))
  71.  
  72. (define (orbit-m68-init . directory)
  73.   (orbit-m68-setup (if directory (car directory) '#f))
  74.   (orbit-init 'base
  75.               'constants
  76.               'primops
  77.               'arith
  78.               'locations
  79.               'low
  80.               'predicates
  81.               'open
  82.               'aliases
  83.               'carcdr
  84.           'genarith))
  85.  
  86. ;;; All the primops used by the compiler itself.  These must be in the base
  87. ;;; primop file
  88.  
  89. (lset primop/lap nil)
  90. (lset primop/lap-template nil)
  91. (lset primop/*primop             nil)
  92. (lset primop/undefined           nil)
  93. (lset primop/undefined-effect    nil)
  94. (lset primop/Y                   nil)
  95. (lset primop/conditional         nil)
  96. (lset primop/test                nil)
  97. (lset primop/true?               nil)
  98. (lset primop/*set-var            nil)
  99. (lset primop/*locative           nil)
  100. (lset primop/*define             nil)
  101. (lset primop/*lset               nil)
  102. (lset primop/*define-constant    nil) ; Can be removed after back_end change
  103. (lset primop/proc+handler        nil)
  104. (lset primop/contents-location   nil)
  105. (lset primop/set-location        nil)
  106. (lset primop/make-cell           nil)
  107. (lset primop/cell-value          nil)
  108. (lset primop/single-set-var      nil)
  109. (lset primop/remove-state-object nil)
  110.  
  111. ;;; The names of the above primops together with flags to indicate which ones
  112. ;;; are exported to STANDARD-SUPPORT-ENV.
  113.  
  114. (define known-primops
  115.   '((lap #f)
  116.     (lap-template #f)
  117.     (*primop             #f)
  118.     (undefined           #t)
  119.     (undefined-effect    #t)
  120.     (Y                   #f)
  121.     (conditional         #f)
  122.     (test                #f)
  123.     (true?               #t)
  124.     (*set-var            #f)
  125.     (*locative           #f)
  126.     (*define             #f)
  127.     (*lset               #f)
  128.     (proc+handler        #f)
  129.     (contents-location   #f)
  130.     (set-location        #f)
  131.     (make-cell           #t)
  132.     (cell-value          #t)
  133.     (remove-state-object #f)
  134.     (single-set-var      #f)))
  135.  
  136. ;;; *BASE-SUPPORT-ENV* is the standard support for the system.
  137. ;;; *STANDARD-SUPPORT-ENV* contains the support for the STANDARD-ENV.
  138.  
  139. ;;; Initialize the compiler.  INIT-MODULE contains loadable definitions of the
  140. ;;; base primops.  MODULES are files whose INF files make up the systems
  141. ;;; standard support.
  142.  
  143. (define (orbit-init init-module . modules)
  144.   (orbit-uninit)
  145.   (bind ((*noise-stream* (terminal-output)))
  146.     (load (module-name->filename init-module) orbit-env)
  147.     (walk (lambda (s)
  148.             (let* ((name (car s))
  149.                    (primop (table-entry primop-table name)))
  150.               (if (not primop)
  151.                   (bug '"no early binding for ~S" name))
  152.               (set (*value orbit-env (concatenate-symbol 'primop/ name))
  153.                    primop)
  154.               (if (not (cadr s))
  155.                   (set (initial-primop-env (car s)) nil))))
  156.           known-primops)
  157.     (define base-early-binding-env
  158.       (make-definition-env false 'base-early-binding-env))
  159.     (instantiate-definition-table base-early-binding-env initial-primop-env)
  160.     (walk (lambda (spec)
  161.             (instantiate-definition-table base-early-binding-env
  162.                                           (get-definition-table spec)))
  163.           modules)
  164.     (let ((table (make-definition-env false 'standard-early-binding-env)))
  165.       (walk (lambda (name)
  166.               (if (base-early-binding-env name)
  167.                   (set (table name) (base-early-binding-env name))))
  168.             *t-exports*)
  169.       (define standard-early-binding-env table)
  170.       (*define standard-env 'standard-early-binding-env
  171.                standard-early-binding-env)
  172.       (*define standard-env 'base-early-binding-env
  173.                base-early-binding-env)
  174.       standard-early-binding-env)))
  175.  
  176.  
  177. ;;; Uninitialize the compiler.
  178.  
  179. (define (orbit-uninit)
  180.   (clean-table definition-tables)
  181.   (clean-table constructed-primops) ; Remove pointers to old nodes
  182.   (clean-table primop-table)
  183.   (walk (lambda (s)
  184.           (set (*value orbit-env (concatenate-symbol 'primop/ (car s)))
  185.                '#f))
  186.         known-primops))
  187.  
  188. ;;; Primops are compiled by calling the compiler recursively.  When
  189. ;;; cross-compiling the primops need to be compiled using the running system's
  190. ;;; constants instead of the target system's.  Since the back end and the
  191. ;;; assembler get these constants from ORBIT-ENV the following unpleasantness
  192. ;;; is necessary.
  193.  
  194. (lset *compile-primops?* t)
  195. (lset *cross-compiling?* nil)
  196. (lset *target-system-constants* nil)
  197. (lset *running-system-constants* nil)
  198.  
  199. (define (primop-compile-init running target)
  200.   (let ((target-table (load-system-constants target))
  201.         (running-table (load-system-constants running)))
  202.     (bind (((print-env-warnings?) nil))
  203.       (walk-table (lambda (ident value)
  204.                     (*lset orbit-env ident value))
  205.                   running-table))
  206.     (set *cross-compiling?* t)
  207.     (set *running-system-constants* running-table)
  208.     (set *target-system-constants* target-table)))
  209.  
  210. (define system-constants-env
  211.   (make-locale standard-env 'system-constants-env))
  212.  
  213. (define system-constants-syntax
  214.   (env-syntax-table system-constants-env))
  215.  
  216. (define (install-system-constants table)
  217.   (walk-table (lambda (ident value)
  218.                 (*set-value orbit-env ident value))
  219.               table))
  220.  
  221. ;;; Load a file using a bogus macro expansion for DEFINE and friends to create
  222. ;;; a table of the files definitions.
  223.  
  224. (define (load-system-constants file)
  225.   (bind (((print-env-warnings?) nil))
  226.     (let* ((table (make-table file))
  227.            (filename (filename-with-type (->filename file) 't))
  228.            (syntax (make-bogus-define table)))
  229.       (set (syntax-table-entry system-constants-syntax 'define)
  230.            syntax)
  231.       (set (syntax-table-entry system-constants-syntax 'define-constant)
  232.            syntax)
  233.       (set (syntax-table-entry system-constants-syntax 'define-integrable)
  234.            syntax)
  235.       (load-quietly filename system-constants-env)
  236.       table)))
  237.  
  238. (define (make-bogus-define table)
  239.   (macro-expander (bogus-define ident value)
  240.     (set (table-entry table ident) value)
  241.     ''#f))
  242.  
  243.  
  244.  
  245.  
  246.  
  247.