Untabification
... tabs in source code in general are Evil Bad and Wrong, but in
strings they are especially so in the context of portable
ANSI Common Lisp, since #\Tab is not a standard character.
... remove all tabs in strings in the source code, and write some
defensive code to prevent them from creeping back in again.
... one or two other whitespacey changes.
(this patch was brought to you by character_branch)
53 files changed:
(fill array initial-element))
(when initial-contents-p
(when initial-element-p
(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.
(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 ~
(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))
(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
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
(let ((data (if initial-element-p
(make-array total-size
:element-type element-type
(incf index))
(t
(unless (typep contents 'sequence)
(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))
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)
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)
(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
(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
(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)))
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 ~
(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 ~
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 ~
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)
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 ~
#!+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))
(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:~% ~
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)
name
old-context
(map 'list #'layout-proper-name old-inherits)
(when diff
(warn
"in class ~S:~% ~
(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))
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:~% ~
(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~% ~
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))))
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~@
;; 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))
(layout-proper-name layout)))
(values))
(char ascii-standard-chars (- x 32))))
(defun sb!xc:char-code (character)
(declare (type standard-char character))
(char ascii-standard-chars (- x 32))))
(defun sb!xc:char-code (character)
(declare (type standard-char character))
(if (char= character #\Newline)
10
(+ (position character ascii-standard-chars) 32))))
(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 ~
(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)
fun)))))
(define-condition no-debug-blocks (debug-condition)
(compiled-debug-fun-compiler-debug-fun what))
:standard)
(error ":FUN-END breakpoints are currently unsupported ~
(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)))
(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 ~
;; and output on T seems broken.
(format t
"~&error flushed (because ~
'*flush-debug-errors*)
(/show0 "throwing DEBUG-LOOP-CATCHER")
(throw 'debug-loop-catcher nil)))))
'*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 ~]~
(cond
((not any-p)
(format t "There are no local variables ~@[starting with ~A ~]~
prefix))
((not any-valid-p)
(format t "All variables ~@[starting with ~A ~]currently ~
prefix))
((not any-valid-p)
(format t "All variables ~@[starting with ~A ~]currently ~
prefix))))
(write-line "There is no variable information available."))))
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~@
(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))
(namestring name))
(file-position *cached-source-stream* 0)
(let ((*read-suppress* t))
binding
:test #'eq))
(warn "Unnamed restart does not have a ~
binding
:test #'eq))
(warn "Unnamed restart does not have a ~
binding))
`(make-restart :name ',(car binding)
:function ,(cadr binding)
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 ~
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)
: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 ~
(symbol
(when (keywordp spec)
(style-warn "Keyword slot name indicates probable syntax ~
- error in DEFSTRUCT: ~S."
+ error in DEFSTRUCT: ~S."
(when (or moved retyped deleted)
(warn
"incompatibly redefining slots of structure class ~S~@
(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))))
name moved retyped deleted)
t))))
#!+sb-doc
"Type corresponding to the characters required by the standard."
'(member
#!+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 #\: #\; #\< #\=
#\- #\. #\/ #\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 #\{
#\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, 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
(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 ~
(sb!xc:get-setf-expansion form environment)
(when (cdr store-vars)
(error "GET-SETF-METHOD used for a form with multiple store ~
form))
(values temps value-forms store-vars store-form access-form)))
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 ~
(cond ((gethash name sb!c:*setf-assumed-fboundp*)
(warn
"defining setf macro for ~S when ~S was previously ~
name
`(setf ,name)))
((not (fboundp `(setf ,name)))
name
`(setf ,name)))
((not (fboundp `(setf ,name)))
:datum arguments
:expected-type 'null
:format-control "You may not supply additional arguments ~
:datum arguments
:expected-type 'null
:format-control "You may not supply additional arguments ~
:format-arguments (list datum fun-name)))
datum)
((symbolp datum) ; roughly, (SUBTYPEP DATUM 'CONDITION)
: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.~%~
(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)))))
(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,
: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."
: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 ~
(setf args (nthcdr ,posn orig-args))
(error 'format-error
:complaint "Index ~W out of bounds. Should have been ~
:args (list ,posn (length orig-args))
:offset ,(1- end)))))
(if colonp
:args (list ,posn (length orig-args))
:offset ,(1- end)))))
(if colonp
(error 'format-error
:complaint
"Index ~W is out of bounds; should have been ~
(error 'format-error
:complaint
"Index ~W is out of bounds; should have been ~
:args (list new-posn (length orig-args))
:offset ,(1- end)))))))
(if params
:args (list new-posn (length orig-args))
:offset ,(1- end)))))))
(if params
(if directive
(error 'format-error
:complaint
(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
: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~@
(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~@
name (car (loop-collector-history cruft)) collector))
(unless (equal dtype (loop-collector-dtype cruft))
(loop-warn
"unequal datatypes specified in different LOOP value accumulations~@
name dtype (loop-collector-dtype cruft))
(when (eq (loop-collector-dtype cruft) t)
(setf (loop-collector-dtype cruft) dtype)))
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,~@
(if (setq tem (loop-tassoc (car z) *loop-named-vars*))
(loop-error
"The variable substitution for ~S occurs twice in a USING phrase,~@
(car z) (cadr z) (cadr tem))
(push (cons (car z) (cadr z)) *loop-named-vars*)))
(when (or (null *loop-source-code*)
(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;~@
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"))
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.~
(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*))))
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:
(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))
(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 ~
(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
,(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
*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.
: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
:FILL - A line break is inserted if and only if either:
(a) the following section cannot be printed on the end of the
(b) the preceding section was not printed on a single line, or
(c) the immediately containing section cannot be printed on one
(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
: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
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
:CURRENT - Indent relative to the current column.
The new indentation value does not take effect until the following line
break."
: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:
#!+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)
`(%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 ~
;; 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.
((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*)
(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*)
(defun maybe-print-query (hint format-string &rest format-args)
(fresh-line *query-io*)
(indentation (indenting-stream-indentation ,stream)))
((>= i indentation))
(%write-string
(indentation (indenting-stream-indentation ,stream)))
((>= i indentation))
(%write-string
+ #.(make-string 60 :initial-element #\Space)
,sub-stream
0
(min 60 (- indentation i)))))
,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:
#!+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)
(declare (type stream target)
(type (member :upcase :downcase :capitalize :capitalize-first)
kind)
way that the argument is passed.
:IN
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.
- 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.
- 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
on the stack, and a pointer to the object is passed instead of
- 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)
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 ~
(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
: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
(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
: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~@
(> (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.
(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 ~
(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)
(%pathname-host pathname)
(%pathname-device pathname)
(%pathname-directory pathname)
:expected-type 'null
:format-control
"The host in the namestring, ~S,~@
: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
: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 ~
(let ((host (%pathname-host pathname)))
(unless host
(error "can't determine the namestring for pathnames with no ~
(funcall (host-unparse host) pathname)))))
(defun host-namestring (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 ~
(setf in-wildcard t)
(unless subs
(error "not enough wildcards in FROM pattern to match ~
pattern))
(let ((sub (pop subs)))
(typecase sub
pattern))
(let ((sub (pop subs)))
(typecase sub
(push sub strings))
(t
(error "can't substitute this into the middle of a word:~
(push sub strings))
(t
(error "can't substitute this into the middle of a word:~
;;; 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~@
;;; 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
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 ~
(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 ~
(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
(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 ~
(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))
:args (list ch)
:namestring word :offset i))))
word))
(when (pattern)
(error 'namestring-parse-error
:complaint "double asterisk inside of logical ~
(when (pattern)
(error 'namestring-parse-error
:complaint "double asterisk inside of logical ~
:args (list chunk)
:namestring namestring
:offset (+ (cdar chunks) pos)))
:args (list chunk)
:namestring namestring
:offset (+ (cdar chunks) pos)))
(unless (and res (plusp res))
(error 'namestring-parse-error
:complaint "expected a positive integer, ~
(unless (and res (plusp res))
(error 'namestring-parse-error
:complaint "expected a positive integer, ~
:args (list str)
:namestring namestr
:offset (+ pos (cdar chunks))))
: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:~% ~
(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.]~% ~]~
~@[ [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)
(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
(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
;;;; 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 ~
((: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
;;; 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 ~
(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))
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, ~
(additional-delta (- old-size size)))
(when (minusp additional-delta)
(error "Alignment ~S needs more space now? It was ~W, ~
note old-size size))
(when (plusp additional-delta)
(emit-filler segment additional-delta)
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 ~
(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 ~
byte-spec-expr))
(setf (ldb byte-spec overall-mask) -1)
(arg-names arg)
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 ~
(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%%
;; 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 ~
name)
*backend-support-routines*)
(error "machine-specific support ~S ~
',name))
args)))
routines))))
',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 ~
(multiple-value-bind (res win) (ctypep val type)
(cond ((not win)
(note-unwinnage "can't tell whether the ~:R argument is a ~
n (type-specifier type) val)
nil)
((not res)
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 ~
((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 ~
n))
(t
(let* ((name (lvar-value k))
n))
(t
(let* ((name (lvar-value k))
((eq int *empty-type*)
(note-lossage
"Definition's declared type for variable ~A:~% ~S~@
((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)))
(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 ~
(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")
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~@
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)
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~% ~
(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))))
(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
;; 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)
;; 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
;; 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)
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 ~
(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."))
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
;;; 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
;;;
;;; the current version of SBCL core files
;;;
(make-fixnum-descriptor length))
(dotimes (i length)
(setf (bvref bytes (+ offset i))
(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))
(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~%~
(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~%~
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~%~
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)))
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.)
;; (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)
;; 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:~
(length bit-array-2)
(length result-bit-array))
(error "Argument and/or result bit arrays are not the same length:~
bit-array-1
bit-array-2
result-bit-array))))
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:~
'((unless (= (length bit-array)
(length result-bit-array))
(error "Argument and result bit arrays are not the same length:~
bit-array result-bit-array))))
(let ((length (length result-bit-array)))
(if (= length 0)
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 ~
(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)))
(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 ~
(let ((*compiler-error-context* (lambda-bind fun)))
(compiler-notify
"Return type not fixed values, so can't use known return ~
(type-specifier rtype)))
(return)))))))))
(values))
(type-specifier rtype)))
(return)))))))))
(values))
(if (template-more-args-type template)
(when (< nargs min)
(bug "Primitive ~A was called with ~R argument~:P, ~
(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."
(compiler-notify "~@<unable to ~
~2I~_~A ~
~I~_due to type uncertainty: ~
(compiler-notify "~@<unable to ~
~2I~_~A ~
~I~_due to type uncertainty: ~
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
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:~
(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
(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 ~
(when (and min (< total-nvals min))
(compiler-warn
"MULTIPLE-VALUE-CALL with ~R values when the function expects ~
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 ~
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 ~
total-nvals max)
(setf (basic-combination-kind node) :error)
(return-from ir1-optimize-mv-call)))
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 ~
(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))
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, ~
;; 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))))
*inline-expansion-limit*))
nil)
(t t))))
(cond (losing-local-functional
(let ((*compiler-error-context* call))
(compiler-notify "couldn't inline expand because expansion ~
(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)
(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 ~
(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))
(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
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)
`(%with-compilation-unit (lambda () ,@body) ,@options))
(defun %with-compilation-unit (fn &key override)
(when summary
(if (eq kind :variable)
(compiler-warn
(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
(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)
(cdr summary) kind summary))))))))
(unless (and (not abort-p)
(rassoc name (funs)))))
(unless name
(error "no move function defined to ~:[save~;load~] SC ~S ~
(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~]~@
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
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~@
((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)))
sc-name load-p (operand-parse-name op))))))
(funs)))
,form)))
`(when ,load-tn
(error "load TN allocated, but no move function?~@
,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
;;; 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 ~
(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)))
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 ~
(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)))
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,~@
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 '*)))))
(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~@
(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)))))
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?~@
(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 ~
(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 ~
dest-name src-name))
((member src-sc (sc-alternate-scs dest-sc))
(error "no load function defined to load SC ~S from its ~
dest-name src-name))
((member dest-sc (sc-alternate-scs src-sc))
(error "no load function defined to save SC ~S in its ~
dest-name src-name))
((member dest-sc (sc-alternate-scs src-sc))
(error "no load function defined to save SC ~S in its ~
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?~@
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.
;;; 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~@
(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."
(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 ~:;,~]~} ~
(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)))
(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:~
(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)
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:~% ~
(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
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.~@
(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~@
(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)
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 ~
(no-move-scs i-sc))))
(t
(error "Representation selection flamed out for no ~
(unless (or (load-lose) (no-move-scs) (move-lose))
(error "Representation selection flamed out for no 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:~
(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)
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 ~
(defun bad-move-arg-error (val pass)
(declare (type tn val pass))
(error "no :MOVE-ARG VOP defined to move ~S (SC ~S) to ~
val (sc-name (tn-sc val))
pass (sc-name (tn-sc pass))))
\f
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 ~
(dolist (const (sc-constant-scs sc))
(unless (svref moves (sc-number const))
(warn "no move function defined to load SC ~S from constant ~
(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-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-name sc) (sc-name alt)))
(unless (svref (sc-move-funs alt) i)
(warn "no move function defined to save SC ~S to alternate ~
(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-name sc) (sc-name alt)))))))))
\f
;;;; representation selection
(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~
(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
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; ~@
(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))
file index."
name)
(let ((*read-suppress* t))
nil)
((> form-number (length mapping-table))
(warn "bogus form-number in form! The source file has probably ~@
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))
(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 ~
;; If not properly named, error.
((not (and name (eq (find-classoid name) class)))
(compiler-error "can't compile TYPEP of anonymous or undefined ~
class))
(t
;; Delay the type transform to give type propagation a chance.
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)
(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)
(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:
(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))
((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)
(parse-namestring "SCRATCH:FOO.TXT.NEWEST")
(parse-namestring "SCRATCH:FOO.TXT"))))
(dolist (p pathnames)
(handler-case
(let ((*print-readably* t))
(assert (equal (read-from-string (format nil "~S" p)) 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
;;; 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)))
(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
;;; 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)))
(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
;;; 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)))
(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
;;; 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)))
(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
;;; 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)
(setf (fill-pointer string) 10)
(setf (subseq string 0 10) "1234567890")
(setf (fill-pointer string) 5)
;;; Function PARSE-NAMESTRING
(sequence-bounding-indices-test
;;; 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)
(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
;;; 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)))
(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
;;; 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)))
(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
;;; 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)))
(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
;;; 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 (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
(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) ""))
(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
;;; 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)))
(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
;;; 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
(assert (string= (replace string "bbbbb" :start1 0 :end1 5) "bbbbb"))
(assert (string= (replace (copy-seq "ccccc")
string
;;; Function SEARCH
(sequence-bounding-indices-test
;;; 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 (= (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
(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)
(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-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
(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
(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))
(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
;;; 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 (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
(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)
(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
: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*
(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
;;; 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)
(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".)
;;; 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".)