Skip to content
Snippets Groups Projects
Commit 4c143708 authored by wlott's avatar wlott
Browse files

Changed load to check the first line of files for ``FASL FILE'' instead of

assuming that everyone is going to use the same pathname type that we use.
Also, when the given filename doesn't exist and doesn't have a type, try
``fasl'' in addition to the machine specific fasl file type.

Also added a *load-depth* special that load maintains as the number of
times load recurses.  The various people who print semicolons at the
beginning of the line now print this many semicolons instead of always
printing one.
parent ab5b571d
No related branches found
No related tags found
No related merge requests found
...@@ -7,11 +7,11 @@ ...@@ -7,11 +7,11 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/load.lisp,v 1.28 1991/03/23 17:38:18 wlott Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/load.lisp,v 1.29 1991/04/06 12:10:07 wlott Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/load.lisp,v 1.28 1991/03/23 17:38:18 wlott Exp $ ;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/load.lisp,v 1.29 1991/04/06 12:10:07 wlott Exp $
;;; ;;;
;;; Loader for Spice Lisp. ;;; Loader for Spice Lisp.
;;; Written by Skef Wholey and Rob MacLachlan. ;;; Written by Skef Wholey and Rob MacLachlan.
...@@ -31,6 +31,8 @@ ...@@ -31,6 +31,8 @@
"The default for the :Verbose argument to Load.") "The default for the :Verbose argument to Load.")
(defvar *load-print-stuff* () (defvar *load-print-stuff* ()
"True if we're gonna mumble about what we're loading.") "True if we're gonna mumble about what we're loading.")
(defvar *load-depth* 0
"Count of the number of recursive loads.")
(defvar *fasl-file* () (defvar *fasl-file* ()
"The fasl file we're reading from.") "The fasl file we're reading from.")
(defvar *current-code-format* (defvar *current-code-format*
...@@ -43,6 +45,21 @@ ...@@ -43,6 +45,21 @@
file, :compile - compile the source and then load the object file, or file, :compile - compile the source and then load the object file, or
:query - ask the user if he wants to load the source or object file.") :query - ask the user if he wants to load the source or object file.")
;;; LOAD-FRESH-LINE -- internal.
;;;
;;; Output the corrent number of semicolons after a fresh-line.
;;;
(defconstant semicolons ";;;;;;;;;;;;;;;;")
;;;
(defun load-fresh-line ()
(fresh-line)
(do ((count *load-depth* (- count (length semicolons))))
((< count (length semicolons))
(unless (zerop count)
(write-string semicolons *standard-output* :end count)))
(write-string semicolons))
(write-char #\space))
;;;; The Fop-Table: ;;;; The Fop-Table:
;;; ;;;
...@@ -246,7 +263,8 @@ ...@@ -246,7 +263,8 @@
(unless (listen stream) (unless (listen stream)
(error "Attempt to load an empty FASL FILE:~% ~S" stream)) (error "Attempt to load an empty FASL FILE:~% ~S" stream))
(when *load-verbose* (when *load-verbose*
(format t "~&; Loading stuff from ~S.~%" stream)) (load-fresh-line)
(format t "Loading stuff from ~S.~%" stream))
(let* ((*fasl-file* stream) (let* ((*fasl-file* stream)
(*current-fop-table* (pop *free-fop-tables*)) (*current-fop-table* (pop *free-fop-tables*))
(*current-fop-table-size* ()) (*current-fop-table-size* ())
...@@ -366,6 +384,7 @@ ...@@ -366,6 +384,7 @@
(- result (ash 1 bits)) (- result (ash 1 bits))
result)) result))
(declare (fixnum index byte bits)))) (declare (fixnum index byte bits))))
;;; Sloload: ;;; Sloload:
...@@ -377,87 +396,107 @@ ...@@ -377,87 +396,107 @@
(defun sloload (stream) (defun sloload (stream)
(when *load-verbose* (when *load-verbose*
(format t "~&; Loading stuff from ~S.~%" stream)) (load-fresh-line)
(format t "Loading stuff from ~S.~%" stream))
(do ((sexpr (read stream nil load-eof-value) (do ((sexpr (read stream nil load-eof-value)
(read stream nil load-eof-value))) (read stream nil load-eof-value)))
((eq sexpr load-eof-value)) ((eq sexpr load-eof-value))
(if *load-print-stuff* (if *load-print-stuff*
(format t "~&; ~S~%" (eval sexpr)) (let ((results (multiple-value-list (eval sexpr))))
(eval sexpr)))))) (load-fresh-line)
(format t "~{~S~^, ~}~%" results))
(eval sexpr)))
t)
;;; Load: ;;; Load:
(defun load (filename &key ((:verbose *load-verbose*) *load-verbose*) (defun load (filename &key ((:verbose *load-verbose*) *load-verbose*)
((:print *load-print-stuff*) *load-print-stuff*) ((:print *load-print-stuff*) *load-print-stuff*)
(if-does-not-exist :error)) (if-does-not-exist :error) contents)
"Loads the file named by Filename into the Lisp environment. See manual "Loads the file named by Filename into the Lisp environment. See manual
for details." for details."
(let ((*package* *package*)) (declare (type (or null (member :source :binary)) contents))
(let ((*package* *package*)
(*load-depth* (1+ *load-depth*)))
(if (streamp filename) (if (streamp filename)
(if (equal (stream-element-type filename) '(unsigned-byte 8)) (if (or (eq contents :binary)
(and (null contents)
(equal (stream-element-type filename)
'(unsigned-byte 8))))
(fasload filename) (fasload filename)
(sloload filename)) (sloload filename))
(let* ((pn (merge-pathnames (pathname filename) (let ((pn (merge-pathnames (pathname filename)
*default-pathname-defaults*)) *default-pathname-defaults*)))
(tn (probe-file pn))) (internal-load pn (probe-file pn) if-does-not-exist contents)))))
(cond
(tn (defun internal-load (pathname truename if-does-not-exist contents)
(if (string-equal (pathname-type tn) (cond
#.(c:backend-fasl-file-type c:*backend*)) (truename
(with-open-file (file tn (case contents
:direction :input (:source
:element-type '(unsigned-byte 8)) (with-open-file (file truename :direction :input)
(fasload file)) (sloload file)))
(with-open-file (file tn :direction :input) (:binary
(sloload file))) (with-open-file (file truename
t) :direction :input
((pathname-type pn) :element-type '(unsigned-byte 8))
(let ((stream (open pn :direction :input (fasload file)))
:if-does-not-exist if-does-not-exist))) (t
(when stream (let ((first-line (with-open-file (file truename :direction :input)
(sloload stream) (read-line file nil))))
(close stream) (if (and first-line
t))) (>= (length first-line) 9)
(t (string= first-line "FASL FILE" :end1 9))
(let* ((srcn (make-pathname :type "lisp" :defaults pn)) (internal-load pathname truename if-does-not-exist :binary)
(src (probe-file srcn)) (internal-load pathname truename if-does-not-exist :source))))))
(objn (make-pathname :type ((pathname-type pathname)
#.(c:backend-fasl-file-type c:*backend*) (with-open-file (stream pathname :direction :input
:defaults pn)) :if-does-not-exist if-does-not-exist)
(obj (probe-file objn))) (sloload stream)))
(cond (t
(obj (let* ((srcn (make-pathname :type "lisp" :defaults pathname))
(cond ((and src (> (file-write-date src) (src (probe-file srcn))
(file-write-date obj))) (obj (or (probe-file (make-pathname
(case *load-if-source-newer* :type #.(c:backend-fasl-file-type c:*backend*)
(:load-object :defaults pathname))
(warn "Loading object file ~A, which is~% ~ (probe-file (make-pathname :type "fasl"
older than the presumed source, ~A." :defaults pathname)))))
(namestring obj) (cond
(namestring src)) (obj
(load obj)) (cond
(:load-source ((and src (> (file-write-date src) (file-write-date obj)))
(warn "Loading source file ~A, which is~% ~ (case *load-if-source-newer*
newer than the presumed object file, ~A." (:load-object
(namestring src) (warn "Loading object file ~A, which is~% ~
(namestring obj)) older than the presumed source:~% ~A."
(load src)) (namestring obj)
(:compile (namestring src))
(compile-file (namestring src)) (internal-load obj obj if-does-not-exist :binary))
(load obj)) (:load-source
(:query (warn "Loading source file ~A, which is~% ~
(if (y-or-n-p "Load source file ~A which is newer~% ~ newer than the presumed object file, ~A."
than presumed object file ~A? " (namestring src)
(namestring src) (namestring obj))
(namestring obj)) (internal-load obj obj if-does-not-exist :source))
(load src) (:compile
(load obj))) (compile-file (namestring src) :output-file obj)
(T (error "*Load-if-source-newer* contains ~A which is not one of:~% ~ (internal-load obj obj if-does-not-exist :binary))
:load-object, :load-source, :compile, or :query." (:query
*load-if-source-newer*)))) (if (y-or-n-p "Load source file ~A which is newer~% ~
(T (load obj)))) than presumed object file ~A? "
(t (namestring src)
(load srcn :if-does-not-exist if-does-not-exist)))))))))) (namestring obj))
(internal-load obj obj if-does-not-exist :source)
(internal-load obj obj if-does-not-exist :binary)))
(T
(error
"*Load-if-source-newer* contains ~A which is not one of:~% ~
:load-object, :load-source, :compile, or :query."
*load-if-source-newer*))))
(t
(internal-load obj obj if-does-not-exist :binary))))
(t
(internal-load srcn srcn if-does-not-exist :source)))))))
;;;; Actual FOP definitions: ;;;; Actual FOP definitions:
...@@ -700,13 +739,17 @@ ...@@ -700,13 +739,17 @@
(define-fop (fop-eval 53) (define-fop (fop-eval 53)
(let ((result (eval (pop-stack)))) (let ((result (eval (pop-stack))))
(when *load-print-stuff* (when *load-print-stuff*
(format t "~&; ~S~%" result)) (load-fresh-line)
(prin1 result)
(terpri))
result)) result))
(define-fop (fop-eval-for-effect 54 nil) (define-fop (fop-eval-for-effect 54 nil)
(let ((result (eval (pop-stack)))) (let ((result (eval (pop-stack))))
(when *load-print-stuff* (when *load-print-stuff*
(format t "~&; ~S~%" result)))) (load-fresh-line)
(prin1 result)
(terpri))))
(define-fop (fop-funcall 55) (define-fop (fop-funcall 55)
(let ((arg (read-arg 1))) (let ((arg (read-arg 1)))
...@@ -836,7 +879,8 @@ ...@@ -836,7 +879,8 @@
(%primitive set-function-arglist fun arglist) (%primitive set-function-arglist fun arglist)
(%primitive set-function-type fun type) (%primitive set-function-type fun type)
(when *load-print-stuff* (when *load-print-stuff*
(format t "~&; ~S defined" fun)) (load-fresh-line)
(format t "~S defined~%" fun))
fun))) fun)))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment