From d3862cc781cabf52f15c2d3a164f992dbbba84f4 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Mon, 20 Aug 2001 19:56:23 +0000 Subject: [PATCH] 0.pre7.14.flaky4.3: (This version builds under sbcl-0.6.12.1, but can't build itself, dying in cross-compilation of string.lisp.) added missing space in NEXT-BYTE in DISASSEM-BYTE-SAP removed bogus DECLAIM (TYPE SYMBOL *SHEBANG-FEATURES*) reenabled COMPILE 'IN-HOST-COMPILATION-MODE --- src/code/list.lisp | 55 +++++++++++++-------------- src/code/seq.lisp | 4 +- src/cold/defun-load-or-cload-xcompiler.lisp | 8 ---- src/cold/shared.lisp | 24 +++++------- src/cold/shebang.lisp | 2 +- src/compiler/target-byte-comp.lisp | 2 +- src/compiler/target-main.lisp | 2 - version.lisp-expr | 2 +- 8 files changed, 42 insertions(+), 57 deletions(-) diff --git a/src/code/list.lisp b/src/code/list.lisp index 4dea431..4f78953 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -673,7 +673,7 @@ (defun member (item list &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc "Returns tail of list beginning with first element satisfying EQLity, - :test, or :test-not with a given item." + :TEST, or :TEST-NOT with a given item." (do ((list list (cdr list))) ((null list) nil) (let ((car (car list))) @@ -682,7 +682,7 @@ (defun member-if (test list &key key) #!+sb-doc - "Returns tail of list beginning with first element satisfying test(element)" + "Return tail of LIST beginning with first element satisfying TEST." (do ((list list (Cdr list))) ((endp list) nil) (if (funcall test (apply-key key (car list))) @@ -690,7 +690,7 @@ (defun member-if-not (test list &key key) #!+sb-doc - "Returns tail of list beginning with first element not satisfying test(el)" + "Return tail of LIST beginning with first element not satisfying TEST." (do ((list list (cdr list))) ((endp list) ()) (if (not (funcall test (apply-key key (car list)))) @@ -698,8 +698,8 @@ (defun tailp (object list) #!+sb-doc - "Returns true if Object is the same as some tail of List, otherwise - returns false. List must be a proper list or a dotted list." + "Return true if OBJECT is the same as some tail of LIST, otherwise + returns false. LIST must be a proper list or a dotted list." (do ((list list (cdr list))) ((atom list) (eql list object)) (if (eql object list) @@ -707,7 +707,7 @@ (defun adjoin (item list &key key (test #'eql) (test-not nil notp)) #!+sb-doc - "Add item to list unless it is already a member" + "Add ITEM to LIST unless it is already a member" (declare (inline member)) (if (let ((key-val (apply-key key item))) (if notp @@ -722,7 +722,7 @@ ;;; order. (defun union (list1 list2 &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc - "Returns the union of list1 and list2." + "Return the union of LIST1 and LIST2." (declare (inline member)) (when (and testp notp) (error "Test and test-not both supplied.")) (let ((res list2)) @@ -731,8 +731,8 @@ (push elt res))) res)) -;;; Destination and source are setf-able and many-evaluable. Sets the source -;;; to the cdr, and "conses" the 1st elt of source to destination. +;;; Destination and source are SETF-able and many-evaluable. Set the +;;; SOURCE to the CDR, and "cons" the 1st elt of source to DESTINATION. ;;; ;;; FIXME: needs a more mnemonic name (defmacro steve-splice (source destination) @@ -743,10 +743,10 @@ (defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc - "Destructively returns the union list1 and list2." + "Destructively return the union of LIST1 and LIST2." (declare (inline member)) (if (and testp notp) - (error "Test and test-not both supplied.")) + (error ":TEST and :TEST-NOT were both supplied.")) (let ((res list2) (list1 list1)) (do () @@ -759,7 +759,7 @@ (defun intersection (list1 list2 &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc - "Returns the intersection of list1 and list2." + "Return the intersection of LIST1 and LIST2." (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) @@ -772,7 +772,7 @@ (defun nintersection (list1 list2 &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc - "Destructively returns the intersection of list1 and list2." + "Destructively return the intersection of LIST1 and LIST2." (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) @@ -787,7 +787,7 @@ (defun set-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc - "Returns the elements of list1 which are not in list2." + "Return the elements of LIST1 which are not in LIST2." (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) @@ -802,7 +802,7 @@ (defun nset-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc - "Destructively returns the elements of list1 which are not in list2." + "Destructively return the elements of LIST1 which are not in LIST2." (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) @@ -817,7 +817,7 @@ (defun set-exclusive-or (list1 list2 &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc - "Returns new list of elements appearing exactly once in list1 and list2." + "Return new list of elements appearing exactly once in LIST1 and LIST2." (declare (inline member)) (let ((result nil)) (dolist (elt list1) @@ -828,18 +828,17 @@ (setq result (cons elt result)))) result)) -;;; The outer loop examines list1 while the inner loop examines list2. If an -;;; element is found in list2 "equal" to the element in list1, both are -;;; spliced out. When the end of list1 is reached, what is left of list2 is -;;; tacked onto what is left of list1. The splicing operation ensures that -;;; the correct operation is performed depending on whether splice is at the -;;; top of the list or not - +;;; The outer loop examines list1 while the inner loop examines list2. +;;; If an element is found in list2 "equal" to the element in list1, +;;; both are spliced out. When the end of list1 is reached, what is +;;; left of list2 is tacked onto what is left of list1. The splicing +;;; operation ensures that the correct operation is performed +;;; depending on whether splice is at the top of the list or not (defun nset-exclusive-or (list1 list2 &key (test #'eql) (test-not nil notp) key) #!+sb-doc - "Destructively return a list with elements which appear but once in list1 - and list2." + "Destructively return a list with elements which appear but once in LIST1 + and LIST2." (do ((list1 list1) (list2 list2) (x list1 (cdr x)) @@ -868,7 +867,7 @@ (defun subsetp (list1 list2 &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc - "Returns T if every element in list1 is also in list2." + "Return T if every element in LIST1 is also in LIST2." (declare (inline member)) (dolist (elt list1) (unless (with-set-keys (member (apply-key key elt) list2)) @@ -879,12 +878,12 @@ (defun acons (key datum alist) #!+sb-doc - "Construct a new alist by adding the pair (key . datum) to alist" + "Construct a new alist by adding the pair (KEY . DATUM) to ALIST." (cons (cons key datum) alist)) (defun pairlis (keys data &optional (alist '())) #!+sb-doc - "Construct an association list from keys and data (adding to alist)" + "Construct an association list from KEYS and DATA (adding to ALIST)." (do ((x keys (cdr x)) (y data (cdr y))) ((and (endp x) (endp y)) alist) diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 18e1d13..0b0e4bc 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -1902,8 +1902,8 @@ from-end start end key))) (frobs)))) -;;; the user interface to FIND and POSITION: Get all our ducks in a row, -;;; then call %FIND-POSITION +;;; the user interface to FIND and POSITION: Get all our ducks in a +;;; row, then call %FIND-POSITION. (declaim (inline find position)) (macrolet ((def-find-position (fun-name values-index) `(defun ,fun-name (item diff --git a/src/cold/defun-load-or-cload-xcompiler.lisp b/src/cold/defun-load-or-cload-xcompiler.lisp index 2a178e0..d195581 100644 --- a/src/cold/defun-load-or-cload-xcompiler.lisp +++ b/src/cold/defun-load-or-cload-xcompiler.lisp @@ -13,8 +13,6 @@ ;;; cross-compilation host Common Lisp. (defun load-or-cload-xcompiler (load-or-cload-stem) - (format t "~&/entering LOAD-OR-CLOAD-XCOMPILER~%") ; REMOVEME - ;; The running-in-the-host-Lisp Python cross-compiler defines its ;; own versions of a number of functions which should not overwrite ;; host-Lisp functions. Instead we put them in a special package. @@ -122,8 +120,6 @@ "WITH-COMPILATION-UNIT")) (export (intern name package-name) package-name))) - (format t "~&/made SB-XC~%") ; REMOVEME - ;; Build a version of Python to run in the host Common Lisp, to be ;; used only in cross-compilation. ;; @@ -134,13 +130,10 @@ ;; order to make the compiler aware of the definitions of assembly ;; routines. (do-stems-and-flags (stem flags) - (format t "~&/STEM=~S FLAGS=~S~%" stem flags) ; REMOVEME (unless (find :not-host flags) - (format t "~&/FUNCALLing ~S~%" load-or-cload-stem) ; REMOVEME (funcall load-or-cload-stem stem :ignore-failure-p (find :ignore-failure-p flags)) - (format t "~&/back from FUNCALL~%") ; REMOVEME #!+sb-show (warn-when-cl-snapshot-diff *cl-snapshot*))) ;; If the cross-compilation host is SBCL itself, we can use the @@ -151,7 +144,6 @@ ;; (in the ordinary build procedure anyway) essentially everything ;; which is reachable at this point will remain reachable for the ;; entire run. - (format t "~&/doing PURIFY~%") ; REMOVEME #+sbcl (sb-ext:purify) (values)) diff --git a/src/cold/shared.lisp b/src/cold/shared.lisp index 40f1eba..e165afb 100644 --- a/src/cold/shared.lisp +++ b/src/cold/shared.lisp @@ -136,8 +136,6 @@ (compile-file #'compile-file) ignore-failure-p) - (format t "~&/entering COMPILE-STEM~%") ; REMOVEME - (let* (;; KLUDGE: Note that this CONCATENATE 'STRING stuff is not The Common ;; Lisp Way, although it works just fine for common UNIX environments. ;; Should it come to pass that the system is ported to environments @@ -199,8 +197,6 @@ ;; the temporary output file to the permanent object file. (rename-file-a-la-unix tmp-obj obj) - (format t "~&/nearly done with COMPILE-STEM~%") ; REMOVEME - ;; nice friendly traditional return value (pathname obj))) (compile 'compile-stem) @@ -310,21 +306,21 @@ :sb-propagate-fun-type)))) (with-additional-nickname ("SB-XC" "SB!XC") (funcall fn)))) -;;; FIXME: This COMPILE caused problems in sbcl-0.6.11.26. (bug 93) -;;;(compile 'in-host-compilation-mode) +(compile 'in-host-compilation-mode) ;;; Process a file as source code for the cross-compiler, compiling it ;;; (if necessary) in the appropriate environment, then loading it ;;; into the cross-compilation host Common lisp. (defun host-cload-stem (stem &key ignore-failure-p) - (format t "~&/entering HOST-CLOAD-STEM ~S ~S" stem ignore-failure-p) ; REMOVEME - (load (in-host-compilation-mode - (lambda () - (compile-stem stem - :obj-prefix *host-obj-prefix* - :obj-suffix *host-obj-suffix* - :compile-file #'cl:compile-file - :ignore-failure-p ignore-failure-p))))) + (let ((compiled-filename (in-host-compilation-mode + (lambda () + (compile-stem + stem + :obj-prefix *host-obj-prefix* + :obj-suffix *host-obj-suffix* + :compile-file #'cl:compile-file + :ignore-failure-p ignore-failure-p))))) + (load compiled-filename))) (compile 'host-cload-stem) ;;; Like HOST-CLOAD-STEM, except that we don't bother to compile. diff --git a/src/cold/shebang.lisp b/src/cold/shebang.lisp index 9a0c532..9587efe 100644 --- a/src/cold/shebang.lisp +++ b/src/cold/shebang.lisp @@ -18,7 +18,7 @@ ;;; the feature list for the target system (export '*shebang-features*) -(declaim (type symbol *shebang-features*)) +(declaim (type list *shebang-features*)) (defvar *shebang-features*) (defun feature-in-list-p (feature list) diff --git a/src/compiler/target-byte-comp.lisp b/src/compiler/target-byte-comp.lisp index 287b7bf..844b199 100644 --- a/src/compiler/target-byte-comp.lisp +++ b/src/compiler/target-byte-comp.lisp @@ -119,7 +119,7 @@ (format t "~&~4D:" index)) (next-byte () (let ((byte (sap-ref-8 sap index))) - (format t " ~2,'0X" byte) + (format t " ~2,'0X " byte) (incf index) byte)) (extract-24-bits () diff --git a/src/compiler/target-main.lisp b/src/compiler/target-main.lisp index d29ce80..c77d7eb 100644 --- a/src/compiler/target-main.lisp +++ b/src/compiler/target-main.lisp @@ -109,12 +109,10 @@ where if NAME is NIL, THING is the result of compilation, and otherwise THING is NAME. When NAME is not NIL, the compiled function is also set into (FDEFINITION NAME)." - ;;(format t "~&/in COMPILE NAME=~S DEFINITION=~S" name definition) ; REMOVEME (multiple-value-bind (compiled-definition warnings-p failure-p) (if (compiled-function-p definition) (values definition nil nil) (actually-compile name definition)) - ;;(format t "~&/COMPILED-DEFINITION=~S~%" compiled-definition) ; REMOVEME (cond (name (unless failure-p (setf (fdefinition name) compiled-definition)) diff --git a/version.lisp-expr b/version.lisp-expr index d28c192..f9e95cd 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -16,4 +16,4 @@ ;;; four numeric fields, is used for versions which aren't released ;;; but correspond only to CVS tags or snapshots. -"0.pre7.14.flaky4.2" +"0.pre7.14.flaky4.3" -- 1.7.10.4