(fill array initial-element))
(when initial-contents-p
(when initial-element-p
- (error "can't specify both :INITIAL-ELEMENT and ~
- :INITIAL-CONTENTS"))
- (unless (= length (length initial-contents))
- (error "There are ~W elements in the :INITIAL-CONTENTS, but ~
- the vector length is ~W."
- (length initial-contents)
- length))
+ (error "can't specify both :INITIAL-ELEMENT and ~
+ :INITIAL-CONTENTS"))
+ (unless (= length (length initial-contents))
+ (error "There are ~W elements in the :INITIAL-CONTENTS, but ~
+ the vector length is ~W."
+ (length initial-contents)
+ length))
(replace array initial-contents))
array))
;; it's either a complex array or a multidimensional array.
(cond (displaced-to
(when (or initial-element-p initial-contents-p)
(error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~
- can be specified along with :DISPLACED-TO"))
+ can be specified along with :DISPLACED-TO"))
(let ((offset (or displaced-index-offset 0)))
(when (> (+ offset total-size)
(array-total-size displaced-to))
initial-element initial-element-p)
(when (and initial-contents-p initial-element-p)
(error "cannot supply both :INITIAL-CONTENTS and :INITIAL-ELEMENT to
- either MAKE-ARRAY or ADJUST-ARRAY."))
+ either MAKE-ARRAY or ADJUST-ARRAY."))
(let ((data (if initial-element-p
(make-array total-size
:element-type element-type
(incf index))
(t
(unless (typep contents 'sequence)
- (error "malformed :INITIAL-CONTENTS: ~S is not a ~
- sequence, but ~W more layer~:P needed."
+ (error "malformed :INITIAL-CONTENTS: ~S is not a ~
+ sequence, but ~W more layer~:P needed."
contents
(- (length dimensions) axis)))
(unless (= (length contents) (car dims))
- (error "malformed :INITIAL-CONTENTS: Dimension of ~
- axis ~W is ~W, but ~S is ~W long."
+ (error "malformed :INITIAL-CONTENTS: Dimension of ~
+ axis ~W is ~W, but ~S is ~W long."
axis (car dims) contents (length contents)))
(if (listp contents)
(dolist (content contents)
(cond (initial-contents-p
;; array former contents replaced by INITIAL-CONTENTS
(if (or initial-element-p displaced-to)
- (error "INITIAL-CONTENTS may not be specified with ~
- the :INITIAL-ELEMENT or :DISPLACED-TO option."))
+ (error "INITIAL-CONTENTS may not be specified with ~
+ the :INITIAL-ELEMENT or :DISPLACED-TO option."))
(let* ((array-size (apply #'* dimensions))
(array-data (data-vector-from-inits
dimensions array-size element-type
(displaced-to
;; We already established that no INITIAL-CONTENTS was supplied.
(when initial-element
- (error "The :INITIAL-ELEMENT option may not be specified ~
- with :DISPLACED-TO."))
- (unless (subtypep element-type (array-element-type displaced-to))
- (error "can't displace an array of type ~S into another of ~
- type ~S"
+ (error "The :INITIAL-ELEMENT option may not be specified ~
+ with :DISPLACED-TO."))
+ (unless (subtypep element-type (array-element-type displaced-to))
+ (error "can't displace an array of type ~S into another of ~
+ type ~S"
element-type (array-element-type displaced-to)))
(let ((displacement (or displaced-index-offset 0))
(array-size (apply #'* dimensions)))
(when (array-has-fill-pointer-p old-array)
(when (> (%array-fill-pointer old-array) new-array-size)
(error "cannot ADJUST-ARRAY an array (~S) to a size (~S) that is ~
- smaller than its fill pointer (~S)"
+ smaller than its fill pointer (~S)"
old-array new-array-size (fill-pointer old-array)))
(%array-fill-pointer old-array)))
((not (array-has-fill-pointer-p old-array))
(error "cannot supply a non-NIL value (~S) for :FILL-POINTER ~
- in ADJUST-ARRAY unless the array (~S) was originally ~
- created with a fill pointer"
+ in ADJUST-ARRAY unless the array (~S) was originally ~
+ created with a fill pointer"
fill-pointer
old-array))
((numberp fill-pointer)
(when (> fill-pointer new-array-size)
(error "can't supply a value for :FILL-POINTER (~S) that is larger ~
- than the new length of the vector (~S)"
+ than the new length of the vector (~S)"
fill-pointer new-array-size))
fill-pointer)
((eq fill-pointer t)
#!+sb-doc
,(format nil
"Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~
- BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~
- If RESULT-BIT-ARRAY is T,~% BIT-ARRAY-1 is used. If ~
- RESULT-BIT-ARRAY is NIL or omitted, a new array is~% created. ~
- All the arrays must have the same rank and dimensions."
+ BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~
+ If RESULT-BIT-ARRAY is T,~% BIT-ARRAY-1 is used. If ~
+ RESULT-BIT-ARRAY is NIL or omitted, a new array is~% created. ~
+ All the arrays must have the same rank and dimensions."
(symbol-name function))
(declare (type (array bit) bit-array-1 bit-array-2)
(type (or (array bit) (member t nil)) result-bit-array))
inherits
:key #'layout-proper-name)
(warn "change in superclasses of class ~S:~% ~
- ~A superclasses: ~S~% ~
- ~A superclasses: ~S"
+ ~A superclasses: ~S~% ~
+ ~A superclasses: ~S"
name
old-context
(map 'list #'layout-proper-name old-inherits)
(when diff
(warn
"in class ~S:~% ~
- ~:(~A~) definition of superclass ~S is incompatible with~% ~
- ~A definition."
+ ~:(~A~) definition of superclass ~S is incompatible with~% ~
+ ~A definition."
name
old-context
(layout-proper-name (svref old-inherits diff))
(let ((old-length (layout-length old-layout)))
(unless (= old-length length)
(warn "change in instance length of class ~S:~% ~
- ~A length: ~W~% ~
- ~A length: ~W"
+ ~A length: ~W~% ~
+ ~A length: ~W"
name
old-context old-length
context length)
t))
(unless (= (layout-depthoid old-layout) depthoid)
(warn "change in the inheritance structure of class ~S~% ~
- between the ~A definition and the ~A definition"
+ between the ~A definition and the ~A definition"
name old-context context)
t))))
;; system from scratch, so we no longer need this functionality in
;; order to maintain the SBCL system by modifying running images.
(error "The class ~S was not changed, and there's no guarantee that~@
- the loaded code (which expected another layout) will work."
+ the loaded code (which expected another layout) will work."
(layout-proper-name layout)))
(values))
(char ascii-standard-chars (- x 32))))
(defun sb!xc:char-code (character)
(declare (type standard-char character))
- ;; FIXME: MacOS X?
(if (char= character #\Newline)
10
(+ (position character ascii-standard-chars) 32))))
(no-debug-fun-returns-debug-fun condition))))
(format stream
"~&Cannot return values from ~:[frame~;~:*~S~] since ~
- the debug information lacks details about returning ~
- values here."
+ the debug information lacks details about returning ~
+ values here."
fun)))))
(define-condition no-debug-blocks (debug-condition)
(compiled-debug-fun-compiler-debug-fun what))
:standard)
(error ":FUN-END breakpoints are currently unsupported ~
- for the known return convention."))
+ for the known return convention."))
(let* ((bpt (%make-breakpoint hook-fun what kind info))
(starter (compiled-debug-fun-end-starter what)))
;; and output on T seems broken.
(format t
"~&error flushed (because ~
- ~S is set)"
+ ~S is set)"
'*flush-debug-errors*)
(/show0 "throwing DEBUG-LOOP-CATCHER")
(throw 'debug-loop-catcher nil)))))
(cond
((not any-p)
(format t "There are no local variables ~@[starting with ~A ~]~
- in the function."
+ in the function."
prefix))
((not any-valid-p)
(format t "All variables ~@[starting with ~A ~]currently ~
- have invalid values."
+ have invalid values."
prefix))))
(write-line "There is no variable information available."))))
(file-position *cached-source-stream* char-offset))
(t
(format t "~%; File has been modified since compilation:~%; ~A~@
- ; Using form offset instead of character position.~%"
+ ; Using form offset instead of character position.~%"
(namestring name))
(file-position *cached-source-stream* 0)
(let ((*read-suppress* t))
binding
:test #'eq))
(warn "Unnamed restart does not have a ~
- report function: ~S"
+ report function: ~S"
binding))
`(make-restart :name ',(car binding)
:function ,(cadr binding)
for z = (remove-duplicates (intersection (cdr x)(cdr y) :test #'string=))
when z do (error 'simple-program-error
:format-control "Parameters ~S and ~S must be disjoint ~
- but have common elements ~% ~S"
+ but have common elements ~% ~S"
:format-arguments (list (car x)(car y) z)))))
(defun stringify-name (name kind)
(symbol
(when (keywordp spec)
(style-warn "Keyword slot name indicates probable syntax ~
- error in DEFSTRUCT: ~S."
+ error in DEFSTRUCT: ~S."
spec))
spec)
(cons
(when (or moved retyped deleted)
(warn
"incompatibly redefining slots of structure class ~S~@
- Make sure any uses of affected accessors are recompiled:~@
- ~@[ These slots were moved to new positions:~% ~S~%~]~
- ~@[ These slots have new incompatible types:~% ~S~%~]~
- ~@[ These slots were deleted:~% ~S~%~]"
+ Make sure any uses of affected accessors are recompiled:~@
+ ~@[ These slots were moved to new positions:~% ~S~%~]~
+ ~@[ These slots have new incompatible types:~% ~S~%~]~
+ ~@[ These slots were deleted:~% ~S~%~]"
name moved retyped deleted)
t))))
#!+sb-doc
"Type corresponding to the characters required by the standard."
'(member
- #\NEWLINE #\SPACE #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\,
+ #\Newline #\Space #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\,
#\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\: #\; #\< #\=
- #\> #\? #\@ #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
+ #\> #\? #\@ #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
#\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\[ #\\ #\]
#\^ #\_ #\` #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
#\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\{
PPRINT-LOGICAL-BLOCK, and only when the LIST argument to
PPRINT-LOGICAL-BLOCK is supplied."
(error "PPRINT-EXIT-IF-LIST-EXHAUSTED must be lexically inside ~
- PPRINT-LOGICAL-BLOCK."))
+ PPRINT-LOGICAL-BLOCK."))
(defmacro pprint-pop ()
#!+sb-doc
(sb!xc:get-setf-expansion form environment)
(when (cdr store-vars)
(error "GET-SETF-METHOD used for a form with multiple store ~
- variables:~% ~S"
+ variables:~% ~S"
form))
(values temps value-forms store-vars store-form access-form)))
(cond ((gethash name sb!c:*setf-assumed-fboundp*)
(warn
"defining setf macro for ~S when ~S was previously ~
- treated as a function"
+ treated as a function"
name
`(setf ,name)))
((not (fboundp `(setf ,name)))
:datum arguments
:expected-type 'null
:format-control "You may not supply additional arguments ~
- when giving ~S to ~S."
+ when giving ~S to ~S."
:format-arguments (list datum fun-name)))
datum)
((symbolp datum) ; roughly, (SUBTYPEP DATUM 'CONDITION)
(source :initarg :source :reader program-error-source))
(:report (lambda (condition stream)
(format stream "Execution of a form compiled with errors.~%~
- Form:~% ~A~%~
- Compile-time-error:~% ~A"
+ Form:~% ~A~%~
+ Compile-time-error:~% ~A"
(program-error-source condition)
(program-error-message condition)))))
:DIRECTION - one of :INPUT, :OUTPUT, :IO, or :PROBE
:ELEMENT-TYPE - the type of object to read or write, default BASE-CHAR
:IF-EXISTS - one of :ERROR, :NEW-VERSION, :RENAME, :RENAME-AND-DELETE,
- :OVERWRITE, :APPEND, :SUPERSEDE or NIL
+ :OVERWRITE, :APPEND, :SUPERSEDE or NIL
:IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or NIL
See the manual for details."
(setf args (nthcdr ,posn orig-args))
(error 'format-error
:complaint "Index ~W out of bounds. Should have been ~
- between 0 and ~W."
+ between 0 and ~W."
:args (list ,posn (length orig-args))
:offset ,(1- end)))))
(if colonp
(error 'format-error
:complaint
"Index ~W is out of bounds; should have been ~
- between 0 and ~W."
+ between 0 and ~W."
:args (list new-posn (length orig-args))
:offset ,(1- end)))))))
(if params
(if directive
(error 'format-error
:complaint
- "cannot include format directives inside the ~
- ~:[suffix~;prefix~] segment of ~~<...~~:>"
+ "cannot include format directives inside the ~
+ ~:[suffix~;prefix~] segment of ~~<...~~:>"
:args (list prefix-p)
:offset (1- (format-directive-end directive))
:references
(t (unless (eq (loop-collector-class cruft) class)
(loop-error
"incompatible kinds of LOOP value accumulation specified for collecting~@
- ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S"
+ ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S"
name (car (loop-collector-history cruft)) collector))
(unless (equal dtype (loop-collector-dtype cruft))
(loop-warn
"unequal datatypes specified in different LOOP value accumulations~@
- into ~S: ~S and ~S"
+ into ~S: ~S and ~S"
name dtype (loop-collector-dtype cruft))
(when (eq (loop-collector-dtype cruft) t)
(setf (loop-collector-dtype cruft) dtype)))
(if (setq tem (loop-tassoc (car z) *loop-named-vars*))
(loop-error
"The variable substitution for ~S occurs twice in a USING phrase,~@
- with ~S and ~S."
+ with ~S and ~S."
(car z) (cadr z) (cadr tem))
(push (cons (car z) (cadr z)) *loop-named-vars*)))
(when (or (null *loop-source-code*)
nil t)))
(t (loop-error
"~S invalid preposition in sequencing or sequence path;~@
- maybe invalid prepositions were specified in iteration path descriptor?"
+ maybe invalid prepositions were specified in iteration path descriptor?"
prep)))
(when (and odir dir (not (eq dir odir)))
(loop-error "conflicting stepping directions in LOOP sequencing path"))
(defun assert-prompt (name value)
(cond ((y-or-n-p "The old value of ~S is ~S.~
- ~%Do you want to supply a new value? "
+ ~%Do you want to supply a new value? "
name value)
(format *query-io* "~&Type a form to be evaluated:~%")
(flet ((read-it () (eval (read *query-io*))))
(defun boole (op integer1 integer2)
#!+sb-doc
"Bit-wise boolean function on two integers. Function chosen by OP:
- 0 BOOLE-CLR
- 1 BOOLE-SET
- 2 BOOLE-1
- 3 BOOLE-2
- 4 BOOLE-C1
- 5 BOOLE-C2
- 6 BOOLE-AND
- 7 BOOLE-IOR
- 8 BOOLE-XOR
- 9 BOOLE-EQV
- 10 BOOLE-NAND
- 11 BOOLE-NOR
- 12 BOOLE-ANDC1
- 13 BOOLE-ANDC2
- 14 BOOLE-ORC1
- 15 BOOLE-ORC2"
+ 0 BOOLE-CLR
+ 1 BOOLE-SET
+ 2 BOOLE-1
+ 3 BOOLE-2
+ 4 BOOLE-C1
+ 5 BOOLE-C2
+ 6 BOOLE-AND
+ 7 BOOLE-IOR
+ 8 BOOLE-XOR
+ 9 BOOLE-EQV
+ 10 BOOLE-NAND
+ 11 BOOLE-NOR
+ 12 BOOLE-ANDC1
+ 13 BOOLE-ANDC2
+ 14 BOOLE-ORC1
+ 15 BOOLE-ORC2"
(case op
(0 (boole 0 integer1 integer2))
(1 (boole 1 integer1 integer2))
(error 'simple-program-error
:format-control
"At least one of :INTERNAL, :EXTERNAL, or ~
- :INHERITED must be supplied."))
+ :INHERITED must be supplied."))
,(dolist (symbol symbol-types)
(unless (member symbol '(:internal :external :inherited))
(error 'program-error
*STANDARD-OUTPUT*) if it is a pretty-printing stream, and do
nothing if not. KIND can be one of:
:LINEAR - A line break is inserted if and only if the immediatly
- containing section cannot be printed on one line.
+ containing section cannot be printed on one line.
:MISER - Same as LINEAR, but only if ``miser-style'' is in effect.
- (See *PRINT-MISER-WIDTH*.)
+ (See *PRINT-MISER-WIDTH*.)
:FILL - A line break is inserted if and only if either:
(a) the following section cannot be printed on the end of the
- current line,
+ current line,
(b) the preceding section was not printed on a single line, or
(c) the immediately containing section cannot be printed on one
- line and miser-style is in effect.
+ line and miser-style is in effect.
:MANDATORY - A line break is always inserted.
When a line break is inserted by any type of conditional newline, any
blanks that immediately precede the conditional newline are ommitted
and do nothing if not. (See PPRINT-LOGICAL-BLOCK.) N is the indentation
to use (in ems, the width of an ``m'') and RELATIVE-TO can be either:
:BLOCK - Indent relative to the column the current logical block
- started on.
+ started on.
:CURRENT - Indent relative to the current column.
The new indentation value does not take effect until the following line
break."
#!+sb-doc
"Bind the reader and printer control variables to values that enable READ
to reliably read the results of PRINT. These values are:
- *PACKAGE* the COMMON-LISP-USER package
- *PRINT-ARRAY* T
- *PRINT-BASE* 10
- *PRINT-CASE* :UPCASE
- *PRINT-CIRCLE* NIL
- *PRINT-ESCAPE* T
- *PRINT-GENSYM* T
- *PRINT-LENGTH* NIL
- *PRINT-LEVEL* NIL
- *PRINT-LINES* NIL
- *PRINT-MISER-WIDTH* NIL
- *PRINT-PRETTY* NIL
- *PRINT-RADIX* NIL
- *PRINT-READABLY* T
- *PRINT-RIGHT-MARGIN* NIL
- *READ-BASE* 10
- *READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT
- *READ-EVAL* T
- *READ-SUPPRESS* NIL
- *READTABLE* the standard readtable"
+ *PACKAGE* the COMMON-LISP-USER package
+ *PRINT-ARRAY* T
+ *PRINT-BASE* 10
+ *PRINT-CASE* :UPCASE
+ *PRINT-CIRCLE* NIL
+ *PRINT-ESCAPE* T
+ *PRINT-GENSYM* T
+ *PRINT-LENGTH* NIL
+ *PRINT-LEVEL* NIL
+ *PRINT-LINES* NIL
+ *PRINT-MISER-WIDTH* NIL
+ *PRINT-PRETTY* NIL
+ *PRINT-RADIX* NIL
+ *PRINT-READABLY* T
+ *PRINT-RIGHT-MARGIN* NIL
+ *READ-BASE* 10
+ *READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT
+ *READ-EVAL* T
+ *READ-SUPPRESS* NIL
+ *READTABLE* the standard readtable"
`(%with-standard-io-syntax (lambda () ,@body)))
(defun %with-standard-io-syntax (function)
;; Someone forgot to initiate circularity detection.
(let ((*print-circle* nil))
(error "trying to use CHECK-FOR-CIRCULARITY when ~
- circularity checking isn't initiated")))
+ circularity checking isn't initiated")))
((t)
;; It's a second (or later) reference to the object while we are
;; just looking. So don't bother groveling it again.
(defun query-read-line ()
(force-output *query-io*)
- (string-trim #.(concatenate 'string '(#\Space #\Tab))
- (read-line *query-io*)))
+ (string-trim " " (read-line *query-io*)))
(defun maybe-print-query (hint format-string &rest format-args)
(fresh-line *query-io*)
(indentation (indenting-stream-indentation ,stream)))
((>= i indentation))
(%write-string
- " "
+ #.(make-string 60 :initial-element #\Space)
,sub-stream
0
(min 60 (- indentation i)))))
#!+sb-doc
"Return a stream that sends all output to the stream TARGET, but modifies
the case of letters, depending on KIND, which should be one of:
- :upcase - convert to upper case.
- :downcase - convert to lower case.
- :capitalize - convert the first letter of words to upper case and the
- rest of the word to lower case.
- :capitalize-first - convert the first letter of the first word to upper
- case and everything else to lower case."
+ :UPCASE - convert to upper case.
+ :DOWNCASE - convert to lower case.
+ :CAPITALIZE - convert the first letter of words to upper case and the
+ rest of the word to lower case.
+ :CAPITALIZE-FIRST - convert the first letter of the first word to upper
+ case and everything else to lower case."
(declare (type stream target)
(type (member :upcase :downcase :capitalize :capitalize-first)
kind)
way that the argument is passed.
:IN
- An :IN argument is simply passed by value. The value to be passed is
- obtained from argument(s) to the interface function. No values are
- returned for :In arguments. This is the default mode.
+ An :IN argument is simply passed by value. The value to be passed is
+ obtained from argument(s) to the interface function. No values are
+ returned for :In arguments. This is the default mode.
:OUT
- The specified argument type must be a pointer to a fixed sized object.
- A pointer to a preallocated object is passed to the routine, and the
- the object is accessed on return, with the value being returned from
- the interface function. :OUT and :IN-OUT cannot be used with pointers
- to arrays, records or functions.
+ The specified argument type must be a pointer to a fixed sized object.
+ A pointer to a preallocated object is passed to the routine, and the
+ the object is accessed on return, with the value being returned from
+ the interface function. :OUT and :IN-OUT cannot be used with pointers
+ to arrays, records or functions.
:COPY
- This is similar to :IN, except that the argument values are stored
+ This is similar to :IN, except that the argument values are stored
on the stack, and a pointer to the object is passed instead of
- the value itself.
+ the value itself.
:IN-OUT
- This is a combination of :OUT and :COPY. A pointer to the argument is
- passed, with the object being initialized from the supplied argument
+ This is a combination of :OUT and :COPY. A pointer to the argument is
+ passed, with the object being initialized from the supplied argument
and the return value being determined by accessing the object on
return."
(multiple-value-bind (lisp-name alien-name)
(setf args (nthcdr posn orig-args))
(error 'format-error
:complaint "Index ~W is out of bounds. (It should ~
- have been between 0 and ~W.)"
+ have been between 0 and ~W.)"
:args (list posn (length orig-args))))))
(if colonp
(interpret-bind-defaults ((n 1)) params
(error 'format-error
:complaint
"Index ~W is out of bounds. (It should
- have been between 0 and ~W.)"
+ have been between 0 and ~W.)"
:args
(list new-posn (length orig-args))))))))
(interpret-bind-defaults ((n 1)) params
(> (file-write-date src-tn) (file-write-date obj-tn)))
(restart-case
(error "The object file ~A is~@
- older than the presumed source:~% ~A."
+ older than the presumed source:~% ~A."
(namestring obj-tn)
(namestring src-tn))
;; FIXME: In CMU CL one of these was a CONTINUE case.
(print-unreadable-object (pathname stream :type t)
(format stream
"~@<(with no namestring) ~_:HOST ~S ~_:DEVICE ~S ~_:DIRECTORY ~S ~
- ~_:NAME ~S ~_:TYPE ~S ~_:VERSION ~S~:>"
+ ~_:NAME ~S ~_:TYPE ~S ~_:VERSION ~S~:>"
(%pathname-host pathname)
(%pathname-device pathname)
(%pathname-directory pathname)
:expected-type 'null
:format-control
"The host in the namestring, ~S,~@
- does not match the explicit HOST argument, ~S."
+ does not match the explicit HOST argument, ~S."
:format-arguments (list new-host host)))
(let ((pn-host (or new-host host (pathname-host defaults))))
(values (%make-maybe-logical-pathname
(let ((host (%pathname-host pathname)))
(unless host
(error "can't determine the namestring for pathnames with no ~
- host:~% ~S" pathname))
+ host:~% ~S" pathname))
(funcall (host-unparse host) pathname)))))
(defun host-namestring (pathname)
(setf in-wildcard t)
(unless subs
(error "not enough wildcards in FROM pattern to match ~
- TO pattern:~% ~S"
+ TO pattern:~% ~S"
pattern))
(let ((sub (pop subs)))
(typecase sub
(push sub strings))
(t
(error "can't substitute this into the middle of a word:~
- ~% ~S"
+ ~% ~S"
sub)))))))
(when strings
;;; Called when we can't see how source and from matched.
(defun didnt-match-error (source from)
(error "Pathname components from SOURCE and FROM args to TRANSLATE-PATHNAME~@
- did not match:~% ~S ~S"
+ did not match:~% ~S ~S"
source from))
;;; Do TRANSLATE-COMPONENT for all components except host, directory
(let ((match (pop subs-left)))
(when (listp match)
(error ":WILD-INFERIORS is not paired in from and to ~
- patterns:~% ~S ~S" from to))
+ patterns:~% ~S ~S" from to))
(res (maybe-diddle-case match diddle-case))))
((member :wild-inferiors)
(aver subs-left)
(let ((match (pop subs-left)))
(unless (listp match)
(error ":WILD-INFERIORS not paired in from and to ~
- patterns:~% ~S ~S" from to))
+ patterns:~% ~S ~S" from to))
(dolist (x match)
(res (maybe-diddle-case x diddle-case)))))
(pattern
(unless (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-))
(error 'namestring-parse-error
:complaint "logical namestring character which ~
- is not alphanumeric or hyphen:~% ~S"
+ is not alphanumeric or hyphen:~% ~S"
:args (list ch)
:namestring word :offset i))))
word))
(when (pattern)
(error 'namestring-parse-error
:complaint "double asterisk inside of logical ~
- word: ~S"
+ word: ~S"
:args (list chunk)
:namestring namestring
:offset (+ (cdar chunks) pos)))
(unless (and res (plusp res))
(error 'namestring-parse-error
:complaint "expected a positive integer, ~
- got ~S"
+ got ~S"
:args (list str)
:namestring namestr
:offset (+ pos (cdar chunks))))
(let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0)))
(format *trace-output*
"~&Evaluation took:~% ~
- ~S second~:P of real time~% ~
- ~S second~:P of user run time~% ~
- ~S second~:P of system run time~% ~
+ ~S second~:P of real time~% ~
+ ~S second~:P of user run time~% ~
+ ~S second~:P of system run time~% ~
~@[ [Run times include ~S second~:P GC run time.]~% ~]~
- ~S page fault~:P and~% ~
- ~:D bytes consed.~%"
+ ~S page fault~:P and~% ~
+ ~:D bytes consed.~%"
(max (/ (- new-real-time old-real-time)
(float sb!xc:internal-time-units-per-second))
0.0)
(declaim (type list *shebang-features*))
(defvar *shebang-backend-subfeatures*)
\f
+;;;; string checker, for catching non-portability early
+(defun make-quote-reader (standard-quote-reader)
+ (lambda (stream char)
+ (let ((result (funcall standard-quote-reader stream char)))
+ (unless (every (lambda (x) (typep x 'standard-char)) result)
+ (warn "Found non-STANDARD-CHAR in ~S" result))
+ result)))
+(compile 'make-quote-reader)
+
+(set-macro-character #\" (make-quote-reader (get-macro-character #\" nil)))
+\f
;;;; FIXME: Would it be worth implementing this?
#|
;;;; readmacro syntax to remove spaces from FORMAT strings at compile time
((:maybe)
(give-up-ir1-transform
"The array type is ambiguous; must call ~
- ARRAY-HAS-FILL-POINTER-P at runtime.")))))))
+ ARRAY-HAS-FILL-POINTER-P at runtime.")))))))
;;; Primitive used to verify indices into arrays. If we can tell at
;;; compile-time or we are generating unsafe code, don't bother with
(when (< (find-alignment additional-delta)
(chooser-alignment note))
(error "~S shrunk by ~W bytes, but claimed that it ~
- preserves ~W bits of alignment."
+ preserves ~W bits of alignment."
note additional-delta (chooser-alignment note)))
(incf delta additional-delta)
(emit-filler segment additional-delta))
(additional-delta (- old-size size)))
(when (minusp additional-delta)
(error "Alignment ~S needs more space now? It was ~W, ~
- and is ~W now."
+ and is ~W now."
note old-size size))
(when (plusp additional-delta)
(emit-filler segment additional-delta)
(arg (gensym (format nil "~:@(ARG-FOR-~S-~)" byte-spec-expr))))
(when (ldb-test (byte byte-size byte-posn) overall-mask)
(error "The byte spec ~S either overlaps another byte spec, or ~
- extends past the end."
+ extends past the end."
byte-spec-expr))
(setf (ldb byte-spec overall-mask) -1)
(arg-names arg)
(setf (segment-postits ,segment-name) nil)
(macrolet ((%%current-segment%% ()
(error "You can't use INST without an ~
- ASSEMBLE inside emitters.")))
+ ASSEMBLE inside emitters.")))
;; KLUDGE: Some host lisps (CMUCL 18e Sparc at least)
;; can't deal with this declaration, so disable it on host
;; Ditto for earlier ENABLE-PACKAGE-LOCKS %%C-S%% %%C-V%%
name)
*backend-support-routines*)
(error "machine-specific support ~S ~
- routine undefined"
+ routine undefined"
',name))
args)))
routines))))
(multiple-value-bind (res win) (ctypep val type)
(cond ((not win)
(note-unwinnage "can't tell whether the ~:R argument is a ~
- constant ~S:~% ~S"
+ constant ~S:~% ~S"
n (type-specifier type) val)
nil)
((not res)
((not (check-arg-type k (specifier-type 'symbol) n)))
((not (constant-lvar-p k))
(note-unwinnage "The ~:R argument (in keyword position) is not a ~
- constant."
+ constant."
n))
(t
(let* ((name (lvar-value k))
((eq int *empty-type*)
(note-lossage
"Definition's declared type for variable ~A:~% ~S~@
- conflicts with this type from ~A:~% ~S"
+ conflicts with this type from ~A:~% ~S"
(leaf-debug-name var) (type-specifier vtype)
where (type-specifier type))
(return-from try-type-intersections (values nil nil)))
(unless (eq x y)
(note-lossage
"The definition ~:[doesn't have~;has~] ~A, but ~
- ~A ~:[doesn't~;does~]."
+ ~A ~:[doesn't~;does~]."
x what where y))))
(frob (optional-dispatch-keyp od) (fun-type-keyp type)
"&KEY arguments")
type-returns)))
(note-lossage
"The result type from ~A:~% ~S~@
- conflicts with the definition's result type:~% ~S"
+ conflicts with the definition's result type:~% ~S"
where (type-specifier type-returns) (type-specifier dtype))
nil)
(*lossage-detected* nil)
(not (csubtypep (leaf-type var) type)))
(funcall unwinnage-fun
"Assignment to argument: ~S~% ~
- prevents use of assertion from function ~
- type ~A:~% ~S~%"
+ prevents use of assertion from function ~
+ type ~A:~% ~S~%"
(leaf-debug-name var)
where
(type-specifier type))))
;; can get them from the table rather than dumping them again. The
;; EQUAL-TABLE is used for lists and strings, and the EQ-TABLE is
;; used for everything else. We use a separate EQ table to avoid
- ;; performance patholigies with objects for which EQUAL degnerates
+ ;; performance pathologies with objects for which EQUAL degenerates
;; to EQL. Everything entered in the EQUAL table is also entered in
;; the EQ table.
(equal-table (make-hash-table :test 'equal) :type hash-table)
;; character code.
(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)))
+ (let ((*print-readably* nil)
+ (*print-pretty* nil))
+ (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)
(if (subsetp headers *fun-header-widetags*)
t
(error "can't test for mix of function subtypes ~
- and normal header types"))
+ and normal header types"))
nil)))
(unless type-codes
(error "At least one type must be supplied for TEST-TYPE."))
;;; a magic number used to identify our core files
(defconstant core-magic
- (logior (ash (char-code #\S) 24)
- (ash (char-code #\B) 16)
- (ash (char-code #\C) 8)
- (char-code #\L)))
+ (logior (ash (sb!xc:char-code #\S) 24)
+ (ash (sb!xc:char-code #\B) 16)
+ (ash (sb!xc:char-code #\C) 8)
+ (sb!xc:char-code #\L)))
;;; the current version of SBCL core files
;;;
(make-fixnum-descriptor length))
(dotimes (i length)
(setf (bvref bytes (+ offset i))
- ;; KLUDGE: There's no guarantee that the character
- ;; encoding here will be the same as the character
- ;; encoding on the target machine, so using CHAR-CODE as
- ;; we do, or a bitwise copy as CMU CL code did, is sleazy.
- ;; (To make this more portable, perhaps we could use
- ;; indices into the sequence which is used to test whether
- ;; a character is a STANDARD-CHAR?) -- WHN 19990817
- (char-code (aref string i))))
+ (sb!xc:char-code (aref string i))))
(setf (bvref bytes (+ offset length))
0) ; null string-termination character for C
des))
(depthoid (descriptor-fixnum depthoid-des)))
(unless (= length old-length)
(error "cold loading a reference to class ~S when the compile~%~
- time length was ~S and current length is ~S"
+ time length was ~S and current length is ~S"
name
length
old-length))
(unless (equal inherits-list old-inherits-list)
(error "cold loading a reference to class ~S when the compile~%~
- time inherits were ~S~%~
- and current inherits are ~S"
+ time inherits were ~S~%~
+ and current inherits are ~S"
name
inherits-list
old-inherits-list))
(unless (= depthoid old-depthoid)
(error "cold loading a reference to class ~S when the compile~%~
- time inheritance depthoid was ~S and current inheritance~%~
- depthoid is ~S"
+ time inheritance depthoid was ~S and current inheritance~%~
+ depthoid is ~S"
name
depthoid
old-depthoid)))
;; (We write each character as a word in order to avoid
;; having to think about word alignment issues in the
;; sbcl-0.7.8 version of coreparse.c.)
- (write-word (char-code char))))
+ (write-word (sb!xc:char-code char))))
;; Write the New Directory entry header.
(write-word new-directory-core-entry-type-code)
(length bit-array-2)
(length result-bit-array))
(error "Argument and/or result bit arrays are not the same length:~
- ~% ~S~% ~S ~% ~S"
+ ~% ~S~% ~S ~% ~S"
bit-array-1
bit-array-2
result-bit-array))))
'((unless (= (length bit-array)
(length result-bit-array))
(error "Argument and result bit arrays are not the same length:~
- ~% ~S~% ~S"
+ ~% ~S~% ~S"
bit-array result-bit-array))))
(let ((length (length result-bit-array)))
(if (= length 0)
(let ((*compiler-error-context* (lambda-bind (first funs))))
(compiler-notify
"Return value count mismatch prevents known return ~
- from these functions:~
- ~{~% ~A~}"
+ from these functions:~
+ ~{~% ~A~}"
(mapcar #'leaf-source-name
(remove-if-not #'leaf-has-source-name-p funs)))))
(let ((ret (lambda-return fun)))
(let ((*compiler-error-context* (lambda-bind fun)))
(compiler-notify
"Return type not fixed values, so can't use known return ~
- convention:~% ~S"
+ convention:~% ~S"
(type-specifier rtype)))
(return)))))))))
(values))
(if (template-more-args-type template)
(when (< nargs min)
(bug "Primitive ~A was called with ~R argument~:P, ~
- but wants at least ~R."
+ but wants at least ~R."
name
nargs
min))
(compiler-notify "~@<unable to ~
~2I~_~A ~
~I~_due to type uncertainty: ~
- ~2I~_~{~?~^~@:_~}~:>"
+ ~2I~_~{~?~^~@:_~}~:>"
note (messages))))
;; As best I can guess, it's OK to fall off the end here
;; because if it's not a VALID-FUNCTION-USE, the user
(let ((*compiler-error-context* node))
(compiler-warn
"New inferred type ~S conflicts with old type:~
- ~% ~S~%*** possible internal error? Please report this."
+ ~% ~S~%*** possible internal error? Please report this."
(type-specifier rtype) (type-specifier node-type))))
(setf (node-derived-type node) int)
;; If the new type consists of only one object, replace the
(when (and min (< total-nvals min))
(compiler-warn
"MULTIPLE-VALUE-CALL with ~R values when the function expects ~
- at least ~R."
+ at least ~R."
total-nvals min)
(setf (basic-combination-kind node) :error)
(return-from ir1-optimize-mv-call))
(when (and max (> total-nvals max))
(compiler-warn
"MULTIPLE-VALUE-CALL with ~R values when the function expects ~
- at most ~R."
+ at most ~R."
total-nvals max)
(setf (basic-combination-kind node) :error)
(return-from ir1-optimize-mv-call)))
(functional
(when (policy *lexenv* (>= speed inhibit-warnings))
(compiler-notify "ignoring ~A declaration not at ~
- definition of local function:~% ~S"
+ definition of local function:~% ~S"
sense name)))
(global-var
(push (cons name (make-new-inlinep found sense))
;; arbitrarily huge blocks of code. -- WHN)
(let ((*compiler-error-context* node))
(compiler-notify "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~
- probably trying to~% ~
- inline a recursive function."
+ probably trying to~% ~
+ inline a recursive function."
*inline-expansion-limit*))
nil)
(t t))))
(cond (losing-local-functional
(let ((*compiler-error-context* call))
(compiler-notify "couldn't inline expand because expansion ~
- calls this LET-converted local function:~
- ~% ~S"
+ calls this LET-converted local function:~
+ ~% ~S"
(leaf-debug-name losing-local-functional)))
(loop for block = (block-next pred) then (block-next block)
until (eq block end)
(when (optional-dispatch-keyp fun)
(when (oddp (length more))
(compiler-warn "function called with odd number of ~
- arguments in keyword portion")
-
+ arguments in keyword portion")
(setf (basic-combination-kind call) :error)
(return-from convert-more-call))
is intended to be wrapped around the compilation of all files in the same
system. These keywords are defined:
:OVERRIDE Boolean-Form
- One of the effects of this form is to delay undefined warnings
- until the end of the form, instead of giving them at the end of each
- compilation. If OVERRIDE is NIL (the default), then the outermost
- WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying
- OVERRIDE true causes that form to grab any enclosed warnings, even if
- it is enclosed by another WITH-COMPILATION-UNIT."
+ One of the effects of this form is to delay undefined warnings
+ until the end of the form, instead of giving them at the end of each
+ compilation. If OVERRIDE is NIL (the default), then the outermost
+ WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying
+ OVERRIDE true causes that form to grab any enclosed warnings, even if
+ it is enclosed by another WITH-COMPILATION-UNIT."
`(%with-compilation-unit (lambda () ,@body) ,@options))
(defun %with-compilation-unit (fn &key override)
(when summary
(if (eq kind :variable)
(compiler-warn
- "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
- ~% ~{~<~% ~1:;~S~>~^ ~}"
+ "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
+ ~% ~{~<~% ~1:;~S~>~^ ~}"
(cdr summary) kind summary)
(compiler-style-warn
- "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
- ~% ~{~<~% ~1:;~S~>~^ ~}"
+ "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
+ ~% ~{~<~% ~1:;~S~>~^ ~}"
(cdr summary) kind summary))))))))
(unless (and (not abort-p)
(rassoc name (funs)))))
(unless name
(error "no move function defined to ~:[save~;load~] SC ~S ~
- ~:[to~;from~] from SC ~S"
+ ~:[to~;from~] from SC ~S"
load-p sc-name load-p (sc-name alt)))
(cond (found
(unless (eq (cdr found) name)
(error "can't tell whether to ~:[save~;load~]~@
- with ~S or ~S when operand is in SC ~S"
+ with ~S or ~S when operand is in SC ~S"
load-p name (cdr found) (sc-name alt)))
(pushnew alt (car found)))
(t
((member (sb-kind (sc-sb sc)) '(:non-packed :unbounded)))
(t
(error "SC ~S has no alternate~:[~; or constant~] SCs, yet it is~@
- mentioned in the restriction for operand ~S"
+ mentioned in the restriction for operand ~S"
sc-name load-p (operand-parse-name op))))))
(funs)))
,form)))
`(when ,load-tn
(error "load TN allocated, but no move function?~@
- VM definition is inconsistent, recompile and try again.")))))
+ VM definition is inconsistent, recompile and try again.")))))
;;; Return the TN that we should bind to the operand's var in the
;;; generator body. In general, this involves evaluating the :LOAD-IF
(aref (sc-load-costs op-sc) load-scn))))
(unless load
(error "no move function defined to move ~:[from~;to~] SC ~
- ~S~%~:[to~;from~] alternate or constant SC ~S"
+ ~S~%~:[to~;from~] alternate or constant SC ~S"
load-p sc-name load-p (sc-name op-sc)))
(let ((op-cost (svref costs op-scn)))
(let ((alias (parse-operand-type alias)))
(unless (eq (car alias) :or)
(error "can't include primitive-type ~
- alias ~S in an :OR restriction: ~S"
+ alias ~S in an :OR restriction: ~S"
item spec))
(dolist (x (cdr alias))
(results x)))
nil)
(when (svref load-scs rep) (return t)))
(error "In the ~A ~:[result~;argument~] to VOP ~S,~@
- none of the SCs allowed by the operand type ~S can ~
- directly be loaded~@
- into any of the restriction's SCs:~% ~S~:[~;~@
- [* type operand must allow T's SCs.]~]"
+ none of the SCs allowed by the operand type ~S can ~
+ directly be loaded~@
+ into any of the restriction's SCs:~% ~S~:[~;~@
+ [* type operand must allow T's SCs.]~]"
(operand-parse-name op) load-p (vop-parse-name parse)
ptype
scs (eq type '*)))))
(meta-primitive-type-or-lose ptype))
(return t))))
(warn "~:[Result~;Argument~] ~A to VOP ~S~@
- has SC restriction ~S which is ~
- not allowed by the operand type:~% ~S"
+ has SC restriction ~S which is ~
+ not allowed by the operand type:~% ~S"
load-p (operand-parse-name op) (vop-parse-name parse)
sc type)))))
(cond ((eq (sb-kind (sc-sb src-sc)) :non-packed)
(unless (member src-sc (sc-constant-scs dest-sc))
(error "loading from an invalid constant SC?~@
- VM definition inconsistent, try recompiling."))
+ VM definition inconsistent, try recompiling."))
(error "no load function defined to load SC ~S ~
- from its constant SC ~S"
+ from its constant SC ~S"
dest-name src-name))
((member src-sc (sc-alternate-scs dest-sc))
(error "no load function defined to load SC ~S from its ~
- alternate SC ~S"
+ alternate SC ~S"
dest-name src-name))
((member dest-sc (sc-alternate-scs src-sc))
(error "no load function defined to save SC ~S in its ~
- alternate SC ~S"
+ alternate SC ~S"
src-name dest-name))
(t
;; FIXME: "VM definition is inconsistent" shouldn't be a
;; possibility in SBCL.
(error "loading to/from SCs that aren't alternates?~@
- VM definition is inconsistent, try recompiling.")))))
+ VM definition is inconsistent, try recompiling.")))))
;;; Called when we failed to pack TN. If RESTRICTED is true, then we
;;; are restricted to pack TN in its SC.
(ptype
(aver (member (sc-number sc) (primitive-type-scs ptype)))
(error "SC ~S doesn't have any :UNBOUNDED alternate SCs, but is~@
- a SC for primitive-type ~S."
+ a SC for primitive-type ~S."
(sc-name sc) (primitive-type-name ptype)))
(t
(error "SC ~S doesn't have any :UNBOUNDED alternate SCs."
(declare (ignore costs load-scs))
(aver (not more-p))
(error "unable to pack a Load-TN in SC ~{~A~#[~^~;, or ~:;,~]~} ~
- for the ~:R ~:[result~;argument~] to~@
- the ~S VOP,~@
- ~:[since all SC elements are in use:~:{~%~@?~}~%~;~
- ~:*but these SC elements are not in use:~% ~S~%Bug?~*~]~
- ~:[~;~@
- Current cost info inconsistent with that in effect at compile ~
- time. Recompile.~%Compilation order may be incorrect.~]"
+ for the ~:R ~:[result~;argument~] to~@
+ the ~S VOP,~@
+ ~:[since all SC elements are in use:~:{~%~@?~}~%~;~
+ ~:*but these SC elements are not in use:~% ~S~%Bug?~*~]~
+ ~:[~;~@
+ Current cost info inconsistent with that in effect at compile ~
+ time. Recompile.~%Compilation order may be incorrect.~]"
(mapcar #'sc-name scs)
n arg-p
(vop-info-name (vop-info (tn-ref-vop op)))
(declare (ignore costs))
(aver (not more-p))
(error "~S is not valid as the ~:R ~:[result~;argument~] to VOP:~
- ~% ~S,~@
- since the TN's primitive type ~S doesn't allow any of the SCs~@
- allowed by the operand restriction:~% ~S~
- ~:[~;~@
- Current cost info inconsistent with that in effect at compile ~
- time. Recompile.~%Compilation order may be incorrect.~]"
+ ~% ~S,~@
+ since the TN's primitive type ~S doesn't allow any of the SCs~@
+ allowed by the operand restriction:~% ~S~
+ ~:[~;~@
+ Current cost info inconsistent with that in effect at compile ~
+ time. Recompile.~%Compilation order may be incorrect.~]"
tn pos arg-p
(template-name (vop-info (tn-ref-vop ref)))
(primitive-type-name ptype)
(when (and (not (eq (tn-kind tn) :specified-save))
(conflicts-in-sc original sc offset))
(format t "~&* Pack-wired-tn possible conflict:~% ~
- tn: ~S; tn-kind: ~S~% ~
- sc: ~S~% ~
- sb: ~S; sb-name: ~S; sb-kind: ~S~% ~
- offset: ~S; end: ~S~% ~
- original ~S~% ~
- tn-save-tn: ~S; tn-kind of tn-save-tn: ~S~%"
+ tn: ~S; tn-kind: ~S~% ~
+ sc: ~S~% ~
+ sb: ~S; sb-name: ~S; sb-kind: ~S~% ~
+ offset: ~S; end: ~S~% ~
+ original ~S~% ~
+ tn-save-tn: ~S; tn-kind of tn-save-tn: ~S~%"
tn (tn-kind tn) sc
sb (sb-name sb) (sb-kind sb)
offset end
(unless (losers)
(error "Representation selection flamed out for no obvious reason.~@
- Try again after recompiling the VM definition."))
+ Try again after recompiling the VM definition."))
(error "~S is not valid as the ~:R ~:[result~;argument~] to the~@
- ~S VOP, since the TN's primitive type ~S allows SCs:~% ~S~@
- ~:[which cannot be coerced or loaded into the allowed SCs:~
- ~% ~S~;~*~]~:[~;~@
- Current cost info inconsistent with that in effect at compile ~
- time. Recompile.~%Compilation order may be incorrect.~]"
+ ~S VOP, since the TN's primitive type ~S allows SCs:~% ~S~@
+ ~:[which cannot be coerced or loaded into the allowed SCs:~
+ ~% ~S~;~*~]~:[~;~@
+ Current cost info inconsistent with that in effect at compile ~
+ time. Recompile.~%Compilation order may be incorrect.~]"
tn pos arg-p
(template-name (vop-info (tn-ref-vop ref)))
(primitive-type-name ptype)
(no-move-scs i-sc))))
(t
(error "Representation selection flamed out for no ~
- obvious reason."))))))
+ obvious reason."))))))
(unless (or (load-lose) (no-move-scs) (move-lose))
(error "Representation selection flamed out for no obvious reason.~@
- Try again after recompiling the VM definition."))
+ Try again after recompiling the VM definition."))
(error "~S is not valid as the ~:R ~:[result~;argument~] to VOP:~
- ~% ~S~%Primitive type: ~S~@
- SC restrictions:~% ~S~@
- ~@[The primitive type disallows these loadable SCs:~% ~S~%~]~
- ~@[No move VOPs are defined to coerce to these allowed SCs:~
- ~% ~S~%~]~
- ~@[These move VOPs couldn't be used due to operand type ~
- restrictions:~% ~S~%~]~
- ~:[~;~@
- Current cost info inconsistent with that in effect at compile ~
- time. Recompile.~%Compilation order may be incorrect.~]"
+ ~% ~S~%Primitive type: ~S~@
+ SC restrictions:~% ~S~@
+ ~@[The primitive type disallows these loadable SCs:~% ~S~%~]~
+ ~@[No move VOPs are defined to coerce to these allowed SCs:~
+ ~% ~S~%~]~
+ ~@[These move VOPs couldn't be used due to operand type ~
+ restrictions:~% ~S~%~]~
+ ~:[~;~@
+ Current cost info inconsistent with that in effect at compile ~
+ time. Recompile.~%Compilation order may be incorrect.~]"
op-tn pos arg-p
(template-name (vop-info (tn-ref-vop op)))
(primitive-type-name ptype)
(defun bad-move-arg-error (val pass)
(declare (type tn val pass))
(error "no :MOVE-ARG VOP defined to move ~S (SC ~S) to ~
- ~S (SC ~S)"
+ ~S (SC ~S)"
val (sc-name (tn-sc val))
pass (sc-name (tn-sc pass))))
\f
(dolist (const (sc-constant-scs sc))
(unless (svref moves (sc-number const))
(warn "no move function defined to load SC ~S from constant ~
- SC ~S"
+ SC ~S"
(sc-name sc) (sc-name const))))
(dolist (alt (sc-alternate-scs sc))
(unless (svref moves (sc-number alt))
(warn "no move function defined to load SC ~S from alternate ~
- SC ~S"
+ SC ~S"
(sc-name sc) (sc-name alt)))
(unless (svref (sc-move-funs alt) i)
(warn "no move function defined to save SC ~S to alternate ~
- SC ~S"
+ SC ~S"
(sc-name sc) (sc-name alt)))))))))
\f
;;;; representation selection
(error "couldn't find op? bug!")))))
(compiler-notify
"doing ~A (cost ~W)~:[~2*~; ~:[to~;from~] ~S~], for:~%~6T~
- the ~:R ~:[result~;argument~] of ~A"
+ the ~:R ~:[result~;argument~] of ~A"
note cost name arg-p name
pos arg-p op-note)))
(t
(file-position f char-offset))
(t
(warn "Source file ~S has been modified; ~@
- using form offset instead of ~
+ using form offset instead of ~
file index."
name)
(let ((*read-suppress* t))
nil)
((> form-number (length mapping-table))
(warn "bogus form-number in form! The source file has probably ~@
- been changed too much to cope with.")
+ been changed too much to cope with.")
(when cache
;; Disable future warnings.
(setf (sfcache-toplevel-form cache) nil))
;; If not properly named, error.
((not (and name (eq (find-classoid name) class)))
(compiler-error "can't compile TYPEP of anonymous or undefined ~
- class:~% ~S"
+ class:~% ~S"
class))
(t
;; Delay the type transform to give type propagation a chance.
(defun walk-template-handle-repeat (form template stop-form context env)
(if (eq form stop-form)
(walk-template form (cdr template) context env)
- (walk-template-handle-repeat-1 form
- template
- (car template)
- stop-form
- context
- env)))
+ (walk-template-handle-repeat-1
+ form template (car template) stop-form context env)))
(defun walk-template-handle-repeat-1 (form template repeat-template
stop-form context env)
(if (null repeat-template)
(walk-template stop-form (cdr template) context env)
(error "while handling code walker REPEAT:
- ~%ran into STOP while still in REPEAT template")))
+ ~%ran into STOP while still in REPEAT template")))
((null repeat-template)
(walk-template-handle-repeat-1
form template (car template) stop-form context env))
(parse-namestring "SCRATCH:FOO.TXT.NEWEST")
(parse-namestring "SCRATCH:FOO.TXT"))))
(dolist (p pathnames)
+ (print p)
(handler-case
(let ((*print-readably* t))
(assert (equal (read-from-string (format nil "~S" p)) p)))
;;; Function COUNT, COUNT-IF, COUNT-IF-NOT
(sequence-bounding-indices-test
- (format t "~&/Function COUNT, COUNT-IF, COUNT-IF-NOT")
+ (format t "~&/Function COUNT, COUNT-IF, COUNT-IF-NOT")
(assert (= (count #\a string :start 0 :end nil) 5))
(assert (= (count #\a string :start 0 :end 5) 5))
(assert (raises-error? (count #\a string :start 0 :end 6)))
;;; Function FILL
(sequence-bounding-indices-test
- (format t "~&/Function FILL~%")
+ (format t "~&/Function FILL")
(assert (string= (fill string #\b :start 0 :end 5) "bbbbb"))
(assert (string= (fill string #\c :start 0 :end nil) "ccccc"))
(assert (raises-error? (fill string #\d :start 0 :end 6)))
;;; Function FIND, FIND-IF, FIND-IF-NOT
(sequence-bounding-indices-test
- (format t "~&/Function FIND, FIND-IF, FIND-IF-NOT~%")
+ (format t "~&/Function FIND, FIND-IF, FIND-IF-NOT")
(assert (char= (find #\a string :start 0 :end nil) #\a))
(assert (char= (find #\a string :start 0 :end 5) #\a))
(assert (raises-error? (find #\a string :start 0 :end 6)))
;;; Function MISMATCH
(sequence-bounding-indices-test
- (format t "~&/Function MISMATCH~%")
+ (format t "~&/Function MISMATCH")
(assert (null (mismatch string "aaaaa" :start1 0 :end1 nil)))
(assert (= (mismatch "aaab" string :start2 0 :end2 4) 3))
(assert (raises-error? (mismatch "aaaaaa" string :start2 0 :end2 6)))
;;; Function PARSE-INTEGER
(sequence-bounding-indices-test
- (format t "~&/Function PARSE-INTEGER~%")
+ (format t "~&/Function PARSE-INTEGER")
(setf (fill-pointer string) 10)
(setf (subseq string 0 10) "1234567890")
(setf (fill-pointer string) 5)
;;; Function PARSE-NAMESTRING
(sequence-bounding-indices-test
- (format t "~&/Function PARSE-NAMESTRING~%")
+ (format t "~&/Function PARSE-NAMESTRING")
(setf (fill-pointer string) 10)
(setf (subseq string 0 10) "/dev/ /tmp")
(setf (fill-pointer string) 5)
;;; Function POSITION, POSITION-IF, POSITION-IF-NOT
(sequence-bounding-indices-test
- (format t "~&/Function POSITION, POSITION-IF, POSITION-IF-NOT~%")
+ (format t "~&/Function POSITION, POSITION-IF, POSITION-IF-NOT")
+
(assert (= (position #\a string :start 0 :end nil) 0))
(assert (= (position #\a string :start 0 :end 5) 0))
(assert (raises-error? (position #\a string :start 0 :end 6)))
;;; Function READ-FROM-STRING
(sequence-bounding-indices-test
- (format t "~&/Function READ-FROM-STRING~%")
+ (format t "~&/Function READ-FROM-STRING")
(setf (subseq string 0 5) "(a b)")
(assert (equal (read-from-string string nil nil :start 0 :end 5) '(a b)))
(assert (equal (read-from-string string nil nil :start 0 :end nil) '(a b)))
;;; Function REDUCE
(sequence-bounding-indices-test
- (format t "~&/Function REDUCE~%")
+ (format t "~&/Function REDUCE")
(setf (subseq string 0 5) "abcde")
(assert (equal (reduce #'list* string :from-end t :start 0 :end nil)
'(#\a #\b #\c #\d . #\e)))
;;; Function REMOVE, REMOVE-IF, REMOVE-IF-NOT, DELETE, DELETE-IF,
;;; DELETE-IF-NOT
(sequence-bounding-indices-test
- (format t "~&/Function REMOVE, REMOVE-IF, REMOVE-IF-NOT, ...~%")
+ (format t "~&/Function REMOVE, REMOVE-IF, REMOVE-IF-NOT, ...")
(assert (equal (remove #\a string :start 0 :end nil) ""))
(assert (equal (remove #\a string :start 0 :end 5) ""))
(assert (raises-error? (remove #\a string :start 0 :end 6)))
(assert (raises-error?
(remove-if-not #'alpha-char-p string :start 6 :end 9))))
(sequence-bounding-indices-test
- (format t "~&/... DELETE, DELETE-IF, DELETE-IF-NOT")
+ (format t "~&/... DELETE, DELETE-IF, DELETE-IF-NOT")
(assert (equal (delete #\a string :start 0 :end nil) ""))
(reset)
(assert (equal (delete #\a string :start 0 :end 5) ""))
;;; Function REMOVE-DUPLICATES, DELETE-DUPLICATES
(sequence-bounding-indices-test
- (format t "~&/Function REMOVE-DUPLICATES, DELETE-DUPLICATES~%")
+ (format t "~&/Function REMOVE-DUPLICATES, DELETE-DUPLICATES")
(assert (string= (remove-duplicates string :start 0 :end 5) "a"))
(assert (string= (remove-duplicates string :start 0 :end nil) "a"))
(assert (raises-error? (remove-duplicates string :start 0 :end 6)))
;;; Function REPLACE
(sequence-bounding-indices-test
- (format t "~&/Function REPLACE~%")
+ (format t "~&/Function REPLACE")
(assert (string= (replace string "bbbbb" :start1 0 :end1 5) "bbbbb"))
(assert (string= (replace (copy-seq "ccccc")
string
;;; Function SEARCH
(sequence-bounding-indices-test
- (format t "~&/Function SEARCH~%")
+ (format t "~&/Function SEARCH")
(assert (= (search "aa" string :start2 0 :end2 5) 0))
(assert (null (search string "aa" :start1 0 :end2 nil)))
(assert (raises-error? (search "aa" string :start2 0 :end2 6)))
(assert (raises-error? (,fn string :start 6 :end 9)))))
(sequence-bounding-indices-test
- (format t "~&/Function STRING-UPCASE, STRING-DOWNCASE, STRING-CAPITALIZE, ...~%")
+ (format t "~&/Function STRING-UPCASE, STRING-DOWNCASE, STRING-CAPITALIZE, ...")
(string-case-frob string-upcase)
(string-case-frob string-downcase)
(string-case-frob string-capitalize)
- (format t "~&/... NSTRING-UPCASE, NSTRING-DOWNCASE, NSTRING-CAPITALIZE~%")
+ (format t "~&/... NSTRING-UPCASE, NSTRING-DOWNCASE, NSTRING-CAPITALIZE")
(string-case-frob nstring-upcase)
(string-case-frob nstring-downcase)
(string-case-frob nstring-capitalize))
(string-predicate-frob string<=)
(string-predicate-frob string>=))
(sequence-bounding-indices-test
- (format t "~&/... STRING-EQUAL, STRING-NOT-EQUAL, STRING-LESSP, ...~%")
+ (format t "~&/... STRING-EQUAL, STRING-NOT-EQUAL, STRING-LESSP, ...")
(string-predicate-frob string-equal)
(string-predicate-frob string-not-equal)
(string-predicate-frob string-lessp))
(sequence-bounding-indices-test
- (format t "~&/... STRING-GREATERP, STRING-NOT-GREATERP, STRING-NOT-LESSP~%")
+ (format t "~&/... STRING-GREATERP, STRING-NOT-GREATERP, STRING-NOT-LESSP")
(string-predicate-frob string-greaterp)
(string-predicate-frob string-not-greaterp)
(string-predicate-frob string-not-lessp))
;;; Function SUBSTITUTE, SUBSTITUTE-IF, SUBSTITUTE-IF-NOT,
;;; NSUBSTITUTE, NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT
(sequence-bounding-indices-test
- (format t "~&/Function SUBSTITUTE, SUBSTITUTE-IF, SUBSTITUTE-IF-NOT, ...~%")
+ (format t "~&/Function SUBSTITUTE, SUBSTITUTE-IF, SUBSTITUTE-IF-NOT, ...")
(assert (string= (substitute #\b #\a string :start 0 :end 5) "bbbbb"))
(assert (string= (substitute #\c #\a string :start 0 :end nil)
"ccccc"))
(assert (raises-error? (substitute-if-not #\b #'alpha-char-p string
:start 6 :end 9))))
(sequence-bounding-indices-test
- (format t "~&/... NSUBSTITUTE, NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT~%")
+ (format t "~&/... NSUBSTITUTE, NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT")
(assert (string= (nsubstitute #\b #\a string :start 0 :end 5) "bbbbb"))
(reset)
(assert (string= (nsubstitute #\c #\a string :start 0 :end nil)
:start 6 :end 9))))
;;; Function WRITE-STRING, WRITE-LINE
(sequence-bounding-indices-test
- (format t "~&/Function WRITE-STRING, WRITE-LINE~%")
+ (format t "~&/Function WRITE-STRING, WRITE-LINE")
(write-string string *standard-output* :start 0 :end 5)
(write-string string *standard-output* :start 0 :end nil)
(assert (raises-error? (write-string string *standard-output*
;;; Macro WITH-INPUT-FROM-STRING
(sequence-bounding-indices-test
- (format t "~&/Macro WITH-INPUT-FROM-STRING~%")
+ (format t "~&/Macro WITH-INPUT-FROM-STRING")
(with-input-from-string (s string :start 0 :end 5)
(assert (char= (read-char s) #\a)))
(with-input-from-string (s string :start 0 :end nil)
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.16.5"
+"0.8.16.6"
projects / sbcl.git / commitdiff