(in-package "SB!IMPL")
\f
-;;; miscellaneous global variables
+;;;; miscellaneous global variables
-(defvar *read-default-float-format* 'single-float
- #!+sb-doc "Float format for 1.0E1")
+;;; ANSI: "the floating-point format that is to be used when reading a
+;;; floating-point number that has no exponent marker or that has e or
+;;; E for an exponent marker"
+(defvar *read-default-float-format* 'single-float)
(declaim (type (member short-float single-float double-float long-float)
*read-default-float-format*))
\f
;;;; constants for character attributes. These are all as in the manual.
+;;; FIXME: It's disturbing to bind nice names like ESCAPE and DELIMITER
+;;; as constants throughout the entire SB-IMPL package. Perhaps these
+;;; could be given some standard prefix, so instead we have constants
+;;; CHATTR-ESCAPE and CHATTR-DELIMITER and so forth.
(defconstant whitespace 0)
(defconstant terminating-macro 1)
(defconstant escape 2)
;; the "9" entry intentionally left blank for some reason -- WHN 19990806
(defconstant multiple-escape 10)
(defconstant package-delimiter 11)
-;; a fake attribute for use in read-unqualified-token
-(defconstant delimiter 12)
+(defconstant delimiter 12) ; (a fake for use in read-unqualified-token)
\f
;;;; macros and functions for character tables
(test-attribute char whitespace rt))
(defmacro constituentp (char &optional (rt '*readtable*))
- `(>= (get-cat-entry ,char ,rt) #.constituent))
+ `(>= (get-cat-entry ,char ,rt) constituent))
(defmacro terminating-macrop (char &optional (rt '*readtable*))
- `(test-attribute ,char #.terminating-macro ,rt))
+ `(test-attribute ,char terminating-macro ,rt))
(defmacro escapep (char &optional (rt '*readtable*))
- `(test-attribute ,char #.escape ,rt))
+ `(test-attribute ,char escape ,rt))
(defmacro multiple-escape-p (char &optional (rt '*readtable*))
- `(test-attribute ,char #.multiple-escape ,rt))
+ `(test-attribute ,char multiple-escape ,rt))
(defmacro token-delimiterp (char &optional (rt '*readtable*))
;; depends on actual attribute numbering above.
- `(<= (get-cat-entry ,char ,rt) #.terminating-macro))
+ `(<= (get-cat-entry ,char ,rt) terminating-macro))
\f
;;;; secondary attribute table
(defun !cold-init-secondary-attribute-table ()
(setq *secondary-attribute-table*
(make-array char-code-limit :element-type '(unsigned-byte 8)
- :initial-element #.constituent))
- (!set-secondary-attribute #\: #.package-delimiter)
- (!set-secondary-attribute #\| #.multiple-escape) ; |) [for EMACS]
- (!set-secondary-attribute #\. #.constituent-dot)
- (!set-secondary-attribute #\+ #.constituent-sign)
- (!set-secondary-attribute #\- #.constituent-sign)
- (!set-secondary-attribute #\/ #.constituent-slash)
+ :initial-element constituent))
+ (!set-secondary-attribute #\: package-delimiter)
+ (!set-secondary-attribute #\| multiple-escape) ; |) [for EMACS]
+ (!set-secondary-attribute #\. constituent-dot)
+ (!set-secondary-attribute #\+ constituent-sign)
+ (!set-secondary-attribute #\- constituent-sign)
+ (!set-secondary-attribute #\/ constituent-slash)
(do ((i (char-code #\0) (1+ i)))
((> i (char-code #\9)))
- (!set-secondary-attribute (code-char i) #.constituent-digit))
- (!set-secondary-attribute #\E #.constituent-expt)
- (!set-secondary-attribute #\F #.constituent-expt)
- (!set-secondary-attribute #\D #.constituent-expt)
- (!set-secondary-attribute #\S #.constituent-expt)
- (!set-secondary-attribute #\L #.constituent-expt)
- (!set-secondary-attribute #\e #.constituent-expt)
- (!set-secondary-attribute #\f #.constituent-expt)
- (!set-secondary-attribute #\d #.constituent-expt)
- (!set-secondary-attribute #\s #.constituent-expt)
- (!set-secondary-attribute #\l #.constituent-expt))
+ (!set-secondary-attribute (code-char i) constituent-digit))
+ (!set-secondary-attribute #\E constituent-expt)
+ (!set-secondary-attribute #\F constituent-expt)
+ (!set-secondary-attribute #\D constituent-expt)
+ (!set-secondary-attribute #\S constituent-expt)
+ (!set-secondary-attribute #\L constituent-expt)
+ (!set-secondary-attribute #\e constituent-expt)
+ (!set-secondary-attribute #\f constituent-expt)
+ (!set-secondary-attribute #\d constituent-expt)
+ (!set-secondary-attribute #\s constituent-expt)
+ (!set-secondary-attribute #\l constituent-expt))
(defmacro get-secondary-attribute (char)
`(elt *secondary-attribute-table*
returns T."
(if non-terminatingp
(set-cat-entry char (get-secondary-attribute char) rt)
- (set-cat-entry char #.terminating-macro rt))
+ (set-cat-entry char terminating-macro rt))
(set-cmt-entry char function rt)
T)
-(defun get-macro-character (char &optional rt)
+(defun get-macro-character (char &optional (rt *readtable*))
#!+sb-doc
"Returns the function associated with the specified char which is a macro
character. The optional readtable argument defaults to the current
readtable."
- (let ((rt (or rt *readtable*)))
+ (let ((rt (or rt *standard-readtable*)))
;; Check macro syntax, return associated function if it's there.
;; Returns a value for all constituents.
(cond ((constituentp char)
(do ((attribute-table (character-attribute-table *readtable*))
(char (fast-read-char t) (fast-read-char t)))
((/= (the fixnum (aref attribute-table (char-code char)))
- #.whitespace)
+ whitespace)
(done-with-fast-read-char)
char)))
;; fundamental-stream
(char (stream-read-char stream) (stream-read-char stream)))
((or (eq char :eof)
(/= (the fixnum (aref attribute-table (char-code char)))
- #.whitespace))
+ whitespace))
(if (eq char :eof)
(error 'end-of-file :stream stream)
char))))))
;; All characters default to "constituent" in MAKE-READTABLE.
;; *** un-constituent-ize some of these ***
(let ((*readtable* *standard-readtable*))
- (set-cat-entry (code-char tab-char-code) #.whitespace)
- (set-cat-entry #\linefeed #.whitespace)
- (set-cat-entry #\space #.whitespace)
- (set-cat-entry (code-char form-feed-char-code) #.whitespace)
- (set-cat-entry (code-char return-char-code) #.whitespace)
- (set-cat-entry #\\ #.escape)
+ (set-cat-entry (code-char tab-char-code) whitespace)
+ (set-cat-entry #\linefeed whitespace)
+ (set-cat-entry #\space whitespace)
+ (set-cat-entry (code-char form-feed-char-code) whitespace)
+ (set-cat-entry (code-char return-char-code) whitespace)
+ (set-cat-entry #\\ escape)
(set-cmt-entry #\\ #'read-token)
- (set-cat-entry (code-char rubout-char-code) #.whitespace)
+ (set-cat-entry (code-char rubout-char-code) whitespace)
(set-cmt-entry #\: #'read-token)
(set-cmt-entry #\| #'read-token)
;; macro definitions
(defvar *read-buffer*)
(defvar *read-buffer-length*)
-;;; FIXME: Is it really helpful to have *READ-BUFFER-LENGTH* be a separate
-;;; variable instead of just calculating it on the fly as (LENGTH *READ-BUFFER*)?
+;;; FIXME: Is it really helpful to have *READ-BUFFER-LENGTH* be a
+;;; separate variable instead of just calculating it on the fly as
+;;; (LENGTH *READ-BUFFER*)?
(defvar *inch-ptr*)
(defvar *ouch-ptr*)
(declaim (simple-string *read-buffer*))
(defmacro reset-read-buffer ()
- ;; Turn *read-buffer* into an empty read buffer.
- ;; *Ouch-ptr* always points to next char to write.
+ ;; Turn *READ-BUFFER* into an empty read buffer.
`(progn
- (setq *ouch-ptr* 0)
- ;; *inch-ptr* always points to next char to read.
- (setq *inch-ptr* 0)))
+ ;; *OUCH-PTR* always points to next char to write.
+ (setq *ouch-ptr* 0)
+ ;; *INCH-PTR* always points to next char to read.
+ (setq *inch-ptr* 0)))
(defun !cold-init-read-buffer ()
(setq *read-buffer* (make-string 512)) ; initial bufsize
(reset-read-buffer))
;;; FIXME I removed "THE FIXNUM"'s from OUCH-READ-BUFFER and
-;;; OUCH-UNREAD-BUFFER, check to make sure that Python really is smart enough
-;;; to make good code without them. And while I'm at it, converting them
-;;; from macros to inline functions might be good, too.
+;;; OUCH-UNREAD-BUFFER, check to make sure that Python really is smart
+;;; enough to make good code without them. And while I'm at it,
+;;; converting them from macros to inline functions might be good,
+;;; too.
(defmacro ouch-read-buffer (char)
`(progn
(declare (ignore ignore))
(%reader-error stream "unmatched close parenthesis"))
-;;; Read from the stream up to the next delimiter. Leave the resulting token in
-;;; *read-buffer*, and return two values:
+;;; Read from the stream up to the next delimiter. Leave the resulting
+;;; token in *READ-BUFFER*, and return two values:
;;; -- a list of the escaped character positions, and
;;; -- The position of the first package delimiter (or NIL).
-(defun internal-read-extended-token (stream firstchar)
+(defun internal-read-extended-token (stream firstchar escape-firstchar)
(reset-read-buffer)
+ (let ((escapes '()))
+ (when escape-firstchar
+ (push *ouch-ptr* escapes)
+ (ouch-read-buffer firstchar)
+ (setq firstchar (read-char stream nil *eof-object*)))
(do ((char firstchar (read-char stream nil *eof-object*))
- (escapes ())
(colon nil))
((cond ((eofp char) t)
((token-delimiterp char)
(reader-eof-error stream "after escape character")
(ouch-read-buffer nextchar))))
((multiple-escape-p char)
- ;; Read to next multiple-escape, escaping single chars along the
- ;; way.
+ ;; Read to next multiple-escape, escaping single chars
+ ;; along the way.
(loop
(let ((ch (read-char stream nil *eof-object*)))
(cond
((multiple-escape-p ch) (return))
((escapep ch)
(let ((nextchar (read-char stream nil *eof-object*)))
- (if (eofp nextchar)
- (reader-eof-error stream "after escape character")
- (ouch-read-buffer nextchar))))
+ (cond ((eofp nextchar)
+ (reader-eof-error stream "after escape character"))
+ (t
+ (push *ouch-ptr* escapes)
+ (ouch-read-buffer nextchar)))))
(t
(push *ouch-ptr* escapes)
(ouch-read-buffer ch))))))
(t
(when (and (constituentp char)
- (eql (get-secondary-attribute char) #.package-delimiter)
+ (eql (get-secondary-attribute char)
+ package-delimiter)
(not colon))
(setq colon *ouch-ptr*))
- (ouch-read-buffer char)))))
+ (ouch-read-buffer char))))))
\f
;;;; character classes
(defmacro char-class (char attable)
`(let ((att (aref ,attable (char-code ,char))))
(declare (fixnum att))
- (if (<= att #.terminating-macro)
- #.delimiter
+ (if (<= att terminating-macro)
+ delimiter
att)))
-;;; Return the character class for CHAR, which might be part of a rational
-;;; number.
+;;; Return the character class for CHAR, which might be part of a
+;;; rational number.
(defmacro char-class2 (char attable)
`(let ((att (aref ,attable (char-code ,char))))
(declare (fixnum att))
- (if (<= att #.terminating-macro)
- #.delimiter
+ (if (<= att terminating-macro)
+ delimiter
(if (digit-char-p ,char *read-base*)
constituent-digit
(if (= att constituent-digit)
(setq possibly-float
(or (digit-char-p ,char 10)
(= att constituent-dot))))
- (if (<= att #.terminating-macro)
- #.delimiter
+ (if (<= att terminating-macro)
+ delimiter
(if (digit-char-p ,char (max *read-base* 10))
(if (digit-char-p ,char *read-base*)
constituent-digit
(defun read-token (stream firstchar)
#!+sb-doc
"This function is just an fsm that recognizes numbers and symbols."
- ;; Check explicitly whether firstchar has entry for non-terminating
- ;; in character-attribute-table and read-dot-number-symbol in CMT.
- ;; Report an error if these are violated (if we called this, we want
- ;; something that is a legitimate token!).
- ;; Read in the longest possible string satisfying the bnf for
- ;; "unqualified-token". Leave the result in the *READ-BUFFER*.
- ;; Return next char after token (last char read).
+ ;; Check explicitly whether FIRSTCHAR has an entry for
+ ;; NON-TERMINATING in CHARACTER-ATTRIBUTE-TABLE and
+ ;; READ-DOT-NUMBER-SYMBOL in CMT. Report an error if these are
+ ;; violated. (If we called this, we want something that is a
+ ;; legitimate token!) Read in the longest possible string satisfying
+ ;; the Backus-Naur form for "unqualified-token". Leave the result in
+ ;; the *READ-BUFFER*. Return next char after token (last char read).
(when *read-suppress*
- (internal-read-extended-token stream firstchar)
+ (internal-read-extended-token stream firstchar nil)
(return-from read-token nil))
(let ((attribute-table (character-attribute-table *readtable*))
(package-designator nil)
(#.escape (go ESCAPE))
(#.package-delimiter (go COLON))
(#.multiple-escape (go MULT-ESCAPE))
- ;;can't have eof, whitespace, or terminating macro as first char!
+ ;; can't have eof, whitespace, or terminating macro as first char!
(t (go SYMBOL)))
- SIGN
- ;;saw "sign"
+ SIGN ; saw "sign"
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (go RETURN-SYMBOL))
(#.multiple-escape (go MULT-ESCAPE))
(#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
(t (go SYMBOL)))
- LEFTDIGIT
- ;;saw "[sign] {digit}+"
+ LEFTDIGIT ; saw "[sign] {digit}+"
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (return (make-integer)))
(#.multiple-escape (go MULT-ESCAPE))
(#.package-delimiter (go COLON))
(t (go SYMBOL)))
- MIDDLEDOT
- ;;saw "[sign] {digit}+ dot"
+ MIDDLEDOT ; saw "[sign] {digit}+ dot"
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (return (let ((*read-base* 10))
(#.multiple-escape (go MULT-ESCAPE))
(#.package-delimiter (go COLON))
(t (go SYMBOL)))
- RIGHTDIGIT
- ;;saw "[sign] {digit}* dot {digit}+"
+ RIGHTDIGIT ; saw "[sign] {digit}* dot {digit}+"
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (return (make-float)))
(#.multiple-escape (go MULT-ESCAPE))
(#.package-delimiter (go COLON))
(t (go SYMBOL)))
- SIGNDOT
- ;;saw "[sign] dot"
+ SIGNDOT ; saw "[sign] dot"
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (go RETURN-SYMBOL))
(#.escape (go ESCAPE))
(#.multiple-escape (go MULT-ESCAPE))
(t (go SYMBOL)))
- FRONTDOT
- ;;saw "dot"
+ FRONTDOT ; saw "dot"
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (%reader-error stream "dot context error"))
(#.multiple-escape (go MULT-ESCAPE))
(#.package-delimiter (go COLON))
(t (go SYMBOL)))
- EXPTSIGN
- ;;we got to EXPONENT, and saw a sign character.
+ EXPTSIGN ; got to EXPONENT, and saw a sign character
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (go RETURN-SYMBOL))
(#.multiple-escape (go MULT-ESCAPE))
(#.package-delimiter (go COLON))
(t (go SYMBOL)))
- EXPTDIGIT
- ;;got to EXPONENT, saw "[sign] {digit}+"
+ EXPTDIGIT ; got to EXPONENT, saw "[sign] {digit}+"
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (return (make-float)))
(#.multiple-escape (go MULT-ESCAPE))
(#.package-delimiter (go COLON))
(t (go SYMBOL)))
- RATIO
- ;;saw "[sign] {digit}+ slash"
+ RATIO ; saw "[sign] {digit}+ slash"
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (go RETURN-SYMBOL))
(#.multiple-escape (go MULT-ESCAPE))
(#.package-delimiter (go COLON))
(t (go SYMBOL)))
- RATIODIGIT
- ;;saw "[sign] {digit}+ slash {digit}+"
+ RATIODIGIT ; saw "[sign] {digit}+ slash {digit}+"
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (return (make-ratio)))
(#.multiple-escape (go MULT-ESCAPE))
(#.package-delimiter (go COLON))
(t (go SYMBOL)))
- DOTS
- ;; saw "dot {dot}+"
+ DOTS ; saw "dot {dot}+"
(ouch-read-buffer char)
(setq char (read-char stream nil nil))
(unless char (%reader-error stream "too many dots"))
(#.multiple-escape (go MULT-ESCAPE))
(#.package-delimiter (go COLON))
(t (go SYMBOL)))
- SYMBOL
- ;; not a dot, dots, or number
+ SYMBOL ; not a dot, dots, or number
(let ((stream (in-synonym-of stream)))
(if (lisp-stream-p stream)
(prepare-for-fast-read-char stream
(#.multiple-escape (go MULT-ESCAPE))
(#.package-delimiter (go COLON))
(t (go SYMBOL-LOOP))))))
- ESCAPE
- ;;saw an escape.
- ;;don't put the escape in the read buffer.
- ;;read-next char, put in buffer (no case conversion).
+ ESCAPE ; saw an escape
+ ;; Don't put the escape in the read buffer.
+ ;; READ-NEXT CHAR, put in buffer (no case conversion).
(let ((nextchar (read-char stream nil nil)))
(unless nextchar
(reader-eof-error stream "after escape character"))
"Symbol ~S not found in the ~A package.")))
(return (intern name found)))))))))
+;;; for semi-external use:
+;;;
+;;; For semi-external use: Return 3 values: the string for the token,
+;;; a flag for whether there was an escape char, and the position of
+;;; any package delimiter.
(defun read-extended-token (stream &optional (*readtable* *readtable*))
- #!+sb-doc
- "For semi-external use: returns 3 values: the string for the token,
- a flag for whether there was an escape char, and the position of any
- package delimiter."
- (let ((firstch (read-char stream nil nil t)))
- (cond (firstch
+ (let ((first-char (read-char stream nil nil t)))
+ (cond (first-char
(multiple-value-bind (escapes colon)
- (internal-read-extended-token stream firstch)
+ (internal-read-extended-token stream first-char nil)
(casify-read-buffer escapes)
(values (read-buffer-to-string) (not (null escapes)) colon)))
(t
(values "" nil nil)))))
+
+;;; for semi-external use:
+;;;
+;;; Read an extended token with the first character escaped. Return
+;;; the string for the token.
+(defun read-extended-token-escaped (stream &optional (*readtable* *readtable*))
+ (let ((first-char (read-char stream nil nil)))
+ (cond (first-char
+ (let ((escapes (internal-read-extended-token stream first-char t)))
+ (casify-read-buffer escapes)
+ (read-buffer-to-string)))
+ (t
+ (reader-eof-error stream "after escape")))))
\f
;;;; number-reading functions
(defmacro digit* nil
`(do ((ch char (inch-read-buffer)))
((or (eofp ch) (not (digit-char-p ch))) (setq char ch))
- ;;report if at least one digit is seen:
+ ;; Report if at least one digit is seen.
(setq one-digit t)))
(defmacro exponent-letterp (letter)
;; appropriately. This should avoid any unnecessary
;; underflow or overflow problems.
(multiple-value-bind (min-expo max-expo)
+ ;; FIXME: These #. forms are broken w.r.t.
+ ;; cross-compilation portability. Maybe expressions
+ ;; like
+ ;; (LOG SB!XC:MOST-POSITIVE-SHORT-FLOAT 10s0)
+ ;; could be used instead? Or perhaps some sort of
+ ;; load-time-form magic?
(case float-format
(short-float
(values
(setf number (/ number (expt 10 correction)))
(setq num (make-float-aux number divisor float-format))
(setq num (* num (expt 10 exponent)))
- (return-from make-float (if negative-fraction (- num) num))))))
+ (return-from make-float (if negative-fraction
+ (- num)
+ num))))))
;; should never happen:
(t (error "internal error in floating point reader")))))
(coerce (/ number divisor) float-format))
(defun make-ratio ()
- ;; Assume *read-buffer* contains a legal ratio. Build the number from
+ ;; Assume *READ-BUFFER* contains a legal ratio. Build the number from
;; the string.
;;
;; Look for optional "+" or "-".
(non-terminating-p nil)
(rt *readtable*))
#!+sb-doc
- "Causes char to become a dispatching macro character in readtable
- (which defaults to the current readtable). If the non-terminating-p
- flag is set to T, the char will be non-terminating. Make-dispatch-
- macro-character returns T."
+ "Cause CHAR to become a dispatching macro character in readtable (which
+ defaults to the current readtable). If NON-TERMINATING-P, the char will
+ be non-terminating."
(set-macro-character char #'read-dispatch-char non-terminating-p rt)
(let* ((dalist (dispatch-tables rt))
(dtable (cdr (find char dalist :test #'char= :key #'car))))
(cond (dtable
- (error "Dispatch character already exists."))
+ (error "The dispatch character ~S already exists." char))
(t
(setf (dispatch-tables rt)
(push (cons char (make-char-dispatch-table)) dalist))))))
-(defun set-dispatch-macro-character
- (disp-char sub-char function &optional (rt *readtable*))
+(defun set-dispatch-macro-character (disp-char sub-char function
+ &optional (rt *readtable*))
#!+sb-doc
- "Causes function to be called whenever the reader reads
- disp-char followed by sub-char. Set-dispatch-macro-character
- returns T."
+ "Cause FUNCTION to be called whenever the reader reads DISP-CHAR
+ followed by SUB-CHAR."
;; Get the dispatch char for macro (error if not there), diddle
;; entry for sub-char.
(when (digit-char-p sub-char)
(coerce function 'function))
(error "~S is not a dispatch char." disp-char))))
-(defun get-dispatch-macro-character (disp-char sub-char &optional rt)
+(defun get-dispatch-macro-character (disp-char sub-char
+ &optional (rt *readtable*))
#!+sb-doc
"Returns the macro character function for sub-char under disp-char
or nil if there is no associated function."
(unless (digit-char-p sub-char)
(let* ((sub-char (char-upcase sub-char))
- (rt (or rt *readtable*))
+ (rt (or rt *standard-readtable*))
(dpair (find disp-char (dispatch-tables rt)
:test #'char= :key #'car)))
(if dpair
(defknown make-package (stringable &key
(:use list)
(:nicknames list)
- ;; ### Extensions...
+ ;; ### extensions...
(:internal-symbols index)
(:external-symbols index))
sb!xc:package)
(defknown unintern (symbol &optional package-designator) boolean)
(defknown unexport (symbols &optional package-designator) (eql t))
(defknown shadowing-import (symbols &optional package-designator) (eql t))
-(defknown shadow ((or symbol string list) &optional package-designator) (eql t))
-(defknown (use-package unuse-package) ((or list package-designator) &optional package-designator) (eql t))
+(defknown shadow ((or symbol string list) &optional package-designator)
+ (eql t))
+(defknown (use-package unuse-package)
+ ((or list package-designator) &optional package-designator) (eql t))
(defknown find-all-symbols (stringable) list (flushable))
\f
;;;; from the "Numbers" chapter:
(defknown lognot (integer) integer (movable foldable flushable explicit-check))
(defknown logtest (integer integer) boolean (movable foldable flushable))
(defknown logbitp (bit-index integer) boolean (movable foldable flushable))
-(defknown ash (integer integer) integer (movable foldable flushable explicit-check))
+(defknown ash (integer integer) integer
+ (movable foldable flushable explicit-check))
(defknown (logcount integer-length) (integer) bit-index
(movable foldable flushable explicit-check))
;;; FIXME: According to the ANSI spec, it's legal to use any
(flushable)
:derive-type (result-type-specifier-nth-arg 1))
-(defknown (map %map) (type-specifier callable sequence &rest sequence) consed-sequence
+(defknown (map %map) (type-specifier callable sequence &rest sequence)
+ consed-sequence
(flushable call)
; :DERIVE-TYPE 'TYPE-SPEC-ARG1 ? Nope... (MAP NIL ...) returns NULL, not NIL.
)
:derive-type (sequence-result-nth-arg 3))
(defknown remove-duplicates
- (sequence &key (:test callable) (:test-not callable) (:start index) (:from-end t)
- (:end sequence-end) (:key callable))
+ (sequence &key (:test callable) (:test-not callable) (:start index)
+ (:from-end t) (:end sequence-end) (:key callable))
consed-sequence
(flushable call)
:derive-type (sequence-result-nth-arg 1))
(defknown delete-duplicates
- (sequence &key (:test callable) (:test-not callable) (:start index) (:from-end t)
- (:end sequence-end) (:key callable))
+ (sequence &key (:test callable) (:test-not callable) (:start index)
+ (:from-end t) (:end sequence-end) (:key callable))
sequence
(flushable call)
:derive-type (sequence-result-nth-arg 1))
(defknown find (t sequence &key (:test callable) (:test-not callable)
- (:start index) (:from-end t) (:end sequence-end) (:key callable))
+ (:start index) (:from-end t) (:end sequence-end)
+ (:key callable))
t
(foldable flushable call))
(defknown (mismatch search)
(sequence sequence &key (:from-end t) (:test callable) (:test-not callable)
- (:start1 index) (:end1 sequence-end) (:start2 index) (:end2 sequence-end)
+ (:start1 index) (:end1 sequence-end)
+ (:start2 index) (:end2 sequence-end)
(:key callable))
(or index null)
(foldable flushable call))
(defknown make-list (index &key (:initial-element t)) list
(movable flushable unsafe))
-;;; All but last must be list...
+;;; All but last must be of type LIST, but there seems to be no way to
+;;; express that in this syntax..
(defknown append (&rest t) t (flushable))
(defknown copy-list (list) list (flushable))
list (foldable flushable unsafe call))
(defknown (union intersection set-difference set-exclusive-or)
- (list list &key (:key callable) (:test callable) (:test-not callable))
+ (list list &key (:key callable) (:test callable) (:test-not callable))
list
(foldable flushable call))
(defknown (nunion nintersection nset-difference nset-exclusive-or)
- (list list &key (:key callable) (:test callable) (:test-not callable))
+ (list list &key (:key callable) (:test callable) (:test-not callable))
list
(foldable flushable call))
(defknown subsetp
- (list list &key (:key callable) (:test callable) (:test-not callable))
+ (list list &key (:key callable) (:test callable) (:test-not callable))
boolean
(foldable flushable call))
(foldable)
#|:derive-type #'result-type-last-arg|#)
-(defknown array-has-fill-pointer-p (array) boolean (movable foldable flushable))
+(defknown array-has-fill-pointer-p (array) boolean
+ (movable foldable flushable))
(defknown fill-pointer (vector) index (foldable flushable))
(defknown vector-push (t vector) (or index null) ())
(defknown vector-push-extend (t vector &optional index) index ())
(defknown make-concatenated-stream (&rest stream) stream (flushable))
(defknown make-two-way-stream (stream stream) stream (flushable))
(defknown make-echo-stream (stream stream) stream (flushable))
-(defknown make-string-input-stream (string &optional index index) stream (flushable unsafe))
+(defknown make-string-input-stream (string &optional index index) stream
+ (flushable unsafe))
(defknown make-string-output-stream () stream (flushable))
(defknown get-output-stream-string (stream) simple-string ())
(defknown streamp (t) boolean (movable foldable flushable))
-(defknown stream-element-type (stream) type-specifier (movable foldable flushable))
-(defknown (output-stream-p input-stream-p) (stream) boolean (movable foldable
- flushable))
+(defknown stream-element-type (stream) type-specifier
+ (movable foldable flushable))
+(defknown (output-stream-p input-stream-p) (stream) boolean
+ (movable foldable flushable))
(defknown close (stream &key (:abort t)) stream ())
\f
;;;; from the "Input/Output" chapter:
-;;; The I/O functions are currently given effects ANY under the theory
-;;; that code motion over I/O operations is particularly confusing and
-;;; not very important for efficency.
+;;; (The I/O functions are given effects ANY under the theory that
+;;; code motion over I/O operations is particularly confusing and not
+;;; very important for efficiency.)
-(defknown copy-readtable (&optional (or readtable null) readtable) readtable
+(defknown copy-readtable (&optional (or readtable null) (or readtable null))
+ readtable
())
(defknown readtablep (t) boolean (movable foldable flushable))
(character character &optional (or readtable null) readtable) (eql t)
())
-(defknown set-macro-character (character callable &optional t readtable) (eql t)
+(defknown set-macro-character (character callable &optional t readtable)
+ (eql t)
(unsafe))
-(defknown get-macro-character (character &optional readtable)
+(defknown get-macro-character (character &optional (or readtable null))
(values callable boolean) (flushable))
(defknown make-dispatch-macro-character (character &optional t readtable)
(character character callable &optional readtable) (eql t)
(unsafe))
(defknown get-dispatch-macro-character
- (character character &optional readtable) callable
+ (character character &optional (or readtable null)) callable
(flushable))
;;; may return any type due to eof-value...
(defknown (read read-preserving-whitespace read-char-no-hang read-char)
- (&optional streamlike t t t) t (explicit-check))
+ (&optional streamlike t t t) t (explicit-check))
(defknown read-delimited-list (character &optional streamlike t) t
(explicit-check))
(movable foldable flushable explicit-check))
(defknown %negate (number) number (movable foldable flushable explicit-check))
(defknown %check-bound (array index fixnum) index (movable foldable flushable))
-(defknown data-vector-ref (simple-array index) t (foldable flushable explicit-check))
+(defknown data-vector-ref (simple-array index) t
+ (foldable flushable explicit-check))
(defknown data-vector-set (array index t) t (unsafe explicit-check))
-(defknown hairy-data-vector-ref (array index) t (foldable flushable explicit-check))
+(defknown hairy-data-vector-ref (array index) t
+ (foldable flushable explicit-check))
(defknown hairy-data-vector-set (array index t) t (unsafe explicit-check))
(defknown sb!kernel:%caller-frame-and-pc () (values t t) (flushable))
(defknown sb!kernel:%with-array-data (array index (or index null))
--- /dev/null
+;;;; tests related to sequences
+
+;;;; This file is impure because we want to be able to use DEFUN.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(in-package :cl-user)
+
+;;; helper functions for exercising SEQUENCE code on data of many
+;;; specialized types, and in many different optimization scenarios
+(defun for-every-seq-1 (base-seq snippet)
+ (dolist (seq-type '(list
+ (simple-array t 1)
+ (vector t)
+ (simple-array character 1)
+ (vector character)
+ (simple-array (signed-byte 4) 1)
+ (vector (signed-byte 4))))
+ (flet ((entirely (eltype)
+ (every (lambda (el) (typep el eltype)) base-seq)))
+ (dolist (declaredness '(nil t))
+ (dolist (optimization '(((speed 3) (space 0))
+ ((speed 2) (space 2))
+ ((speed 1) (space 2))
+ ((speed 0) (space 1))))
+ (let* ((seq (if (eq seq-type 'list)
+ (coerce base-seq 'list)
+ (destructuring-bind (type-first &rest type-rest)
+ seq-type
+ (ecase type-first
+ (simple-array
+ (destructuring-bind (eltype one) type-rest
+ (assert (= one 1))
+ (if (entirely eltype)
+ (coerce base-seq seq-type)
+ (return))))
+ (vector
+ (destructuring-bind (eltype) type-rest
+ (if (entirely eltype)
+ (replace (make-array (length base-seq)
+ :element-type eltype
+ :adjustable t)
+ base-seq)
+ (return))))))))
+ (lambda-expr `(lambda (seq)
+ ,@(when declaredness
+ `((declare (type ,seq-type seq))))
+ (declare (optimize ,@optimization))
+ ,snippet)))
+ (multiple-value-bind (fun warnings-p failure-p)
+ (compile nil lambda-expr)
+ (when (or warnings-p failure-p)
+ (error "~@<failed compilation:~2I ~_WARNINGS-P=~S ~_FAILURE-P=~S ~_LAMBDA-EXPR=~S~:@>" lambda-expr))
+ (unless (funcall fun seq)
+ (error "~@<failed test:~2I ~_BASE-SEQ=~S ~_SNIPPET=~S ~_SEQ-TYPE=~S ~_DECLAREDNESS=~S ~_OPTIMIZATION=~S~:@>"
+ base-seq
+ snippet
+ seq-type
+ declaredness
+ optimization)))))))))
+(defun for-every-seq (base-seq snippets)
+ (dolist (snippet snippets)
+ (for-every-seq-1 base-seq snippet)))
+
+;;; tests of FIND, POSITION, FIND-IF, and POSITION-IF (and a few for
+;;; deprecated FIND-IF-NOT and POSITION-IF-NOT too)
+(for-every-seq #()
+ '((null (find 1 seq))
+ (null (find 1 seq :from-end t))
+ (null (position 1 seq :key #'abs))
+ (null (position nil seq :test (constantly t)))
+ (null (position nil seq :test nil))
+ (null (position nil seq :test-not nil))
+ (null (find-if #'1+ seq :key #'log))
+ (null (position-if #'identity seq :from-end t))
+ (null (find-if-not #'packagep seq))
+ (null (position-if-not #'packagep seq :key nil))))
+(for-every-seq #(1)
+ '((null (find 2 seq))
+ (find 2 seq :key #'1+)
+ (find 1 seq :from-end t)
+ (null (find 0 seq :from-end t))
+ (eql 0 (position 1 seq :key #'abs))
+ (null (position nil seq :test 'equal))
+ (eql 1 (find-if #'1- seq :key #'log))
+ (eql 0 (position-if #'identity seq :from-end t))
+ (null (find-if-not #'sin seq))
+ (eql 0 (position-if-not #'packagep seq :key 'identity))))
+(for-every-seq #(1 2 3 2 1)
+ '((find 3 seq)
+ (find 3 seq :from-end 'yes)
+ (eql 0 (position 0 seq :key '1-))
+ (eql 4 (position 0 seq :key '1- :from-end t))
+ (eql 2 (position 4 seq :key '1+))
+ (eql 2 (position 4 seq :key '1+ :from-end t))
+ (eql 1 (position 2 seq))
+ (eql 3 (position 2 seq :key nil :from-end t))
+ (eql 2 (position 3 seq :test '=))
+ (eql 0 (position 3 seq :test-not 'equalp))
+ (eql 2 (position 3 seq :test 'equal :from-end t))
+ (null (position 4 seq :test #'eql))
+ (null (find-if #'packagep seq))
+ (eql 1 (find-if #'plusp seq))
+ (eql 3 (position-if #'plusp seq :key #'1- :from-end t))
+ (eql 1 (position-if #'evenp seq))
+ (eql 3 (position-if #'evenp seq :from-end t))
+ (null (find-if-not #'plusp seq))
+ (eql 0 (position-if-not #'evenp seq))))
+(for-every-seq "string test"
+ '((null (find 0 seq))
+ (null (find #\D seq :key #'char-upcase))
+ (find #\E seq :key #'char-upcase)
+ (null (find #\e seq :key #'char-upcase))
+ (eql 3 (position #\i seq))
+ (eql 0 (position #\s seq :key #'char-downcase))
+ (eql 1 (position #\s seq :key #'char-downcase :test #'char/=))
+ (eql 9 (position #\s seq :from-end t :test #'char=))
+ (eql 10 (position #\s seq :from-end t :test #'char/=))
+ (eql 4 (position #\N seq :from-end t :key 'char-upcase :test #'char-equal))
+ (eql 5 (position-if (lambda (c) (equal #\g c)) seq))
+ (eql 5 (position-if (lambda (c) (equal #\g c)) seq :from-end t))
+ (find-if #'characterp seq)
+ (find-if #'(lambda (c) (typep c 'base-char)) seq :from-end t)
+ (null (find-if 'upper-case-p seq))))
+
+;;; success
+(quit :unix-status 104)
projects / sbcl.git / commitdiff