[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: Re: A suggestion about the T compiler
I have gotten so many requests for the load hacque that I've decided to post
it to t-discussion. Here it comes, along with the original copyright message
of the T3 distribution. Cut where indicated and compile the file, then load
it first thing in your init.t file as described below. Enjoy!
----------------------------------------cut here------------------------------------------------
(herald load (env tsys)
(syntax-table (env-syntax-table t-implementation-env)))
;;**********************************************************************************************
;;
;; LOAD.T
;;
;;**********************************************************************************************
;; File: [yale-ring]~/sys/homes/ram/t3/load.t
;; Author: Ashwin Ram <Ram@yale>
;; Written: 02/26/87
;; CONTENTS:
;; ---------
;; Fix bug in *REQUIRE (actually, LOADED?).
;; Fix bug in LOAD (actually, OPEN-DEFAULT-FILENAME).
;; Abstract LOAD-OUT-OF-DATE-ACTION checking and add to both REQUIRE and LOAD.
;; HOW TO USE:
;; -----------
;; This file must be loaded into T-IMPLEMENTATION-ENV,
;; after which you should import *REQUIRE (and LOAD-OUT-OF-DATE-ACTION if
;; you want it) into your own environment.
;;
;; I have the following lines at the beginning of my INIT.T file:
;;
;; (load '(sys/homes/ram/t3 load) t-implementation-env) ;; Load this file.
;; (import t-implementation-env *require load-out-of-date-action)
;; (set (load-out-of-date-action) 'recompile)
;;
;; The options for load-out-of-date-action are as follows. Assume you have typed
;; (load 'foo) or (require foo), and foo.t and foo.mobj both exist.
;;
;; binary - always load foo.mobj (this is T's normal default)
;; source - always load foo.t
;; newer - always load whichever is newer
;; recompile - recompile foo.t, then load foo.mobj if successful
;; query - ask user whether to recompile
;; warn - print warning message, then load foo.mobj
;;
;; To select the option you want, type: (set (load-out-of-date-action) 'xxxxxx)
;;**********************************************************************************************
;;; Copyright (c) 1985 Yale University
;;; Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
;;; This material was developed by the T Project at the Yale University Computer
;;; Science Department. Permission to copy this software, to redistribute it,
;;; and to use it for any purpose is granted, subject to the following restric-
;;; tions 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 T Project at Yale any improvements or extensions that they make,
;;; so that these may be included in future releases; and (b) to inform
;;; the T Project 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. Yale has made no warrantee or representation that the operation of
;;; this software will be error-free, and Yale 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 Yale University nor of any
;;; adaptation thereof in any advertising, promotional, or sales literature
;;; without prior written consent from Yale in each case.
;;;
;;; Modications by Ashwin Ram, 02/26/87.
;;**********************************************************************************************
;; Fix bug in loaded?.
;;**********************************************************************************************
;; Files are entered in the loaded-files table after expanding to full path
;; names, so loaded? better expand filenames before looking in that table.
;; From ~/TSYS/LOAD.T (changes in uppercase):
(define (loaded? name env)
(let ((id (cond ((string? name) name)
((filename? name) (filename->string name))
((port? name) (port-name name))
(else
(error "invalid identifier for file - ~a" name)))))
(true? (loaded-file env (FILENAME->STRING (EXPAND-FILENAME (->FILENAME id)))))))
;;**********************************************************************************************
;; From ~/TSYS/LOAD.T (changes in uppercase):
(define (instantiate-comex comex env . id)
(let* ((id (if (null? id) nil (car id)))
(h (vref (comex-objects comex) 1))
(herald (parse-herald (car h) (cdr h))))
(set (comex-module-name comex) herald)
(receive (unit code) (install-comex comex env)
(set (weak-table-entry code-unit-table code) unit)
(add-to-population code-population code)
(if id (set (loaded-file env id) (AUGMENT-UNIT unit ID)))
(run-compiled-code unit env))))
(define (instantiate-source port form env)
(receive (h port)
(cond ((and (pair? form) (eq? (car form) 'herald))
(let ((h (parse-herald (cadr form) (cddr form))))
(cond ((herald-read-table h)
=> (lambda (rt)
(set (port-read-table port)
(eval rt env)))))
(return h port)))
(else
;++(warning "file ~S has no HERALD form.~%"
;++ (port-name port))
(return (make-default-herald (port-name port))
(cons-port form port))))
(check-compatibility port h env)
(let ((unit (standard-compile-port port (get-target-syntax h env) h)))
(if (port-name port) (set (loaded-file env (port-name port)) (AUGMENT-UNIT unit (PORT-NAME PORT))))
(run-compiled-code unit env))))
;;**********************************************************************************************
;; Fix bug in open-default-filename.
;;**********************************************************************************************
;; From ~/TSYS/LOAD.T (changes in uppercase):
(define (open-default-filename filespec complain?)
(let ((open (if complain? open maybe-open))
(fname (GET-DEFAULT-FILENAME filespec)))
(OPEN FNAME 'IN)))
;;**********************************************************************************************
;; Abstract the load-out-of-date-action feature.
;;**********************************************************************************************
;; This code is new.
(define (get-default-filename filespec)
(let* ((fname (->filename filespec))
(ftype (filename-type fname))
(src (filename-with-type fname (source-file-type (local-machine))))
(bin (filename-with-type fname (object-file-type (local-machine)))))
(cond ((or (string? filespec) (not (null? ftype)))
fname)
((file-exists? bin)
(xcase (load-out-of-date-action)
((binary) bin)
((source) src)
((newer) (if (and (file-exists? src) (file-newer? src bin))
src
bin))
((recompile) (if (and (file-exists? src) (file-newer? src bin))
(if (maybe-comfile src bin) bin src)
bin))
((warn) (if (and (file-exists? src) (file-newer? src bin))
(if (print-load-message?)
(let ((msg-port (standard-output)))
(comment-indent msg-port (fx* *load-level* 2))
(format msg-port "Warning: ~a has changed since it was last compiled~%" src)
(force-output msg-port))))
bin)
((query) (if (and (file-exists? src) (file-newer? src bin)
(yes-or-no? "File ~a is out of date. Recompile " src))
(if (maybe-comfile src bin) bin src)
bin))))
(else src))))
;; Like COMFILE but doesn't break if can't compile (say, it isn't your file).
;; If can't compile, behaves like NEWER which is presumably what you wanted.
(define (maybe-comfile src bin)
(cond ((maybe-open bin '(out)) ;; hack!
=> (lambda (port)
(close port)
(comfile src)
'#t))
(else (if (print-load-message?)
(let ((msg-port (standard-output)))
(comment-indent msg-port (fx* *load-level* 2))
(format msg-port "Can't compile ~a~%" (filename->string src))
(force-output msg-port)))
'#f)))
;;**********************************************************************************************
;; Add newer and warn options.
;;**********************************************************************************************
;; From ~/TSYS/LOAD.T (changes in uppercase):
(define-simple-switch load-out-of-date-action
(lambda (sym)
(case sym
((binary) t)
((source) t)
((query) t)
((recompile) t)
((WARN) T)
((NEWER) T)
(else nil)))
'binary)
;;**********************************************************************************************
;; Add load-out-of-date-action feature to require.
;;**********************************************************************************************
;; From ~/TSYS/LOAD.T (changes in uppercase):
(define (*require id filespec env)
(let ((fname (EXPAND-FILENAME (GET-DEFAULT-FILENAME filespec))))
(cond ((AND (loaded? fname env)
(SAME-AS-BEFORE? FNAME ENV))
(cond ((print-load-message?)
(let ((msg-port (standard-output)))
(comment-indent msg-port (fx* *load-level* 2))
(format msg-port "Already loaded ~a~%" (FILENAME->STRING fname))
(force-output msg-port))))
(undefined-value "File already loaded"))
(else
(load-file (FILENAME->STRING fname) env t))))) ;; Why do GET-DEFAULT again?
;;**********************************************************************************************
;; New stuff to check write dates.
;;**********************************************************************************************
;; The right way to do LOADED? is to check both the name of the file as well as the file write
;; date, since if the file has changed since it was loaded, we shouldn't really consider it
;; loaded any more. On systems supporting version or generation numbers, we can just check
;; that instead. For example, if *require causes an already-loaded file to be recompiled,
;; it really should reload that file.
;; Here's one way to fix it that will be relatively painless to get rid of once the T guys
;; fix it for real. This code is new and hopefully temporary:
(define-operation (unit-write-date unit)
*min-fixnum*)
(define (augment-unit unit id)
(let ((write-date (if (null? id) *min-fixnum* (file-write-date id))))
(join (object nil ((unit-write-date self) write-date))
unit)))
;; This code duplicates some of LOADED?, but rather than hack LOADED? I separated this out
;; since I don't know what else depends on LOADED?.
(define (same-as-before? name env)
(let* ((fname (expand-filename
(->filename
(cond ((string? name) name)
((filename? name) (filename->string name))
((port? name) (port-name name))
(else
(error "invalid identifier for file - ~a" name))))))
(id (filename->string fname))
(unit (loaded-file env id)))
(cond ((fx> (file-write-date fname) (unit-write-date unit))
(cond ((print-load-message?)
(let ((msg-port (standard-output)))
(comment-indent msg-port (fx* *load-level* 2))
(format msg-port "~a has changed since it was loaded~%" id)
(force-output msg-port))))
'#f)
(else '#t))))
;;**********************************************************************************************
'LOAD
----------------------------------------cut here------------------------------------------------
Let me know if you have any trouble setting it up. Comments, suggestions and
improvements are welcome too.
-- Ashwin Ram --
ARPA: Ram-Ashwin@cs.yale.edu
UUCP: {decvax,linus,seismo}!yale!Ram-Ashwin
BITNET: Ram@yalecs