(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)))
(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)))
(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))))
(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)
(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
;;; 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))
(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)
(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 ()
(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."))
(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."))
(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."))
(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."))
(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)
(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))
(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))
(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)
;;; 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.
"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.
;;
;; 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
;; (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))
(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
;; 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)
: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.
projects / sbcl.git / commitdiff