(inline-function-info-type info)))
(arg-types (second spec))
(result-type (third spec))
- (args (mapcar #'(lambda (x)
- (declare (ignore x))
- (gensym))
- arg-types))
+ (args (make-gensym-list (length arg-types)))
(func
`(the ,result-type
(,(inline-function-info-interpreter-function info)
arg-types args))
,(if (and (consp result-type)
(eq (car result-type) 'values))
- (let ((results
- (mapcar #'(lambda (x)
- (declare (ignore x))
- (gensym))
- (cdr result-type))))
+ (let ((results (make-gensym-list
+ (length (cdr result-type)))))
`(multiple-value-bind ,results ,func
,@(mapcar #'(lambda (res)
`(push-eval-stack ,res))
(flush-standard-output-streams)
(sb!unix:unix-exit wot)))
-(defun quit (&key recklessly-p (unix-code 0))
+(defun quit (&key recklessly-p
+ (unix-code 0 unix-code-p)
+ (unix-status unix-code))
#!+sb-doc
"Terminate the current Lisp. Things are cleaned up (with UNWIND-PROTECT
and so forth) unless RECKLESSLY-P is non-NIL. On UNIX-like systems,
- UNIX-CODE is used as the status code."
+ UNIX-STATUS is used as the status code."
(declare (type (signed-byte 32) unix-code))
+ ;; TO DO: UNIX-CODE was deprecated in sbcl-0.6.8, after having been
+ ;; around for less than a year. It should be safe to remove it after
+ ;; a year.
+ (when unix-code-p
+ (warn "The UNIX-CODE argument is deprecated. Use the UNIX-STATUS argument
+instead (which is another name for the same thing)."))
(if recklessly-p
- (sb!unix:unix-exit unix-code)
+ (sb!unix:unix-exit unix-status)
(throw '%end-of-the-world unix-code)))
\f
;;;; initialization functions
;;; We also cache the last top-level form that we printed a source for so that
;;; we don't have to do repeated reads and calls to FORM-NUMBER-TRANSLATIONS.
(defvar *cached-top-level-form-offset* nil)
-(declaim (type (or sb!kernel:index null) *cached-top-level-form-offset*))
+(declaim (type (or index null) *cached-top-level-form-offset*))
(defvar *cached-top-level-form*)
(defvar *cached-form-number-translations*)
`(multiple-value-bind (,g) ,value-form
,g)))
((list-of-symbols-p vars)
- (let ((temps (mapcar #'(lambda (x)
- (declare (ignore x))
- (gensym)) vars)))
+ (let ((temps (make-gensym-list (length vars))))
`(multiple-value-bind ,temps ,value-form
,@(mapcar #'(lambda (var temp)
`(setq ,var ,temp))
(file-comment
"$Header$")
+;;; a type used for indexing into arrays, and for related quantities
+;;; like lengths of lists
+;;;
+;;; It's intentionally limited to one less than the
+;;; ARRAY-DIMENSION-LIMIT for efficiency reasons, because in SBCL
+;;; ARRAY-DIMENSION-LIMIT is MOST-POSITIVE-FIXNUM, and staying below
+;;; that lets the system know it can increment a value of this type
+;;; without having to worry about using a bignum to represent the
+;;; result.
+;;;
+;;; (It should be safe to use ARRAY-DIMENSION-LIMIT as an exclusive
+;;; bound because ANSI specifies it as an exclusive bound.)
+(def!type index () `(integer 0 (,sb!xc:array-dimension-limit)))
+
;;; the default value used for initializing character data. The ANSI
;;; spec says this is arbitrary. CMU CL used #\NULL, which we avoid
;;; because it's not in the ANSI table of portable characters.
(error "not legal as a function name: ~S" function-name))))
;;; Is X a (possibly-improper) list of at least N elements?
+(declaim (ftype (function (t index)) list-of-length-at-least-p))
(defun list-of-length-at-least-p (x n)
- (declare (type (and unsigned-byte fixnum) n))
(or (zerop n) ; since anything can be considered an improper list of length 0
(and (consp x)
(list-of-length-at-least-p (cdr x) (1- n)))))
+
+;;; Return a list of N gensyms. (This is a common suboperation in
+;;; macros and other code-manipulating code.)
+(declaim (ftype (function (index) list) make-gensym-list))
+(defun make-gensym-list (n)
+ (loop repeat n collect (gensym)))
\f
#|
;;; REMOVEME when done testing byte cross-compiler
(error "SETF of APPLY is only defined for function args like #'SYMBOL."))
(let ((function (second functionoid))
(new-var (gensym))
- (vars (mapcar #'(lambda (x)
- (declare (ignore x))
- (gensym))
- args)))
+ (vars (make-gensym-list (length args))))
(values vars args (list new-var)
`(apply #'(setf ,function) ,new-var ,@vars)
`(apply #',function ,@vars))))
body))))
annotated-cases))))))))
-;;; FIXME: Delete this when the system is stable.
-#|
-This macro doesn't work in our system due to lossage in closing over tags.
-The previous version sets up unique run-time tags.
-
-(defmacro handler-case (form &rest cases)
- #!+sb-doc
- "(HANDLER-CASE form
- { (type ([var]) body) }* )
- Executes form in a context with handlers established for the condition
- types. A peculiar property allows type to be :no-error. If such a clause
- occurs, and form returns normally, all its values are passed to this clause
- as if by MULTIPLE-VALUE-CALL. The :no-error clause accepts more than one
- var specification."
- (let ((no-error-clause (assoc ':no-error cases)))
- (if no-error-clause
- (let ((normal-return (make-symbol "normal-return"))
- (error-return (make-symbol "error-return")))
- `(block ,error-return
- (multiple-value-call #'(lambda ,@(cdr no-error-clause))
- (block ,normal-return
- (return-from ,error-return
- (handler-case (return-from ,normal-return ,form)
- ,@(remove no-error-clause cases)))))))
- (let ((tag (gensym))
- (var (gensym))
- (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case))
- cases)))
- `(block ,tag
- (let ((,var nil))
- ,var ;ignorable
- (tagbody
- (handler-bind
- ,(mapcar #'(lambda (annotated-case)
- (list (cadr annotated-case)
- `#'(lambda (temp)
- ,(if (caddr annotated-case)
- `(setq ,var temp)
- '(declare (ignore temp)))
- (go ,(car annotated-case)))))
- annotated-cases)
- (return-from ,tag ,form))
- ,@(mapcan
- #'(lambda (annotated-case)
- (list (car annotated-case)
- (let ((body (cdddr annotated-case)))
- `(return-from
- ,tag
- ,(cond ((caddr annotated-case)
- `(let ((,(caaddr annotated-case)
- ,var))
- ,@body))
- ((not (cdr body))
- (car body))
- (t
- `(progn ,@body)))))))
- annotated-cases))))))))
-|#
-
(defmacro ignore-errors (&rest forms)
#!+sb-doc
"Executes forms after establishing a handler for all error conditions that
;;; back to the symbol which was used to indirect into the function,
;;; so the undefined function handler can base its complaint on that.
;;;
-;;; Another problem with doing the simple thing: people will want to indirect
-;;; through something in order to get to SETF functions, in order to be able to
-;;; redefine them. What will they indirect through? This could be done with a
-;;; hack, making an anonymous symbol and linking it to the main symbol's
-;;; SB!KERNEL:SETF-FUNCTION property. The anonymous symbol could even point
-;;; back to the symbol it's the SETF function for, so that if the SETF function
-;;; was undefined at the time a call was made, the debugger could say which
-;;; function caused the problem. It'd probably be cleaner, though, to use a new
-;;; type of primitive object (SYMBOLOID?) instead. It could probably be like
-;;; symbol except that its name could be any object and its value points back
-;;; to the symbol which owns it. Then the setf functions for FOO could be on
-;;; the list (GET FOO 'SB!KERNEL:SYMBOLOIDS)
+;;; Another problem with doing the simple thing: people will want to
+;;; indirect through something in order to get to SETF functions, in
+;;; order to be able to redefine them. What will they indirect
+;;; through? This could be done with a hack, making an anonymous
+;;; symbol and linking it to the main symbol's SB!KERNEL:SETF-FUNCTION
+;;; property. The anonymous symbol could even point back to the symbol
+;;; it's the SETF function for, so that if the SETF function was
+;;; undefined at the time a call was made, the debugger could say
+;;; which function caused the problem. It'd probably be cleaner,
+;;; though, to use a new type of primitive object (SYMBOLOID?)
+;;; instead. It could probably be like symbol except that its name
+;;; could be any object and its value points back to the symbol which
+;;; owns it. Then the setf functions for FOO could be on the list (GET
+;;; FOO 'SB!KERNEL:SYMBOLOIDS)
;;;
-;;; FIXME: Oh, my. Now that I've started thinking about it, I appreciate more
-;;; fully how weird and twisted FDEFNs might be. Look at the calling sequence
-;;; for full calls. It goes and reads the address of a function object from its
-;;; own table of immediate values, then jumps into that. Consider how weird
-;;; that is. Not only is it not doing indirection through a symbol (which I'd
-;;; already realized) but it's not doing indirection through
+;;; FIXME: Oh, my. Now that I've started thinking about it, I
+;;; appreciate more fully how weird and twisted FDEFNs might be. Look
+;;; at the calling sequence for full calls. It goes and reads the
+;;; address of a function object from its own table of immediate
+;;; values, then jumps into that. Consider how weird that is. Not only
+;;; is it not doing indirection through a symbol (which I'd already
+;;; realized) but it's not doing indirection through
;;; The compiler emits calls to this when someone tries to funcall a symbol.
(defun %coerce-name-to-function (name)
(or (and fdefn (fdefn-function fdefn))
(error 'undefined-function :name name))))
+(defun %coerce-callable-to-function (callable)
+ (if (functionp callable)
+ callable
+ (%coerce-name-to-function callable)))
+
;;; This is just another name for %COERCE-NAME-TO-FUNCTION.
#!-sb-fluid (declaim (inline raw-definition))
(defun raw-definition (name)
(def-alien-type-translator array (ele-type &rest dims &environment env)
(when dims
- (unless (typep (first dims) '(or sb!kernel:index null))
+ (unless (typep (first dims) '(or index null))
(error "The first dimension is not a non-negative fixnum or NIL: ~S"
(first dims)))
- (let ((loser (find-if-not #'(lambda (x) (typep x 'sb!kernel:index))
+ (let ((loser (find-if-not #'(lambda (x) (typep x 'index))
(rest dims))))
(when loser
(error "A dimension is not a non-negative fixnum: ~S" loser))))
\f
;;; list copying functions
-;;; The list is copied correctly even if the list is not terminated by ()
-;;; The new list is built by cdr'ing splice which is always at the tail
-;;; of the new list
-
(defun copy-list (list)
#!+sb-doc
- "Returns a new list EQUAL but not EQ to list"
+ "Returns a new list which is EQUAL to LIST."
+ ;; The list is copied correctly even if the list is not terminated
+ ;; by NIL. The new list is built by CDR'ing SPLICE which is always
+ ;; at the tail of the new list.
(if (atom list)
list
(let ((result (list (car list))))
(defun copy-alist (alist)
#!+sb-doc
- "Returns a new association list equal to alist, constructed in space"
+ "Returns a new association list which is EQUAL to ALIST."
(if (atom alist)
alist
(let ((result
(result y (cons (car top) result)))
((endp top) result)))
-;;; NCONC finds the first non-null list, so it can make splice point to a cons.
-;;; After finding the first cons element, it holds it in a result variable
-;;; while running down successive elements tacking them together. While
-;;; tacking lists together, if we encounter a null list, we set the previous
-;;; list's last cdr to nil just in case it wasn't already nil, and it could
-;;; have been dotted while the null list was the last argument to NCONC. The
-;;; manipulation of splice (that is starting it out on a first cons, setting
-;;; LAST of splice, and setting splice to ele) inherently handles (nconc x x),
-;;; and it avoids running down the last argument to NCONC which allows the last
-;;; argument to be circular.
+;;; NCONC finds the first non-null list, so it can make splice point
+;;; to a cons. After finding the first cons element, it holds it in a
+;;; result variable while running down successive elements tacking
+;;; them together. While tacking lists together, if we encounter a
+;;; null list, we set the previous list's last cdr to nil just in case
+;;; it wasn't already nil, and it could have been dotted while the
+;;; null list was the last argument to NCONC. The manipulation of
+;;; splice (that is starting it out on a first cons, setting LAST of
+;;; splice, and setting splice to ele) inherently handles (nconc x x),
+;;; and it avoids running down the last argument to NCONC which allows
+;;; the last argument to be circular.
(defun nconc (&rest lists)
#!+sb-doc
"Concatenates the lists given as arguments (by changing them)"
((atom 2nd) 3rd)
(rplacd 2nd 3rd)))
\f
-(defun butlast (list &optional (n 1))
- #!+sb-doc
- "Return a new list the same as LIST without the last N conses.
- List must not be circular."
- (declare (list list) (type index n))
- (let ((length (do ((list list (cdr list))
- (i 0 (1+ i)))
- ((atom list) (1- i)))))
- (declare (type index length))
- (unless (< length n)
- (do* ((top (cdr list) (cdr top))
- (result (list (car list)))
- (splice result)
- (count length (1- count)))
- ((= count n) result)
- (declare (type index count))
- (setq splice (cdr (rplacd splice (list (car top)))))))))
-
-(defun nbutlast (list &optional (n 1))
- #!+sb-doc
- "Modifies List to remove the last N conses. List must not be circular."
- (declare (list list) (type index n))
- (let ((length (do ((list list (cdr list))
- (i 0 (1+ i)))
- ((atom list) (1- i)))))
- (declare (type index length))
- (unless (< length n)
- (do ((1st (cdr list) (cdr 1st))
- (2nd list 1st)
- (count length (1- count)))
- ((= count n)
- (rplacd 2nd ())
- list)
- (declare (type index count))))))
+(flet (;; Return the number of conses at the head of the
+ ;; possibly-improper list LIST. (Or if LIST is circular, you
+ ;; lose.)
+ (count-conses (list)
+ (do ((in-list list (cdr in-list))
+ (result 0 (1+ result)))
+ ((atom in-list)
+ result)
+ (declare (type index result)))))
+ (declare (ftype (function (t) index) count-conses))
+ (defun butlast (list &optional (n 1))
+ (let* ((n-conses-in-list (count-conses list))
+ (n-remaining-to-copy (- n-conses-in-list n)))
+ (declare (type fixnum n-remaining-to-copy))
+ (when (plusp n-remaining-to-copy)
+ (do* ((result (list (first list)))
+ (rest (rest list) (rest rest))
+ (splice result))
+ ((zerop (decf n-remaining-to-copy))
+ result)
+ (setf splice
+ (setf (cdr splice)
+ (list (first rest))))))))
+ (defun nbutlast (list &optional (n 1))
+ (let ((n-conses-in-list (count-conses list)))
+ (unless (< n-conses-in-list n)
+ (setf (cdr (nthcdr (- n-conses-in-list n 1) list))
+ nil)
+ list))))
(defun ldiff (list object)
"Returns a new list, whose elements are those of List that appear before
(return (cdr result))
(setq splice (cdr (rplacd splice (list (car list))))))))
\f
-;;; Functions to alter list structure
+;;;; functions to alter list structure
(defun rplaca (x y)
#!+sb-doc
(declare (optimize-interface (speed 3) (safety 0)))
value))))
\f
-;;;; macros for (&key (key #'identity) (test #'eql testp) (test-not nil notp)).
+;;;; macros for (&KEY (KEY #'IDENTITY) (TEST #'EQL TESTP) (TEST-NOT NIL NOTP))
;;; Use these with the following keyword args:
(defmacro with-set-keys (funcall)
;; State: :active or :inactive.
(state :inactive :type (member :active :inactive))
;; The control stack; an index into *control-stacks*.
- (control-stack-id nil :type (or sb!kernel:index null))
+ (control-stack-id nil :type (or sb!int:index null))
;; Binding stack.
(binding-stack nil :type (or (simple-array t (*)) null))
;; Twice the number of bindings.
(len (length eval-stack)))
(do ((i eval-stack-top (1+ i)))
((= i len))
- (declare (type sb!kernel:index i))
+ (declare (type sb!int:index i))
(setf (svref eval-stack i) nil))))))
;;; Generate the initial bindings for a newly created stack-group.
(let ((destroyed-processes nil))
(do ((cnt 0 (1+ cnt)))
((> cnt 10))
- (declare (type sb!kernel:index cnt))
+ (declare (type sb!int:index cnt))
(dolist (process *all-processes*)
(when (and (not (eq process *current-process*))
(process-active-p process)
"Wait until FD is usable for DIRECTION and return True. DIRECTION should be
either :INPUT or :OUTPUT. TIMEOUT, if supplied, is the number of seconds to
wait before giving up and returning NIL."
- (declare (type sb!kernel:index fd)
+ (declare (type sb!int:index fd)
(type (or real null) timeout)
(optimize (speed 3)))
(if (or (eq *current-process* *initial-process*)
(eval-when (:compile-toplevel)
-;;; Seq-Dispatch does an efficient type-dispatch on the given Sequence.
-
-;;; FIXME: It might be worth making three cases here, LIST, SIMPLE-VECTOR,
-;;; and VECTOR, instead of the current LIST and VECTOR. It tend to make code
-;;; run faster but be bigger; some benchmarking is needed to decide.
+;;; SEQ-DISPATCH does an efficient type-dispatch on the given SEQUENCE.
+;;;
+;;; FIXME: It might be worth making three cases here, LIST,
+;;; SIMPLE-VECTOR, and VECTOR, instead of the current LIST and VECTOR.
+;;; It tend to make code run faster but be bigger; some benchmarking
+;;; is needed to decide.
(sb!xc:defmacro seq-dispatch (sequence list-form array-form)
`(if (listp ,sequence)
,list-form
,array-form))
-;;; FIXME: Implementations of MAPFOO which use this are O(N*N) when users
-;;; could reasonably expect them to be O(N). This should be fixed.
-(sb!xc:defmacro elt-slice (sequences n)
- #!+sb-doc
- "Returns a list of the Nth element of each of the sequences. Used by MAP
- and friends."
- `(mapcar #'(lambda (seq) (elt seq ,n)) ,sequences))
-
(sb!xc:defmacro make-sequence-like (sequence length)
#!+sb-doc
"Returns a sequence of the same type as SEQUENCE and the given LENGTH."
) ; EVAL-WHEN
+;;; It's possible with some sequence operations to declare the length
+;;; of a result vector, and to be safe, we really ought to verify that
+;;; the actual result has the declared length.
+(defun vector-of-checked-length-given-length (vector declared-length)
+ (declare (type vector vector))
+ (declare (type index declared-length))
+ (let ((actual-length (length vector)))
+ (unless (= actual-length declared-length)
+ (error 'simple-type-error
+ :datum vector
+ :expected-type `(vector ,declared-length)
+ :format-control
+ "Vector length (~D) doesn't match declared length (~D)."
+ :format-arguments (list actual-length declared-length))))
+ vector)
+(defun sequence-of-checked-length-given-type (sequence result-type)
+ (let ((ctype (specifier-type result-type)))
+ (if (not (array-type-p ctype))
+ sequence
+ (let ((declared-length (first (array-type-dimensions ctype))))
+ (if (eq declared-length '*)
+ sequence
+ (vector-of-checked-length-given-length sequence
+ declared-length))))))
+
;;; Given an arbitrary type specifier, return a sane sequence type
;;; specifier that we can directly match.
(defun result-type-or-lose (type &optional nil-ok)
(defun signal-index-too-large-error (sequence index)
(let* ((length (length sequence))
- (max-index (and (plusp length)(1- length))))
+ (max-index (and (plusp length) (1- length))))
(error 'index-too-large-error
:datum index
:expected-type (if max-index
(defun concat-to-simple* (type &rest sequences)
(concatenate-to-mumble type sequences))
\f
-;;;; MAP
+;;;; MAP and MAP-INTO
-;;; helper functions to handle the common consing subcases of MAP
+;;; helper functions to handle arity-1 subcases of MAP
(declaim (ftype (function (function sequence) list) %map-list-arity-1))
(declaim (ftype (function (function sequence) simple-vector)
%map-simple-vector-arity-1))
(simple-vector (dovector (,i sequence) ,@body))
(vector (dovector (,i sequence) ,@body))))))
(defun %map-to-list-arity-1 (fun sequence)
- (declare (type function fun))
- (let ((really-fun (if (functionp fun) fun (%coerce-name-to-function fun)))
- (reversed-result nil))
+ (let ((reversed-result nil)
+ (really-fun (%coerce-callable-to-function fun)))
(dosequence (element sequence)
(push (funcall really-fun element)
reversed-result))
(nreverse reversed-result)))
(defun %map-to-simple-vector-arity-1 (fun sequence)
- (declare (type function fun))
- (let ((really-fun (if (functionp fun) fun (%coerce-name-to-function fun)))
- (result (make-array (length sequence)))
- (index 0))
+ (let ((result (make-array (length sequence)))
+ (index 0)
+ (really-fun (%coerce-callable-to-function fun)))
(declare (type index index))
(dosequence (element sequence)
(setf (aref result index)
(funcall really-fun element))
(incf index))
- result)))
-
-(eval-when (:compile-toplevel :execute)
-
-(sb!xc:defmacro map-to-list (function sequences)
- `(do ((seqs more-sequences (cdr seqs))
- (min-length (length first-sequence)))
- ((null seqs)
- (let ((result (list nil)))
- (do ((index 0 (1+ index))
- (splice result))
- ((= index min-length) (cdr result))
- (declare (fixnum index))
- (setq splice
- (cdr (rplacd splice
- (list (apply ,function (elt-slice ,sequences
- index)))))))))
- (declare (fixnum min-length))
- (let ((length (length (car seqs))))
- (declare (fixnum length))
- (if (< length min-length)
- (setq min-length length)))))
-
-(sb!xc:defmacro map-to-simple (output-type-spec function sequences)
- `(do ((seqs more-sequences (cdr seqs))
- (min-length (length first-sequence)))
- ((null seqs)
- (do ((index 0 (1+ index))
- (result (make-sequence-of-type ,output-type-spec min-length)))
- ((= index min-length) result)
- (declare (fixnum index))
- (setf (aref result index)
- (apply ,function (elt-slice ,sequences index)))))
- (declare (fixnum min-length))
- (let ((length (length (car seqs))))
- (declare (fixnum length))
- (if (< length min-length)
- (setq min-length length)))))
-
-(sb!xc:defmacro map-for-effect (function sequences)
- `(do ((seqs more-sequences (cdr seqs))
- (min-length (length first-sequence)))
- ((null seqs)
- (do ((index 0 (1+ index)))
- ((= index min-length) nil)
- (apply ,function (elt-slice ,sequences index))))
- (declare (fixnum min-length))
- (let ((length (length (car seqs))))
- (declare (fixnum length))
- (if (< length min-length)
- (setq min-length length)))))
-
-) ; EVAL-WHEN
-
-#!+high-security-support
-(defun get-minimum-length-sequences (sequences)
- #!+sb-doc "Gets the minimum length of the sequences. This is
-needed to check whether the supplied type is appropriate."
- (let ((min nil))
- (dolist (i sequences)
- (when (or (listp i) (vectorp i))
- (let ((l (length i)))
- (when (or (null min)
- (> min l)))
- (setf min l))))
- min))
-
-(defun map (output-type-spec function first-sequence &rest more-sequences)
- #!+sb-doc
- "FUNCTION must take as many arguments as there are sequences provided. The
- result is a sequence such that element i is the result of applying FUNCTION
- to element i of each of the argument sequences."
- (let ((really-function (if (functionp function)
- function
- (%coerce-name-to-function function))))
- ;; Pick off the easy non-consing arity-1 special case and handle
- ;; it without consing, since the user probably didn't expect us to
- ;; cons here. (Notably, the super duper users who wrote PCL in
- ;; terms of quantifiers without declaring the types of their
- ;; sequence arguments didn't expect to end up consing when SBCL
- ;; transforms the quantifiers into calls to MAP NIL.)
- (when (and (null more-sequences)
- (null output-type-spec))
- (macrolet ((frob () '(return-from map
- (map nil really-function first-sequence))))
- (etypecase first-sequence
- (simple-vector (frob))
- (list (frob))
- (vector (frob)))))
- ;; Otherwise, if the user didn't give us enough information to
- ;; simplify at compile time, we cons and cons and cons..
- (let ((sequences (cons first-sequence more-sequences)))
- (case (type-specifier-atom output-type-spec)
- ((nil) (map-for-effect really-function sequences))
- (list (map-to-list really-function sequences))
- ((simple-vector simple-string vector string array simple-array
- bit-vector simple-bit-vector base-string simple-base-string)
- #!+high-security
- (let ((min-length-sequences (get-minimum-length-sequences
- sequences))
- (dimensions (array-type-dimensions (specifier-type
- output-type-spec))))
- (when (or (/= (length dimensions) 1)
- (and (not (eq (car dimensions) '*))
- (/= (car dimensions) min-length-sequences)))
- (error 'simple-type-error
- :datum output-type-spec
- :expected-type
- (ecase (type-specifier-atom output-type-spec)
- ((simple-vector bit-vector simple-bit-vector string simple-string base-string)
- `(,(type-specifier-atom output-type-spec) ,min-length-sequences))
- ((array vector simple-array) `(,(type-specifier-atom output-type-spec) * ,min-length-sequences)))
- :format-control "Minimum length of sequences is ~S, this is not compatible with the type ~S."
- :format-arguments
- (list min-length-sequences output-type-spec))))
- (let ((result (map-to-simple output-type-spec
- really-function
- sequences)))
- #!+high-security
- (check-type-var result output-type-spec)
- result))
- (t
- (apply #'map (result-type-or-lose output-type-spec t)
- really-function sequences))))))
-
-#!+high-security-support
-(defun map-without-errorchecking
- (output-type-spec function first-sequence &rest more-sequences)
- #!+sb-doc
- "FUNCTION must take as many arguments as there are sequences provided. The
- result is a sequence such that element i is the result of applying FUNCTION
- to element I of each of the argument sequences. This version has no
- error-checking, to pass cold-load."
- (let ((sequences (cons first-sequence more-sequences)))
- (case (type-specifier-atom output-type-spec)
- ((nil) (map-for-effect function sequences))
- (list (map-to-list function sequences))
- ((simple-vector simple-string vector string array simple-array
- bit-vector simple-bit-vector base-string simple-base-string)
- (map-to-simple output-type-spec function sequences))
- (t
- (apply #'map (result-type-or-lose output-type-spec t)
- function sequences)))))
-
+ result))
+ (defun %map-for-effect-arity-1 (fun sequence)
+ (let ((really-fun (%coerce-callable-to-function fun)))
+ (dosequence (element sequence)
+ (funcall really-fun element)))
+ nil))
+
+;;; helper functions to handle arity-N subcases of MAP
+;;;
+;;; KLUDGE: This is hairier, and larger, than need be, because we
+;;; don't have DYNAMIC-EXTENT. With DYNAMIC-EXTENT, we could define
+;;; %MAP-FOR-EFFECT, and then implement the
+;;; other %MAP-TO-FOO functions reasonably efficiently by passing closures to
+;;; %MAP-FOR-EFFECT. (DYNAMIC-EXTENT would help a little by avoiding
+;;; consing each closure, and would help a lot by allowing us to define
+;;; a closure (LAMBDA (&REST REST) <do something with (APPLY FUN REST)>)
+;;; with the REST list allocated with DYNAMIC-EXTENT. -- WHN 20000920
+(macrolet (;; Execute BODY in a context where the machinery for
+ ;; UPDATED-MAP-APPLY-ARGS has been set up.
+ (with-map-state (sequences &body body)
+ `(let* ((%sequences ,sequences)
+ (%iters (mapcar (lambda (sequence)
+ (etypecase sequence
+ (list sequence)
+ (vector 0)))
+ %sequences))
+ (%apply-args (make-list (length %sequences))))
+ (declare (type list %sequences %iters %apply-args))
+ ,@body))
+ ;; Return a list of args to pass to APPLY for the next
+ ;; function call in the mapping, or NIL if no more function
+ ;; calls should be made (because we've reached the end of a
+ ;; sequence arg).
+ (updated-map-apply-args ()
+ '(do ((in-sequences %sequences (cdr in-sequences))
+ (in-iters %iters (cdr in-iters))
+ (in-apply-args %apply-args (cdr in-apply-args)))
+ ((null in-sequences)
+ %apply-args)
+ (declare (type list in-sequences in-iters in-apply-args))
+ (let ((i (car in-iters)))
+ (declare (type (or list index) i))
+ (if (listp i)
+ (if (null i) ; if end of this sequence
+ (return nil)
+ (setf (car in-apply-args) (car i)
+ (car in-iters) (cdr i)))
+ (let ((v (the vector (car in-sequences))))
+ (if (>= i (length v)) ; if end of this sequence
+ (return nil)
+ (setf (car in-apply-args) (aref v i)
+ (car in-iters) (1+ i)))))))))
+ (defun %map-to-list (func sequences)
+ (declare (type function func))
+ (declare (type list sequences))
+ (with-map-state sequences
+ (loop with updated-map-apply-args
+ while (setf updated-map-apply-args (updated-map-apply-args))
+ collect (apply func updated-map-apply-args))))
+ (defun %map-to-vector (output-type-spec func sequences)
+ (declare (type function func))
+ (declare (type list sequences))
+ (let ((min-len (with-map-state sequences
+ (do ((counter 0 (1+ counter)))
+ ;; Note: Doing everything in
+ ;; UPDATED-MAP-APPLY-ARGS here is somewhat
+ ;; wasteful; we even do some extra consing.
+ ;; And stepping over every element of
+ ;; VECTORs, instead of just grabbing their
+ ;; LENGTH, is also wasteful. But it's easy
+ ;; and safe. (If you do rewrite it, please
+ ;; try to make sure that
+ ;; (MAP NIL #'F SOME-CIRCULAR-LIST #(1))
+ ;; does the right thing.)
+ ((not (updated-map-apply-args))
+ counter)
+ (declare (type index counter))))))
+ (declare (type index min-len))
+ (with-map-state sequences
+ (let ((result (make-sequence-of-type output-type-spec min-len))
+ (index 0))
+ (declare (type index index))
+ (loop with updated-map-apply-args
+ while (setf updated-map-apply-args (updated-map-apply-args))
+ do
+ (setf (aref result index)
+ (apply func updated-map-apply-args))
+ (incf index))
+ result))))
+ (defun %map-for-effect (func sequences)
+ (declare (type function func))
+ (declare (type list sequences))
+ (with-map-state sequences
+ (loop with updated-map-apply-args
+ while (setf updated-map-apply-args (updated-map-apply-args))
+ do
+ (apply func updated-map-apply-args))
+ nil)))
+
+ "FUNCTION must take as many arguments as there are sequences provided.
+ The result is a sequence of type OUTPUT-TYPE-SPEC such that element I
+ is the result of applying FUNCTION to element I of each of the argument
+ sequences."
+
+;;; %MAP is just MAP without the final just-to-be-sure check that
+;;; length of the output sequence matches any length specified
+;;; in RESULT-TYPE.
+(defun %map (result-type function first-sequence &rest more-sequences)
+ (let ((really-function (%coerce-callable-to-function function)))
+ ;; Handle one-argument MAP NIL specially, using ETYPECASE to turn
+ ;; it into something which can be DEFTRANSFORMed away. (It's
+ ;; fairly important to handle this case efficiently, since
+ ;; quantifiers like SOME are transformed into this case, and since
+ ;; there's no consing overhead to dwarf our inefficiency.)
+ (if (and (null more-sequences)
+ (null result-type))
+ (%map-for-effect-arity-1 really-function first-sequence)
+ ;; Otherwise, use the industrial-strength full-generality
+ ;; approach, consing O(N-ARGS) temporary storage (which can have
+ ;; DYNAMIC-EXTENT), then using O(N-ARGS * RESULT-LENGTH) time.
+ (let ((sequences (cons first-sequence more-sequences)))
+ (case (type-specifier-atom result-type)
+ ((nil) (%map-for-effect really-function sequences))
+ (list (%map-to-list really-function sequences))
+ ((simple-vector simple-string vector string array simple-array
+ bit-vector simple-bit-vector base-string simple-base-string)
+ (%map-to-vector result-type really-function sequences))
+ (t
+ (apply #'map
+ (result-type-or-lose result-type t)
+ really-function
+ sequences)))))))
+
+(defun map (result-type function first-sequence &rest more-sequences)
+ (sequence-of-checked-length-given-type (apply #'%map
+ result-type
+ function
+ first-sequence
+ more-sequences)
+ ;; (The RESULT-TYPE isn't
+ ;; strictly the type of the
+ ;; result, because when
+ ;; RESULT-TYPE=NIL, the result
+ ;; actually has NULL type. But
+ ;; that special case doesn't
+ ;; matter here, since we only
+ ;; look closely at vector
+ ;; types; so we can just pass
+ ;; RESULT-TYPE straight through
+ ;; as a type specifier.)
+ result-type))
+
+;;; KLUDGE: MAP has been rewritten substantially since the fork from
+;;; CMU CL in order to give reasonable performance, but this
+;;; implementation of MAP-INTO still has the same problems as the old
+;;; MAP code. Ideally, MAP-INTO should be rewritten to be efficient in
+;;; the same way that the corresponding cases of MAP have been
+;;; rewritten. Instead of doing it now, though, it's easier to wait
+;;; until we have DYNAMIC-EXTENT, at which time it should become
+;;; extremely easy to define a reasonably efficient MAP-INTO in terms
+;;; of (MAP NIL ..). -- WHN 20000920
(defun map-into (result-sequence function &rest sequences)
(let* ((fp-result
(and (arrayp result-sequence)
(when fp-result
(setf (fill-pointer result-sequence) len))
- (dotimes (index len)
- (setf (elt result-sequence index)
- (apply function
- (mapcar #'(lambda (seq) (elt seq index))
- sequences)))))
+ (let ((really-fun (%coerce-callable-to-function function)))
+ (dotimes (index len)
+ (setf (elt result-sequence index)
+ (apply really-fun
+ (mapcar #'(lambda (seq) (elt seq index))
+ sequences))))))
result-sequence)
\f
;;;; quantifiers
;; enough that we can use an inline function instead
;; of a compiler macro (as above). -- WHN 20000410
(define-compiler-macro ,name (pred first-seq &rest more-seqs)
- (let ((elements (mapcar (lambda (x)
- (declare (ignore x))
- (gensym "ARG"))
- (cons first-seq more-seqs)))
+ (let ((elements (make-gensym-list (1+ (length more-seqs))))
(blockname (gensym "BLOCK")))
(once-only ((pred pred))
`(block ,blockname
(res (type-specifier
(single-value-type
(values-specifier-type (third type)))))
- (arglist (loop repeat (1+ (length args)) collect (gensym))))
+ (arglist (make-gensym-list (1+ (length args)))))
(cond
((null (intersection args lambda-list-keywords))
`(defun (setf ,name) ,arglist
tree)
(t tree)))
-;;; Sharp-equal works as follows. When a label is assigned (ie when #= is
-;;; called) we GENSYM a symbol is which is used as an unforgeable tag.
-;;; *SHARP-SHARP-ALIST* maps the integer tag to this gensym.
+;;; Sharp-equal works as follows. When a label is assigned (i.e. when
+;;; #= is called) we GENSYM a symbol is which is used as an
+;;; unforgeable tag. *SHARP-SHARP-ALIST* maps the integer tag to this
+;;; gensym.
;;;
-;;; When SHARP-SHARP encounters a reference to a label, it returns the symbol
-;;; assoc'd with the label. Resolution of the reference is deferred until the
-;;; read done by #= finishes. Any already resolved tags (in
-;;; *SHARP-EQUAL-ALIST*) are simply returned.
+;;; When SHARP-SHARP encounters a reference to a label, it returns the
+;;; symbol assoc'd with the label. Resolution of the reference is
+;;; deferred until the read done by #= finishes. Any already resolved
+;;; tags (in *SHARP-EQUAL-ALIST*) are simply returned.
;;;
;;; After reading of the #= form is completed, we add an entry to
-;;; *SHARP-EQUAL-ALIST* that maps the gensym tag to the resolved object. Then
-;;; for each entry in the *SHARP-SHARP-ALIST, the current object is searched
-;;; and any uses of the gensysm token are replaced with the actual value.
+;;; *SHARP-EQUAL-ALIST* that maps the gensym tag to the resolved
+;;; object. Then for each entry in the *SHARP-SHARP-ALIST, the current
+;;; object is searched and any uses of the gensysm token are replaced
+;;; with the actual value.
(defvar *sharp-sharp-alist* ())
(defun sharp-equal (stream ignore label)
;;; system area pointer to it.
#!-sb-fluid (declaim (inline %make-alien))
(defun %make-alien (bits)
- (declare (type sb!kernel:index bits) (optimize-interface (safety 2)))
+ (declare (type index bits) (optimize-interface (safety 2)))
(alien-funcall (extern-alien "malloc" (function system-area-pointer unsigned))
- (ash (the sb!kernel:index (+ bits 7)) -3)))
+ (ash (the index (+ bits 7)) -3)))
#!-sb-fluid (declaim (inline free-alien))
(defun free-alien (alien)
(unless stub
(setf stub
(let ((fun (gensym))
- (parms (loop repeat (length args) collect (gensym))))
+ (parms (make-gensym-list (length args))))
(compile nil
`(lambda (,fun ,@parms)
(declare (type (alien ,type) ,fun))
:extern ,alien-name)
,@(alien-vars))
,(if (alien-values-type-p result-type)
- (let ((temps (loop
- repeat (length (alien-values-type-values
- result-type))
- collect (gensym))))
+ (let ((temps (make-gensym-list
+ (length
+ (alien-values-type-values result-type)))))
`(multiple-value-bind ,temps
(alien-funcall ,lisp-name ,@(alien-args))
(values ,@temps ,@(results))))
#!+sb-doc
"For each entry in HASH-TABLE, call the designated function on the key
and value of the entry. Return NIL."
- (let ((fun (coerce function-designator 'function))
+ (let ((fun (%coerce-callable-to-function function-designator))
(size (length (hash-table-next-vector hash-table))))
(declare (type function fun))
(do ((i 1 (1+ i)))
projects / sbcl.git / commitdiff