From 1dfcd0ed5fc81f4355101c1eeb990a1f7d089e40 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 25 Apr 2002 20:59:44 +0000 Subject: [PATCH] 0.7.3.2: (slightly dangerous, as WHN committed while I was building, but these fixes have been in my tree for a while, anyway) More clisp bootstrapping fixes: ... define FASL-WRITE-STRING to write fasl headers, and use it ... don't pass :start arguments that are greater than the length of the sequence ... make set-functions to pass around for structure setters, rather than #'(setf slot) ... move compiler/generic/vm-tran.lisp later in the build order --- build-order.lisp-expr | 10 ++++++---- src/compiler/dump.lisp | 39 ++++++++++++++++++++++++++------------- src/compiler/main.lisp | 6 +++++- src/compiler/tn.lisp | 30 ++++++++++++++++++++++++------ version.lisp-expr | 2 +- 5 files changed, 62 insertions(+), 25 deletions(-) diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 8c77713..9ff03fd 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -455,10 +455,6 @@ ("src/compiler/ir1report") ("src/compiler/ir1opt") - ;; Compiling this file requires the macros SB!ASSEM:EMIT-LABEL and - ;; SB!ASSEM:EMIT-POST-IT, defined in assem.lisp. - ("src/compiler/late-vmdef") - ("src/compiler/ir1final") ("src/compiler/array-tran") ("src/compiler/seqtran") @@ -482,6 +478,12 @@ ("src/compiler/generic/utils") ("src/assembly/assemfile") + ;; Compiling this file requires the macros SB!ASSEM:EMIT-LABEL and + ;; SB!ASSEM:EMIT-POST-IT, defined in assem.lisp, and also possibly + ;; the definition of the LOCATION-INFO structure (if structures in + ;; the host lisp have setf expanders rather than setf functions). + ("src/compiler/late-vmdef") + ("src/compiler/fixup") ; for DEFSTRUCT FIXUP, used by insts.lisp ("src/compiler/target/insts") diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index 82469dd..094f646 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -246,6 +246,17 @@ ;;;; opening and closing fasl files +;;; A utility function to write strings to (unsigned-byte 8) streams. +;;; We restrict this to ASCII (with the averrance) because of +;;; ambiguity of higher bytes: Unicode, some ISO-8859-x, or what? This +;;; could be revisited in the event of doing funky things with stream +;;; encodings -- CSR, 2002-04-25 +(defun fasl-write-string (string stream) + (loop for char across string + do (let ((code (char-code char))) + (aver (<= 0 code 127)) + (write-byte code stream)))) + ;;; Open a fasl file, write its header, and return a FASL-OUTPUT ;;; object for dumping to it. Some human-readable information about ;;; the source code is given by the string WHERE. If BYTE-P is true, @@ -261,23 +272,25 @@ ;; Begin the header with the constant machine-readable (and ;; semi-human-readable) string which is used to identify fasl files. - (write-string *fasl-header-string-start-string* stream) + (fasl-write-string *fasl-header-string-start-string* stream) ;; The constant string which begins the header is followed by ;; arbitrary human-readable text, terminated by a special ;; character code. - (with-standard-io-syntax - (format stream - "~% ~ - compiled from ~S~% ~ - at ~A~% ~ - on ~A~% ~ - using ~A version ~A~%" - where - (format-universal-time nil (get-universal-time)) - (machine-instance) - (sb!xc:lisp-implementation-type) - (sb!xc:lisp-implementation-version))) + (fasl-write-string + (with-standard-io-syntax + (format nil + "~% ~ + compiled from ~S~% ~ + at ~A~% ~ + on ~A~% ~ + using ~A version ~A~%" + where + (format-universal-time nil (get-universal-time)) + (machine-instance) + (sb!xc:lisp-implementation-type) + (sb!xc:lisp-implementation-version))) + stream) (dump-byte +fasl-header-string-stop-char-code+ res) ;; Finish the header by outputting fasl file implementation and diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index b5ad7f1..c44d601 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -1225,7 +1225,11 @@ (node-component (lambda-bind x))) :toplevel))) lambdas - :start start) + ;; this used to read ":start start", but + ;; start can be greater than len, which + ;; is an error according to ANSI - CSR, + ;; 2002-04-25 + :start (min start len)) len))) (do* ((start 0 (1+ loser)) (loser (loser start) (loser start))) diff --git a/src/compiler/tn.lisp b/src/compiler/tn.lisp index e0b6a26..8ec5260 100644 --- a/src/compiler/tn.lisp +++ b/src/compiler/tn.lisp @@ -33,6 +33,24 @@ ,result) ,@body)))) +(defun set-ir2-physenv-live-tns (value instance) + (setf (ir2-physenv-live-tns instance) value)) + +(defun set-ir2-physenv-debug-live-tns (value instance) + (setf (ir2-physenv-debug-live-tns instance) value)) + +(defun set-ir2-component-alias-tns (value instance) + (setf (ir2-component-alias-tns instance) value)) + +(defun set-ir2-component-normal-tns (value instance) + (setf (ir2-component-normal-tns instance) value)) + +(defun set-ir2-component-restricted-tns (value instance) + (setf (ir2-component-restricted-tns instance) value)) + +(defun set-ir2-component-wired-tns (value instance) + (setf (ir2-component-wired-tns instance) value)) + ;;; Remove all TNs with no references from the lists of unpacked TNs. ;;; We null out the Offset so that nobody will mistake deleted wired ;;; TNs for properly packed TNs. We mark non-deleted alias TNs so that @@ -65,26 +83,26 @@ (:environment (clear-live tn #'ir2-physenv-live-tns - #'(setf ir2-physenv-live-tns))) + #'set-ir2-physenv-live-tns)) (:debug-environment (clear-live tn #'ir2-physenv-debug-live-tns - #'(setf ir2-physenv-debug-live-tns))))) + #'set-ir2-physenv-debug-live-tns)))) (clear-live (tn getter setter) (let ((env (physenv-info (tn-physenv tn)))) (funcall setter (delete tn (funcall getter env)) env)))) (declare (inline used-p delete-some delete-1 clear-live)) (delete-some #'ir2-component-alias-tns - #'(setf ir2-component-alias-tns)) + #'set-ir2-component-alias-tns) (do ((tn (ir2-component-alias-tns 2comp) (tn-next tn))) ((null tn)) (setf (sbit aliases (tn-number (tn-save-tn tn))) 1)) (delete-some #'ir2-component-normal-tns - #'(setf ir2-component-normal-tns)) + #'set-ir2-component-normal-tns) (delete-some #'ir2-component-restricted-tns - #'(setf ir2-component-restricted-tns)) + #'set-ir2-component-restricted-tns) (delete-some #'ir2-component-wired-tns - #'(setf ir2-component-wired-tns)))) + #'set-ir2-component-wired-tns))) (values)) ;;;; TN creation diff --git a/version.lisp-expr b/version.lisp-expr index 3e931c3..349c76a 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.3.1" +"0.7.3.2" -- 1.7.10.4