The situation is complicated by the presence of Common Lisp types
like UNSIGNED-BYTE (which can either be used in list form or alone)
so I'm not 100% sure that the behavior above is actually illegal.
- But I'm 90+% sure, and someday perhaps I'll be motivated to look it up..
+ But I'm 90+% sure, and the following related behavior,
+ (TYPEP 11 'AND) => T
+ treating the bare symbol AND as equivalent to '(AND), is specifically
+ forbidden (by the ANSI specification of the AND type).
11:
It would be nice if the
them as methods, and identified their generic functions and
specializers.
+83:
+ RANDOM-INTEGER-EXTRA-BITS=10 may not be large enough for the RANDOM
+ RNG to be high quality near RANDOM-FIXNUM-MAX; it looks as though
+ the mean of the distribution can be systematically O(0.1%) wrong.
+ Just increasing R-I-E-B is probably not a good solution, since
+ it would decrease efficiency more than is probably necessary. Perhaps
+ using some sort of accept/reject method would be better.
KNOWN BUGS RELATED TO THE IR1 INTERPRETER
which, unlike e.g. #\Newline, don't have names defined in the
ANSI Common Lisp standard, may change to their ASCII symbolic
names: #\Nul, #\Soh, #\Stx, etc.
+* INTERNAL-TIME-UNITS-PER-SECOND might increase, e.g. to 1000.
(close-fasl-file *lap-output-file* (not won)))
won))
-(defstruct reg-spec
+(defstruct (reg-spec (:copier nil))
(kind :temp :type (member :arg :temp :res))
(name nil :type symbol)
(temp nil :type symbol)
(defstruct (alien-type-type
(:include ctype
(class-info (type-class-or-lose 'alien)))
- (:constructor %make-alien-type-type (alien-type)))
+ (:constructor %make-alien-type-type (alien-type))
+ (:copier nil))
(alien-type nil :type alien-type))
(!define-type-class alien)
(lambda (x stream)
(print-unreadable-object (x stream :type t :identity t)
(prin1 (byte-function-name (byte-closure-function x))
- stream)))))
+ stream))))
+ (:copier nil))
;; the byte function that we call
(function (required-argument) :type byte-function)
;; the closure data vector
;;; object for a closure)
(defstruct (byte-function (:include byte-function-or-closure)
(:type funcallable-structure)
- (:constructor nil))
+ (:constructor nil)
+ (:copier nil))
;; The component that this XEP is an entry point into. NIL until
;; LOAD or MAKE-CORE-BYTE-COMPONENT fills it in. They count on this
;; being the first slot.
;;; fixed-argument byte function
(defstruct (simple-byte-function (:include byte-function)
- (:type funcallable-structure))
+ (:type funcallable-structure)
+ (:copier nil))
;; The number of arguments expected.
(num-args 0 :type (integer 0 #.call-arguments-limit))
;; The start of the function.
;;; variable-arg-count byte function
(defstruct (hairy-byte-function (:include byte-function)
- (:type funcallable-structure))
+ (:type funcallable-structure)
+ (:copier nil))
;; The minimum and maximum number of args, ignoring &REST and &KEY.
(min-args 0 :type (integer 0 #.call-arguments-limit))
(max-args 0 :type (integer 0 #.call-arguments-limit))
;;; SYSTEM-AREA-POINTER is not a primitive type in ANSI Common Lisp,
;;; so we need a compound type to represent it in the host Common Lisp
;;; at cross-compile time:
-(defstruct (system-area-pointer (:constructor make-sap) (:conc-name "SAP-"))
+(defstruct (system-area-pointer (:constructor make-sap)
+ (:conc-name "SAP-"))
;; the integer representation of the address
(int (error "missing SAP-INT argument") :type sap-int-type :read-only t))
;;; These exist for caching data stored in packed binary form in
;;; compiler debug-functions. Debug-functions store these.
-(defstruct (debug-var (:constructor nil))
+(defstruct (debug-var (:constructor nil)
+ (:copier nil))
;; the name of the variable
(symbol (required-argument) :type symbol)
;; a unique integer identification relative to other variables with the same
(defstruct (compiled-debug-var
(:include debug-var)
(:constructor make-compiled-debug-var
- (symbol id alive-p sc-offset save-sc-offset)))
+ (symbol id alive-p sc-offset save-sc-offset))
+ (:copier nil))
;; Storage class and offset. (unexported).
(sc-offset nil :type sb!c::sc-offset)
;; Storage class and offset when saved somewhere.
(defstruct (interpreted-debug-var
(:include debug-var (alive-p t))
- (:constructor make-interpreted-debug-var (symbol ir1-var)))
+ (:constructor make-interpreted-debug-var (symbol ir1-var))
+ (:copier nil))
;; This is the IR1 structure that holds information about interpreted vars.
(ir1-var nil :type sb!c::lambda-var))
;;;; frames
;;; These represent call-frames on the stack.
-(defstruct (frame (:constructor nil))
+(defstruct (frame (:constructor nil)
+ (:copier nil))
;; the next frame up, or NIL when top frame
(up nil :type (or frame null))
;; the previous frame down, or NIL when the bottom frame. Before
(:constructor make-compiled-frame
(pointer up debug-function code-location number
#!+gengc saved-state-chain
- &optional escaped)))
+ &optional escaped))
+ (:copier nil))
;; This indicates whether someone interrupted the frame.
;; (unexported). If escaped, this is a pointer to the state that was
;; saved when we were interrupted. On the non-gengc system, this is
(:include frame)
(:constructor make-interpreted-frame
(pointer up debug-function code-location number
- real-frame closure)))
+ real-frame closure))
+ (:copier nil))
;; This points to the compiled-frame for SB!EVAL:INTERNAL-APPLY-LOOP.
(real-frame nil :type compiled-frame)
;; This is the closed over data used by the interpreter.
;;; code-locations and other objects that reference DEBUG-FUNCTIONs
;;; point to unique objects. This is due to the overhead in cached
;;; information.
-(defstruct debug-function
+(defstruct (debug-function (:copier nil))
;; Some representation of the function arguments. See
;; DEBUG-FUNCTION-LAMBDA-LIST.
;; NOTE: must parse vars before parsing arg list stuff.
(defstruct (compiled-debug-function
(:include debug-function)
(:constructor %make-compiled-debug-function
- (compiler-debug-fun component)))
+ (compiler-debug-fun component))
+ (:copier nil))
;; Compiler's dumped debug-function information. (unexported).
(compiler-debug-fun nil :type sb!c::compiled-debug-function)
;; Code object. (unexported).
(defstruct (interpreted-debug-function
(:include debug-function)
- (:constructor %make-interpreted-debug-function (ir1-lambda)))
+ (:constructor %make-interpreted-debug-function (ir1-lambda))
+ (:copier nil))
;; This is the IR1 lambda that this debug-function represents.
(ir1-lambda nil :type sb!c::clambda))
(:include debug-function)
(:constructor make-bogus-debug-function
(%name &aux (%lambda-list nil) (%debug-vars nil)
- (blocks nil) (%function nil))))
+ (blocks nil) (%function nil)))
+ (:copier nil))
%name)
(defvar *ir1-lambda-debug-function* (make-hash-table :test 'eq))
;;;; DEBUG-BLOCKs
;;; These exist for caching data stored in packed binary form in compiler
-;;; debug-blocks.
-(defstruct (debug-block (:constructor nil))
+;;; DEBUG-BLOCKs.
+(defstruct (debug-block (:constructor nil)
+ (:copier nil))
;; Code-locations where execution continues after this block.
(successors nil :type list)
;; This indicates whether the block is a special glob of code shared by
(defstruct (compiled-debug-block (:include debug-block)
(:constructor
make-compiled-debug-block
- (code-locations successors elsewhere-p)))
- ;; Code-location information for the block.
+ (code-locations successors elsewhere-p))
+ (:copier nil))
+ ;; code-location information for the block
(code-locations nil :type simple-vector))
(defstruct (interpreted-debug-block (:include debug-block
(elsewhere-p nil))
(:constructor %make-interpreted-debug-block
- (ir1-block)))
+ (ir1-block))
+ (:copier nil))
;; This is the IR1 block this debug-block represents.
(ir1-block nil :type sb!c::cblock)
;; Code-location information for the block.
;;; This is an internal structure that manages information about a
;;; breakpoint locations. See *COMPONENT-BREAKPOINT-OFFSETS*.
(defstruct (breakpoint-data (:constructor make-breakpoint-data
- (component offset)))
+ (component offset))
+ (:copier nil))
;; This is the component in which the breakpoint lies.
component
;; This is the byte offset into the component.
(breakpoint-data-offset obj))))
(defstruct (breakpoint (:constructor %make-breakpoint
- (hook-function what kind %info)))
+ (hook-function what kind %info))
+ (:copier nil))
;; This is the function invoked when execution encounters the
;; breakpoint. It takes a frame, the breakpoint, and optionally a
;; list of values. Values are supplied for :FUNCTION-END breakpoints
;;;; CODE-LOCATIONs
-(defstruct (code-location (:constructor nil))
+(defstruct (code-location (:constructor nil)
+ (:copier nil))
;; This is the debug-function containing code-location.
(debug-function nil :type debug-function)
;; This is initially :UNSURE. Upon first trying to access an
(:constructor make-known-code-location
(pc debug-function %tlf-offset %form-number
%live-set kind &aux (%unknown-p nil)))
- (:constructor make-compiled-code-location (pc debug-function)))
+ (:constructor make-compiled-code-location (pc debug-function))
+ (:copier nil))
;; This is an index into debug-function's component slot.
(pc nil :type sb!c::index)
;; This is a bit-vector indexed by a variable's position in
(:include code-location
(%unknown-p nil))
(:constructor make-interpreted-code-location
- (ir1-node debug-function)))
+ (ir1-node debug-function))
+ (:copier nil))
;; This is an index into debug-function's component slot.
(ir1-node nil :type sb!c::node))
(defstruct (function-end-cookie
(:print-object (lambda (obj str)
(print-unreadable-object (obj str :type t))))
- (:constructor make-function-end-cookie (bogus-lra debug-fun)))
- ;; This is a pointer to the bogus-lra created for :function-end bpts.
+ (:constructor make-function-end-cookie (bogus-lra debug-fun))
+ (:copier nil))
+ ;; a pointer to the bogus-lra created for :FUNCTION-END breakpoints
bogus-lra
- ;; This is the debug-function associated with the cookie.
+ ;; the debug-function associated with the cookie
debug-fun)
;;; This maps bogus-lra-components to cookies, so that
;;;; the BREAKPOINT-INFO structure
;;; info about a made breakpoint
-(defstruct breakpoint-info
+(defstruct (breakpoint-info (:copier nil))
;; where we are going to stop
(place (required-argument)
:type (or sb!di:code-location sb!di:debug-function))
(:print-object (lambda (x s)
(print-unreadable-object (x s :type t)
(write-string (unprintable-object-string x)
- s)))))
+ s))))
+ (:copier nil))
string)
;;; Print FRAME with verbosity level 1. If we hit a &REST arg, then
(deftype count-vector () '(simple-array double-float (2)))
(defstruct (vop-stats
(:constructor %make-vop-stats (name))
- (:constructor make-vop-stats-key))
+ (:constructor make-vop-stats-key)
+ (:copier nil))
(name (required-argument) :type simple-string)
(data (make-array 2 :element-type 'double-float) :type count-vector))
(res restart))))
(res))))
-(defstruct restart
+(defstruct (restart (:copier nil))
name
function
report-function
(or (built-in-class-translation spec) spec)
spec))
(t
- (let* ((lspec (if (atom spec) (list spec) spec))
+ (let* (;; FIXME: This
+ (lspec (if (atom spec) (list spec) spec))
(fun (info :type :translator (car lspec))))
(cond (fun (funcall fun lspec))
((or (and (consp spec) (symbolp (car spec)))
(defstruct (hairy-type (:include ctype
(class-info (type-class-or-lose 'hairy))
(enumerable t))
+ (:copier nil)
#!+cmu (:pure nil))
;; the Common Lisp type-specifier
(specifier nil :type t))
;;; An UNKNOWN-TYPE is a type not known to the type system (not yet
;;; defined). We make this distinction since we don't want to complain
;;; about types that are hairy but defined.
-(defstruct (unknown-type (:include hairy-type)))
+(defstruct (unknown-type (:include hairy-type)
+ (:copier nil)))
;;; ARGS-TYPE objects are used both to represent VALUES types and
;;; to represent FUNCTION types.
(defstruct (args-type (:include ctype)
- (:constructor nil))
+ (:constructor nil)
+ (:copier nil))
;; Lists of the type for each required and optional argument.
(required nil :type list)
(optional nil :type list)
(defstruct (values-type
(:include args-type
- (class-info (type-class-or-lose 'values)))))
+ (class-info (type-class-or-lose 'values)))
+ (:copier nil)))
(!define-type-class values)
;;; represents something that the compiler knows to be a constant.)
(defstruct (constant-type
(:include ctype
- (class-info (type-class-or-lose 'constant))))
+ (class-info (type-class-or-lose 'constant)))
+ (:copier nil))
;; The type which the argument must be a constant instance of for this type
;; specifier to win.
(type (required-argument) :type ctype))
;;; The NAMED-TYPE is used to represent *, T and NIL. These types must be
-;;; super or sub types of all types, not just classes and * & NIL aren't
+;;; super- or sub-types of all types, not just classes and * and NIL aren't
;;; classes anyway, so it wouldn't make much sense to make them built-in
;;; classes.
(defstruct (named-type (:include ctype
- (class-info (type-class-or-lose 'named))))
+ (class-info (type-class-or-lose 'named)))
+ (:copier nil))
(name nil :type symbol))
-;;; The Numeric-Type is used to represent all numeric types, including things
+;;; A NUMERIC-TYPE represents any numeric type, including things
;;; such as FIXNUM.
(defstruct (numeric-type (:include ctype
(class-info (type-class-or-lose
;;; The Array-Type is used to represent all array types, including
;;; things such as SIMPLE-STRING.
(defstruct (array-type (:include ctype
- (class-info (type-class-or-lose 'array))))
+ (class-info (type-class-or-lose 'array)))
+ (:copier nil))
;; the dimensions of the array, or * if unspecified. If a dimension
;; is unspecified, it is *.
(dimensions '* :type (or list (member *)))
(defstruct (member-type (:include ctype
(class-info (type-class-or-lose 'member))
(enumerable t))
+ (:copier nil)
#-sb-xc-host (:pure nil))
;; the things in the set, with no duplications
(members nil :type list))
;;; A COMPOUND-TYPE is a type defined out of a set of types,
;;; the common parent of UNION-TYPE and INTERSECTION-TYPE.
(defstruct (compound-type (:include ctype)
- (:constructor nil))
+ (:constructor nil)
+ (:copier nil))
(types nil :type list :read-only t))
;;; A UNION-TYPE represents a use of the OR type specifier which can't
;;; 2. There are never any UNION-TYPE components.
(defstruct (union-type (:include compound-type
(class-info (type-class-or-lose 'union)))
- (:constructor %make-union-type (enumerable types))))
+ (:constructor %make-union-type (enumerable types))
+ (:copier nil)))
;;; An INTERSECTION-TYPE represents a use of the AND type specifier
;;; which can't be canonicalized to something simpler. Canonical form:
(class-info (type-class-or-lose
'intersection)))
(:constructor %make-intersection-type
- (enumerable types))))
+ (enumerable types))
+ (:copier nil)))
;;; Return TYPE converted to canonical form for a situation where the
;;; "type" '* (which SBCL still represents as a type even though ANSI
cdr-raw-type
&aux
(car-type (type-*-to-t car-raw-type))
- (cdr-type (type-*-to-t cdr-raw-type)))))
+ (cdr-type (type-*-to-t cdr-raw-type))))
+ (:copier nil))
;; the CAR and CDR element types (to support ANSI (CONS FOO BAR) types)
;;
;; FIXME: Most or all other type structure slots could also be :READ-ONLY.
(defstruct (fd-stream
(:constructor %make-fd-stream)
(:include lisp-stream
- (misc #'fd-stream-misc-routine)))
+ (misc #'fd-stream-misc-routine))
+ (:copier nil))
;; the name of this stream
(name nil)
;;;; definition encapsulation
(defstruct (encapsulation-info (:constructor make-encapsulation-info
- (type definition)))
+ (type definition))
+ (:copier nil))
;; This is definition's encapsulation type. The encapsulated
;; definition is in the previous encapsulation-info element or
;; installed as the global definition of some function name.
(eval-when (:compile-toplevel :execute :load-toplevel)
-(defstruct alien-type-class
+(defstruct (alien-type-class (:copier nil))
(name nil :type symbol)
(include nil :type (or null alien-type-class))
(unparse nil :type (or null function))
(:constructor
,(symbolicate "MAKE-" defstruct-name)
(&key class bits alignment
- ,@(mapcar #'(lambda (x)
- (if (atom x) x (car x)))
+ ,@(mapcar (lambda (x)
+ (if (atom x) x (car x)))
slots)
,@include-args)))
,@slots)))))
;; defaulted after creation
(assigned-slots () :type list))
-(defstruct condition-slot
+(defstruct (condition-slot (:copier nil))
(name (required-argument) :type symbol)
;; list of all applicable initargs
(initargs (required-argument) :type list)
;;;; also be annotated with function or values types.
;;; the description of a keyword argument
-(defstruct (key-info #-sb-xc-host (:pure t))
+(defstruct (key-info #-sb-xc-host (:pure t)
+ (:copier nil))
;; the keyword
(name (required-argument) :type keyword)
;; the type of the argument value
(!def-type-translator not (&whole whole type)
(declare (ignore type))
+ ;; Check legality of arguments.
+ (destructuring-bind (not typespec) whole
+ (declare (ignore not))
+ (specifier-type typespec)) ; must be legal typespec
+ ;; Create object.
(make-hairy-type :specifier whole))
(!def-type-translator satisfies (&whole whole fun)
(declare (ignore fun))
+ ;; Check legality of arguments of arguments.
+ (destructuring-bind (satisfies predicate-name) whole
+ (declare (ignore satisfies))
+ (unless (symbolp predicate-name)
+ (error 'simple-type-error
+ :datum predicate-name
+ :expected-type symbol
+ :format-control "~S is not a symbol."
+ :format-arguments (list predicate-name))))
(make-hairy-type :specifier whole))
\f
;;;; numeric types
(deftype in-buffer-type ()
`(simple-array (unsigned-byte 8) (,in-buffer-length)))
-(defstruct (lisp-stream (:constructor nil))
+(defstruct (lisp-stream (:constructor nil)
+ (:copier nil))
;; Buffered input.
(in-buffer nil :type (or in-buffer-type null))
(in-index in-buffer-length :type index) ; index into IN-BUFFER
(t (error 'simple-type-error
:datum name
:expected-type '(or string symbol)
- :format-control "Module name must be a string or symbol -- ~S."
+ :format-control "Module name must be a string or symbol: ~S"
:format-arguments (list name)))))
(:out #'pretty-out)
(:sout #'pretty-sout)
(:misc #'pretty-misc))
- (:constructor make-pretty-stream (target)))
+ (:constructor make-pretty-stream (target))
+ (:copier nil))
;; Where the output is going to finally go.
(target (required-argument) :type stream)
;; Line length we should format to. Cached here so we don't have to keep
\f
;;;; logical blocks
-(defstruct logical-block
+(defstruct (logical-block (:copier nil))
;; The column this logical block started in.
(start-column 0 :type column)
;; The column the current section started in.
\f
;;;; the pending operation queue
-(defstruct (queued-op (:constructor nil))
+(defstruct (queued-op (:constructor nil)
+ (:copier nil))
(posn 0 :type posn))
(defmacro enqueue (stream type &rest args)
,entry))))
(defstruct (section-start (:include queued-op)
- (:constructor nil))
+ (:constructor nil)
+ (:copier nil))
(depth 0 :type index)
(section-end nil :type (or null newline block-end)))
-(defstruct (newline
- (:include section-start))
+(defstruct (newline (:include section-start)
+ (:copier nil))
(kind (required-argument)
:type (member :linear :fill :miser :literal :mandatory)))
(setf (section-start-section-end entry) newline))))
(maybe-output stream (or (eq kind :literal) (eq kind :mandatory))))
-(defstruct (indentation
- (:include queued-op))
+(defstruct (indentation (:include queued-op)
+ (:copier nil))
(kind (required-argument) :type (member :block :current))
(amount 0 :type fixnum))
(defun enqueue-indent (stream kind amount)
(enqueue stream indentation :kind kind :amount amount))
-(defstruct (block-start
- (:include section-start))
+(defstruct (block-start (:include section-start)
+ (:copier nil))
(block-end nil :type (or null block-end))
(prefix nil :type (or null simple-string))
(suffix nil :type (or null simple-string)))
(setf (pretty-stream-pending-blocks stream)
(cons start pending-blocks))))
-(defstruct (block-end
- (:include queued-op))
+(defstruct (block-end (:include queued-op)
+ (:copier nil))
(suffix nil :type (or null simple-string)))
(defun end-logical-block (stream)
(pretty-sout stream suffix 0 (length suffix)))
(setf (block-start-block-end start) end)))
-(defstruct (tab
- (:include queued-op))
+(defstruct (tab (:include queued-op)
+ (:copier nil))
(sectionp nil :type (member t nil))
(relativep nil :type (member t nil))
(colnum 0 :type column)
(defvar *initial-pprint-dispatch*)
(defvar *building-initial-table* nil)
-(defstruct pprint-dispatch-entry
+(defstruct (pprint-dispatch-entry (:copier nil))
;; The type specifier for this entry.
(type (required-argument) :type t)
;; A function to test to see whether an object is of this time. Pretty must
(pprint-dispatch-entry-priority entry)
(pprint-dispatch-entry-initial-p entry))))
-(defstruct pprint-dispatch-table
+(defstruct (pprint-dispatch-table (:copier nil))
;; A list of all the entries (except for CONS entries below) in highest
;; to lowest priority.
(entries nil :type list)
;;; FIXME: It might make sense to replace this with something
;;; with finer resolution, e.g. milliseconds or microseconds.
+;;; For that matter, maybe we should boost the internal clock
+;;; up to something faster, like milliseconds.
(defconstant +ticks-per-second+ internal-time-units-per-second)
\f
;;;; PCOUNTER
-;;; a PCOUNTER is used to represent an integer quantity which can grow
-;;; bigger than a fixnum, but typically does so, if at all, in many
-;;; small steps, where we don't want to cons on every step. (Total
-;;; system consing, time spent in a profiled function, and bytes
-;;; consed in a profiled function are all examples of such
+;;; a PCOUNTER is used to represent an unsigned integer quantity which
+;;; can grow bigger than a fixnum, but typically does so, if at all,
+;;; in many small steps, where we don't want to cons on every step.
+;;; (Total system consing, time spent in a profiled function, and
+;;; bytes consed in a profiled function are all examples of such
;;; quantities.)
(defstruct (pcounter (:copier nil))
- (integer 0 :type integer)
- (fixnum 0 :type fixnum))
+ (integer 0 :type unsigned-byte)
+ (fixnum 0 :type (and fixnum unsigned-byte)))
(declaim (ftype (function (pcounter integer) pcounter) incf-pcounter))
-(declaim (inline incf-pcounter))
+;;;(declaim (inline incf-pcounter)) ; FIXME: maybe inline when more stable
(defun incf-pcounter (pcounter delta)
(let ((sum (+ (pcounter-fixnum pcounter) delta)))
(cond ((typep sum 'fixnum)
pcounter)
(declaim (ftype (function (pcounter) integer) pcounter->integer))
-(declaim (inline pcounter->integer))
+;;;(declaim (inline pcounter->integer)) ; FIXME: maybe inline when more stable
(defun pcounter->integer (pcounter)
(+ (pcounter-integer pcounter)
(pcounter-fixnum pcounter)))
;;;; FIXNUM overflows.
(declaim (ftype (function ((or pcounter fixnum) integer) (or pcounter fixnum)) %incf-pcounter-or-fixnum))
-(declaim (inline %incf-pcounter-or-fixnum))
+;;;(declaim (inline %incf-pcounter-or-fixnum)) ; FIXME: maybe inline when more stable
(defun %incf-pcounter-or-fixnum (x delta)
(etypecase x
(fixnum
;;; name. This holds the functions that we call to manipulate the
;;; closure which implements the encapsulation.
(defvar *profiled-function-name->info* (make-hash-table))
-(defstruct profile-info
+(defstruct (profile-info (:copier nil))
(name (required-argument) :read-only t)
(encapsulated-fun (required-argument) :type function :read-only t)
(encapsulation-fun (required-argument) :type function :read-only t)
(declaim (type (or pcounter fixnum) *enclosed-profiles*))
;;; the components of profiling overhead
-(defstruct overhead
+(defstruct (overhead (:copier nil))
;; the number of ticks a bare function call takes. This is
;; factored into the other overheads, but not used for itself.
(call (required-argument) :type single-float :read-only t)
\f
;;;; reporting results
-(defstruct time-info
+(defstruct (time-info (:copier nil))
name
calls
seconds
'(simple-array (unsigned-byte 8) (#.char-code-limit)))
(sb!xc:defstruct (readtable (:conc-name nil)
- (:predicate readtablep)
- (:copier nil))
+ (:predicate readtablep))
#!+sb-doc
"Readtable is a data structure that maps characters into syntax
types for the Common Lisp expression reader."
(defvar *active-processes* nil
"List of process structures for all active processes.")
-(defstruct (process)
+(defstruct (process (:copier nil))
pid ; PID of child process
%status ; either :RUNNING, :STOPPED, :EXITED, or :SIGNALED
exit-code ; either exit code or signal
:datum type
:expected-type '(or vector cons)
:format-control
- "NIL output type invalid for this sequence function."
+ "A NIL output type is invalid for this sequence function."
:format-arguments ())))
((dolist (seq-type '(list string simple-vector bit-vector))
(when (csubtypep type (specifier-type seq-type))
(default-handler #'default-default-handler)))
(:print-object
(lambda (s stream)
- (format stream "#<Object Set ~S>" (object-set-name s)))))
+ (format stream "#<Object Set ~S>" (object-set-name s))))
+ (:copier nil))
name ; Name, for descriptive purposes.
(table (make-hash-table :test 'eq)) ; Message-ID or
; xevent-type --> handler fun.
;;;; file descriptor I/O noise
(defstruct (handler
- (:constructor make-handler (direction descriptor function)))
+ (:constructor make-handler (direction descriptor function))
+ (:copier nil))
;; Reading or writing...
(direction nil :type (member :input :output))
;; File descriptor this handler is tied to.
;;;; utilities for dealing with signal names and numbers
(defstruct (unix-signal
- (:constructor make-unix-signal (%name %number %description)))
+ (:constructor make-unix-signal (%name %number %description))
+ (:copier nil))
%name ; signal keyword
(%number nil :type integer) ; UNIX signal number
(%description nil :type string)) ; documentation
(:constructor #!-high-security-support
make-broadcast-stream
#!+high-security-support
- %make-broadcast-stream (&rest streams)))
+ %make-broadcast-stream (&rest
+ streams))
+ (:copier nil))
;; a list of all the streams we broadcast to
(streams () :type list :read-only t))
(bout #'synonym-bout)
(sout #'synonym-sout)
(misc #'synonym-misc))
- (:constructor make-synonym-stream (symbol)))
+ (:constructor make-synonym-stream (symbol))
+ (:copier nil))
;; This is the symbol, the value of which is the stream we are synonym to.
(symbol nil :type symbol :read-only t))
(def!method print-object ((x synonym-stream) stream)
(:constructor #!-high-security-support
make-two-way-stream
#!+high-security-support
- %make-two-way-stream (input-stream output-stream)))
+ %make-two-way-stream (input-stream output-stream))
+ (:copier nil))
(input-stream (required-argument) :type stream :read-only t)
(output-stream (required-argument) :type stream :read-only t))
(def!method print-object ((x two-way-stream) stream)
(:constructor
#!-high-security-support make-concatenated-stream
#!+high-security-support %make-concatenated-stream
- (&rest streams &aux (current streams))))
+ (&rest streams &aux (current streams)))
+ (:copier nil))
;; The car of this is the stream we are reading from now.
current
;; This is a list of all the streams. We need to remember them so that
(bin #'echo-bin)
(misc #'echo-misc)
(n-bin #'ill-bin))
- (:constructor make-echo-stream (input-stream output-stream)))
+ (:constructor make-echo-stream (input-stream output-stream))
+ (:copier nil))
unread-stuff)
(def!method print-object ((x echo-stream) stream)
(print-unreadable-object (x stream :type t :identity t)
(n-bin #'string-stream-read-n-bytes)
(misc #'string-in-misc))
(:constructor internal-make-string-input-stream
- (string current end)))
+ (string current end))
+ (:copier nil))
(string nil :type simple-string)
(current nil :type index)
(end nil :type index))
(out #'string-ouch)
(sout #'string-sout)
(misc #'string-out-misc))
- (:constructor make-string-output-stream ()))
+ (:constructor make-string-output-stream ())
+ (:copier nil))
;; The string we throw stuff in.
(string (make-string 40) :type simple-string)
;; Index of the next location to use.
(return count))))
(:element-type 'base-char)))
+;;; Return a string of all the characters sent to a stream made by
+;;; MAKE-STRING-OUTPUT-STREAM since the last call to this function.
(defun get-output-stream-string (stream)
- #!+sb-doc
- "Returns a string of all the characters sent to a stream made by
- Make-String-Output-Stream since the last call to this function."
(declare (type string-output-stream stream))
(let* ((length (string-output-stream-index stream))
(result (make-string length)))
(setf (string-output-stream-index stream) 0)
result))
+;;; Dump the characters buffer up in IN-STREAM to OUT-STREAM as
+;;; GET-OUTPUT-STREAM-STRING would return them.
(defun dump-output-stream-string (in-stream out-stream)
- #!+sb-doc
- "Dumps the characters buffer up in the In-Stream to the Out-Stream as
- Get-Output-Stream-String would return them."
(write-string* (string-output-stream-string in-stream) out-stream
0 (string-output-stream-index in-stream))
(setf (string-output-stream-index in-stream) 0))
\f
;;;; fill-pointer streams
-;;; Fill pointer string output streams are not explicitly mentioned in the CLM,
-;;; but they are required for the implementation of With-Output-To-String.
+;;; Fill pointer STRING-OUTPUT-STREAMs are not explicitly mentioned in
+;;; the CLM, but they are required for the implementation of
+;;; WITH-OUTPUT-TO-STRING.
(defstruct (fill-pointer-output-stream
(:include lisp-stream
(out #'fill-pointer-ouch)
(sout #'fill-pointer-sout)
(misc #'fill-pointer-misc))
- (:constructor make-fill-pointer-output-stream (string)))
- ;; The string we throw stuff in.
+ (:constructor make-fill-pointer-output-stream (string))
+ (:copier nil))
+ ;; the string we throw stuff in
string)
(defun fill-pointer-ouch (stream character)
(out #'indenting-out)
(sout #'indenting-sout)
(misc #'indenting-misc))
- (:constructor make-indenting-stream (stream)))
+ (:constructor make-indenting-stream (stream))
+ (:copier nil))
;; the stream we're based on
stream
;; how much we indent on each line
(defstruct (case-frob-stream
(:include lisp-stream
(:misc #'case-frob-misc))
- (:constructor %make-case-frob-stream (target out sout)))
+ (:constructor %make-case-frob-stream (target out sout))
+ (:copier nil))
(target (required-argument) :type stream))
(defun make-case-frob-stream (target kind)
;;;; public interface from "EXTENSIONS" package
(defstruct (stream-command (:constructor make-stream-command
- (name &optional args)))
+ (name &optional args))
+ (:copier nil))
(name nil :type symbol)
(args nil :type list))
(def!method print-object ((obj stream-command) str)
(error 'simple-type-error :datum ,var
:expected-type ',type
:format-control
- "Argument ~A is not a ~S: ~S."
+ "~@<Argument ~A is not a ~S: ~2I~_~S~:>"
:format-arguments
(list ',var ',type ,var))))))
(declare (fixnum count)))))
(defun random (arg &optional (state *random-state*))
- #!+sb-doc
- "Generate a uniformly distributed pseudo-random number between zero
- and Arg. State, if supplied, is the random state to use."
(declare (inline %random-single-float %random-double-float
#!+long-float %long-float))
(cond
- ((and (fixnump arg) (<= arg random-fixnum-max) #!+high-security (> arg 0))
+ ((and (fixnump arg) (<= arg random-fixnum-max) (> arg 0))
(rem (random-chunk state) arg))
- ((and (typep arg 'single-float) #!+high-security (> arg 0.0S0))
+ ((and (typep arg 'single-float) (> arg 0.0S0))
(%random-single-float arg state))
- ((and (typep arg 'double-float) #!+high-security (> arg 0.0D0))
+ ((and (typep arg 'double-float) (> arg 0.0D0))
(%random-double-float arg state))
#!+long-float
- ((and (typep arg 'long-float) #!+high-security (> arg 0.0L0))
+ ((and (typep arg 'long-float) (> arg 0.0L0))
(%random-long-float arg state))
- ((and (integerp arg) #!+high-security (> arg 0))
+ ((and (integerp arg) (> arg 0))
(%random-integer arg state))
(t
(error 'simple-type-error
:expected-type '(or (integer 1) (float (0))) :datum arg
- :format-control "Argument is not a positive integer or a positive float: ~S"
+ :format-control "~@<Argument is neither a positive integer nor a ~
+ positive float: ~2I~_~S~:>"
:format-arguments (list arg)))))
;; package!)
(multiple-value-bind (whole wholeless-arglist)
(if (eq '&whole (car arglist))
- (values (cadr arglist) (cddr arglist))
- (values (gensym) arglist))
+ (values (cadr arglist) (cddr arglist))
+ (values (gensym) arglist))
(multiple-value-bind (forms decls) (parse-body body nil)
`(progn
(!cold-init-forms
;;; DEFVARs for these come later, after we have enough stuff defined.
(declaim (special *wild-type* *universal-type* *empty-type*))
\f
-;;; The XXX-Type structures include the CTYPE structure for some slots that
-;;; apply to all types.
+;;; the base class for the internal representation of types
(def!struct (ctype (:conc-name type-)
(:constructor nil)
(:make-load-form-fun make-type-load-form)
(hairy-type
;; Now the tricky stuff.
(let* ((hairy-spec (hairy-type-specifier type))
- (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
+ (symbol (car hairy-spec)))
(ecase symbol
(and
- (or (atom hairy-spec)
- (dolist (spec (cdr hairy-spec) t)
- (unless (%%typep object (specifier-type spec))
- (return nil)))))
+ (every (lambda (spec) (%%typep object (specifier-type spec)))
+ (rest hairy-spec)))
+ ;; Note: it should be safe to skip OR here, because union
+ ;; types can always be represented as UNION-TYPE in general
+ ;; or other CTYPEs in special cases; we never need to use
+ ;; HAIRY-TYPE for them.
(not
(unless (proper-list-of-length-p hairy-spec 2)
(error "invalid type specifier: ~S" hairy-spec))
(satisfies
(unless (proper-list-of-length-p hairy-spec 2)
(error "invalid type specifier: ~S" hairy-spec))
- (let ((fn (cadr hairy-spec)))
- (if (funcall (typecase fn
- (function fn)
- (symbol (symbol-function fn))
- (t
- (coerce fn 'function)))
- object)
- t
- nil))))))
+ (values (funcall (symbol-function (cadr hairy-spec)) object))))))
(alien-type-type
(sb!alien-internals:alien-typep object (alien-type-type-alien-type type)))
(function-type
;;;; we don't need to do horrible things like hand-copying the
;;;; direntry struct slot types into an alien struct.
-;;; FIXME: DIRECTORY is an external symbol of package CL, so we should use some
-;;; other name for this low-level implementation type.
-(defstruct directory
+;;; FIXME: DIRECTORY is an external symbol of package CL, so we should
+;;; use some other name for this low-level implementation type.
+(defstruct (directory (:copier nil))
name
(dir-struct (required-argument) :type system-area-pointer))
(/show0 "unix.lisp 304")
;;;; the SEGMENT structure
;;; This structure holds the state of the assembler.
-(defstruct segment
+(defstruct (segment (:copier nil))
;; the name of this segment (for debugging output and stuff)
(name "Unnamed" :type simple-base-string)
;; Ordinarily this is a vector where instructions are written. If
(defstruct (instruction
(:include sset-element)
(:conc-name inst-)
- (:constructor make-instruction (number emitter attributes delay)))
+ (:constructor make-instruction (number emitter attributes delay))
+ (:copier nil))
;; The function to envoke to actually emit this instruction. Gets called
;; with the segment as its one argument.
(emitter (required-argument) :type (or null function))
;;;; structure used during output emission
;;; common supertype for all the different kinds of annotations
-(defstruct (annotation (:constructor nil))
+(defstruct (annotation (:constructor nil)
+ (:copier nil))
;; Where in the raw output stream was this annotation emitted.
(index 0 :type index)
;; What position does that correspond to.
(posn nil :type (or index null)))
(defstruct (label (:include annotation)
- (:constructor gen-label ()))
+ (:constructor gen-label ())
+ (:copier nil))
;; (doesn't need any additional information beyond what is in the
;; annotation structure)
)
(:include annotation)
(:conc-name alignment-)
(:predicate alignment-p)
- (:constructor make-alignment (bits size fill-byte)))
+ (:constructor make-alignment (bits size fill-byte))
+ (:copier nil))
;; The minimum number of low-order bits that must be zero.
(bits 0 :type alignment)
;; The amount of filler we are assuming this alignment op will take.
;;; we actually know what label positions, etc. are
(defstruct (back-patch
(:include annotation)
- (:constructor make-back-patch (size function)))
+ (:constructor make-back-patch (size function))
+ (:copier nil))
;; The area effected by this back-patch.
(size 0 :type index)
;; The function to use to generate the real data
(defstruct (chooser
(:include annotation)
(:constructor make-chooser
- (size alignment maybe-shrink worst-case-fun)))
- ;; the worst case size for this chooser. There is this much space allocated
- ;; in the output buffer.
+ (size alignment maybe-shrink worst-case-fun))
+ (:copier nil))
+ ;; the worst case size for this chooser. There is this much space
+ ;; allocated in the output buffer.
(size 0 :type index)
;; the worst case alignment this chooser is guaranteed to preserve
(alignment 0 :type alignment)
- ;; the function to call to determine of we can use a shorter sequence. It
- ;; returns NIL if nothing shorter can be used, or emits that sequence and
- ;; returns T.
+ ;; the function to call to determine of we can use a shorter
+ ;; sequence. It returns NIL if nothing shorter can be used, or emits
+ ;; that sequence and returns T.
(maybe-shrink nil :type function)
- ;; the function to call to generate the worst case sequence. This is used
- ;; when nothing else can be condensed.
+ ;; the function to call to generate the worst case sequence. This is
+ ;; used when nothing else can be condensed.
(worst-case-fun nil :type function))
-;;; This is used internally when we figure out a chooser or alignment doesn't
-;;; really need as much space as we initially gave it.
+;;; This is used internally when we figure out a chooser or alignment
+;;; doesn't really need as much space as we initially gave it.
(defstruct (filler
(:include annotation)
- (:constructor make-filler (bytes)))
+ (:constructor make-filler (bytes))
+ (:copier nil))
;; the number of bytes of filler here
(bytes 0 :type index))
\f
;;;; output functions
-;;; interface: Emit the supplied BYTE to SEGMENT, growing SEGMENT if necessary.
+;;; interface: Emit the supplied BYTE to SEGMENT, growing SEGMENT if
+;;; necessary.
(defun emit-byte (segment byte)
(declare (type segment segment))
;; We could use DECLARE instead of CHECK-TYPE here, but (1) CMU CL's
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *vm-support-routines* ',routines))
- (defstruct vm-support-routines
+ (defstruct (vm-support-routines (:copier nil))
,@(mapcar #'(lambda (routine)
`(,routine nil :type (or function null)))
routines))
;;; number of bits devoted to coding byte-inline functions.
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defstruct inline-function-info
+ (defstruct (inline-function-info (:copier nil))
;; the name of the function that we convert into calls to this
(function (required-argument) :type symbol)
;; the name of the function that the interpreter should call to
\f
;;;; annotations hung off the IR1 while compiling
-(defstruct byte-component-info
+(defstruct (byte-component-info (:copier nil))
(constants (make-array 10 :adjustable t :fill-pointer 0)))
-(defstruct byte-lambda-info
+(defstruct (byte-lambda-info (:copier nil))
(label nil :type (or null label))
(stack-size 0 :type index)
;; FIXME: should be INTERESTING-P T :TYPE BOOLEAN
(defun block-interesting (block)
(byte-lambda-info-interesting (lambda-info (block-home-lambda block))))
-(defstruct byte-lambda-var-info
+(defstruct (byte-lambda-var-info (:copier nil))
(argp nil :type (member t nil))
(offset 0 :type index))
-(defstruct byte-nlx-info
+(defstruct (byte-nlx-info (:copier nil))
(stack-slot nil :type (or null index))
(label (sb!assem:gen-label) :type sb!assem:label)
(duplicate nil :type (member t nil)))
(defstruct (byte-block-info
+ (:copier nil)
(:include block-annotation)
(:constructor make-byte-block-info
(block &key produces produces-sset consumes
(defstruct (byte-continuation-info
(:include sset-element)
(:constructor make-byte-continuation-info
- (continuation results placeholders)))
+ (continuation results placeholders))
+ (:copier nil))
(continuation (required-argument) :type continuation)
(results (required-argument)
:type (or (member :fdefinition :eq-test :unknown) index))
(defstruct (constraint
(:include sset-element)
- (:constructor make-constraint (number kind x y not-p)))
- ;; The kind of constraint we have:
+ (:constructor make-constraint (number kind x y not-p))
+ (:copier nil))
+ ;; the kind of constraint we have:
;;
;; TYPEP
;; X is a LAMBDA-VAR and Y is a CTYPE. The value of X is
;; constrained to be of type Y.
;;
- ;; >, <
+ ;; > or <
;; X is a lambda-var and Y is a CTYPE. The relation holds
;; between X and some object of type Y.
;;
(values))
-;;; Do copy propagation on Component by initializing the flow analysis sets,
-;;; doing flow analysis, and then propagating copies using the results.
+;;; Do copy propagation on COMPONENT by initializing the flow analysis
+;;; sets, doing flow analysis, and then propagating copies using the
+;;; results.
(defun copy-propagate (component)
(setf (block-out (component-head component)) (make-sset))
(do-blocks (block component)
;;;; proclamation, we can check the actual type for compatibity with the
;;;; previous uses.
-(defstruct (approximate-function-type)
+(defstruct (approximate-function-type (:copier nil))
;; The smallest and largest numbers of arguments that this function has been
;; called with.
(min-args call-arguments-limit :type fixnum)
;; describing each argument position in which the keyword appeared.
(keys () :type list))
-(defstruct (approximate-key-info)
+(defstruct (approximate-key-info (:copier nil))
;; The keyword name of this argument. Although keyword names don't have to
;; be keywords, we only match on keywords when figuring an approximate type.
(name (required-argument) :type keyword)
;;; The LOCATION-INFO structure holds the information what we need
;;; about locations which code generation decided were "interesting".
(defstruct (location-info
- (:constructor make-location-info (kind label vop)))
+ (:constructor make-location-info (kind label vop))
+ (:copier nil))
;; The kind of location noted.
(kind nil :type location-kind)
;; The label pointing to the interesting code location.
\f
;;;; cached functions
-(defstruct function-cache
+(defstruct (function-cache (:copier nil))
(printers nil :type list)
(labellers nil :type list)
(prefilters nil :type list))
length
mask id
printer
- labeller prefilter control)))
+ labeller prefilter control))
+ (:copier nil))
(name nil :type (or symbol string))
(format-name nil :type (or symbol string))
;;;; an instruction space holds all known machine instructions in a form that
;;;; can be easily searched
-(defstruct (inst-space (:conc-name ispace-))
+(defstruct (inst-space (:conc-name ispace-)
+ (:copier nil))
(valid-mask dchunk-zero :type dchunk) ; applies to *children*
(choices nil :type list))
(def!method print-object ((ispace inst-space) stream)
(print-unreadable-object (ispace stream :type t :identity t)))
-(defstruct (inst-space-choice (:conc-name ischoice-))
+(defstruct (inst-space-choice (:conc-name ischoice-)
+ (:copier nil))
(common-id dchunk-zero :type dchunk) ; applies to *parent's* mask
(subspace (required-argument) :type (or inst-space instruction)))
\f
;;;; These are the kind of values we can compute for an argument, and
-;;;; how to compute them. The :checker functions make sure that a given
+;;;; how to compute them. The :CHECKER functions make sure that a given
;;;; argument is compatible with another argument for a given use.
(defvar *arg-form-kinds* nil)
-(defstruct arg-form-kind
+(defstruct (arg-form-kind (:copier nil))
(names nil :type list)
(producer (required-argument) :type function)
(checker (required-argument) :type function))
(prefilter nil)
(use-label nil))
-(defstruct (instruction-format (:conc-name format-))
+(defstruct (instruction-format (:conc-name format-)
+ (:copier nil))
(name nil)
(args nil :type list)
\f
;;; A FUNSTATE holds the state of any arguments used in a disassembly
;;; function.
-(defstruct (funstate (:conc-name funstate-) (:constructor %make-funstate))
+(defstruct (funstate (:conc-name funstate-)
+ (:constructor %make-funstate)
+ (:copier nil))
(args nil :type list)
(arg-temps nil :type list)) ; See below.
;;;; (notably functions), we sometimes use a VALSRC structure to keep track of
;;;; the source from which they were derived.
-(defstruct (valsrc (:constructor %make-valsrc))
+(defstruct (valsrc (:constructor %make-valsrc)
+ (:copier nil))
(value nil)
(source nil))
(valsrc-value thing)
thing))
\f
-(defstruct (cached-function (:conc-name cached-fun-))
+(defstruct (cached-function (:conc-name cached-fun-)
+ (:copier nil))
(funstate nil :type (or null funstate))
(constraint nil :type list)
(name nil :type (or null symbol)))
#-no-ansi-print-object
(:print-object (lambda (x s)
(print-unreadable-object (x s :type t)
- (prin1 (namestring (fasl-file-stream x)) s)))))
+ (prin1 (namestring (fasl-file-stream x)) s))))
+ (:copier nil))
;; the stream we dump to
(stream (required-argument) :type stream)
;; hashtables we use to keep track of dumped constants so that we
(valid-structures (make-hash-table :test 'eq) :type hash-table))
;;; This structure holds information about a circularity.
-(defstruct circularity
+(defstruct (circularity (:copier nil))
;; the kind of modification to make to create circularity
(type (required-argument) :type (member :rplaca :rplacd :svset :struct-set))
;; the object containing circularity
;;;; annotating IR1 for interpretation
(defstruct (lambda-eval-info (:constructor make-lambda-eval-info
- (frame-size args-passed entries)))
+ (frame-size args-passed entries))
+ (:copier nil))
frame-size ; number of stack locations needed to hold locals
args-passed ; number of referenced arguments passed to lambda
entries ; a-list mapping entry nodes to stack locations
(print-unreadable-object (obj str :type t)))
(defstruct (entry-node-info (:constructor make-entry-node-info
- (st-top nlx-tag)))
+ (st-top nlx-tag))
+ (:copier nil))
st-top ; stack top when we encounter the entry node
nlx-tag) ; tag to which to throw to get back entry node's context
(def!method print-object ((obj entry-node-info) str)
(in-package "SB!C")
-;;; FIXUP -- A fixup of some kind.
+;;; a fixup of some kind
(defstruct (fixup
- (:constructor make-fixup (name flavor &optional offset)))
- ;; The name and flavor of the fixup. The assembler makes no assumptions
- ;; about the contents of these fields; their semantics are imposed by the
- ;; dumper.
+ (:constructor make-fixup (name flavor &optional offset))
+ (:copier nil))
+ ;; the name and flavor of the fixup. The assembler makes no
+ ;; assumptions about the contents of these fields; their semantics
+ ;; are imposed by the dumper.
name
flavor
- ;; OFFSET is an optional offset from whatever external label this fixup
- ;; refers to. Or in the case of the :CODE-OBJECT flavor of fixups on the :X86
- ;; architecture, NAME is always NIL, so this fixup doesn't refer to an
- ;; external label, and OFFSET is an offset from the beginning of the
- ;; current code block.
+ ;; OFFSET is an optional offset from whatever external label this
+ ;; fixup refers to. Or in the case of the :CODE-OBJECT flavor of
+ ;; fixups on the :X86 architecture, NAME is always NIL, so this
+ ;; fixup doesn't refer to an external label, and OFFSET is an offset
+ ;; from the beginning of the current code block.
offset)
-;;; were done with another flavor
-
-(def!method print-object ((fixup fixup) stream)
- (print-unreadable-object (fixup stream :type t)
- (format stream
- ":FLAVOR ~S :NAME ~S :OFFSET ~S"
- (fixup-flavor fixup)
- (fixup-name fixup)
- (fixup-offset fixup))))
-
;;; KLUDGE: Despite its name, this is not a list of FIXUP objects, but rather a
;;; list of `(,KIND ,FIXUP ,POSN). Perhaps this non-mnemonicity could be
;;; reduced by naming what's currently a FIXUP structure a FIXUP-REQUEST, and
;;; FIXNUMness) might be different between host and target. Perhaps
;;; this property should be protected by #-SB-XC-HOST? Perhaps we need
;;; 3-stage bootstrapping after all? (Ugh! It's *so* slow already!)
-(defknown typep (t type-specifier) boolean
+(defknown typep (t type-specifier) t
(flushable
;; Unlike SUBTYPEP or UPGRADED-ARRAY-ELEMENT-TYPE and friends, this
;; seems to be FOLDABLE. Like SUBTYPEP, it's affected by type
(:constructor make-core-object ())
#-no-ansi-print-object
(:print-object (lambda (x s)
- (print-unreadable-object (x s :type t)))))
+ (print-unreadable-object (x s :type t))))
+ (:copier nil))
;; A hashtable translating ENTRY-INFO structures to the corresponding actual
;; FUNCTIONs for functions in this compilation.
(entry-table (make-hash-table :test 'eq) :type hash-table)
;;; a GENESIS-time representation of a memory space (e.g. read-only space,
;;; dynamic space, or static space)
-(defstruct (gspace (:constructor %make-gspace))
+(defstruct (gspace (:constructor %make-gspace)
+ (:copier nil))
;; name and identifier for this GSPACE
(name (required-argument) :type symbol :read-only t)
(identifier (required-argument) :type fixnum :read-only t)
(defstruct (descriptor
(:constructor make-descriptor
- (high low &optional gspace word-offset)))
+ (high low &optional gspace word-offset))
+ (:copier nil))
;; the GSPACE that this descriptor is allocated in, or NIL if not set yet.
(gspace nil :type (or gspace null))
;; the offset in words from the start of GSPACE, or NIL if not set yet
#-no-ansi-print-object
(:print-object (lambda (x s)
(print-unreadable-object (x s :type t)
- (prin1 (class-info-name x))))))
+ (prin1 (class-info-name x)))))
+ (:copier nil))
;; name of this class
(name nil :type keyword :read-only t)
;; List of Type-Info structures for each type in this class.
"~S ~S, Number = ~D"
(class-info-name (type-info-class x))
(type-info-name x)
- (type-info-number x))))))
+ (type-info-number x)))))
+ (:copier nil))
;; the name of this type
(name (required-argument) :type keyword)
;; this type's class
;;; type, then the inline type check will win. If the inline check
;;; didn't win, we would try to use the type system before it was
;;; properly initialized.
-(defstruct (info-env (:constructor nil))
+(defstruct (info-env (:constructor nil)
+ (:copier nil))
;; some string describing what is in this environment, for
;; printing/debugging purposes only
(name (required-argument) :type string))
;;; indirect through a parallel vector to find the index in the
;;; ENTRIES at which the entries for a given name starts.
(defstruct (compact-info-env (:include info-env)
- #-sb-xc-host (:pure :substructure))
+ #-sb-xc-host (:pure :substructure)
+ (:copier nil))
;; If this value is EQ to the name we want to look up, then the
;; cache hit function can be called instead of the lookup function.
(cache-name 0)
\f
;;;; volatile environments
-;;; This is a closed hashtable, with the bucket being computed by taking the
-;;; GLOBALDB-SXHASHOID of the Name mod the table size.
-(defstruct (volatile-info-env (:include info-env))
- ;; If this value is EQ to the name we want to look up, then the cache hit
- ;; function can be called instead of the lookup function.
+;;; This is a closed hashtable, with the bucket being computed by
+;;; taking the GLOBALDB-SXHASHOID of the NAME modulo the table size.
+(defstruct (volatile-info-env (:include info-env)
+ (:copier nil))
+ ;; If this value is EQ to the name we want to look up, then the
+ ;; cache hit function can be called instead of the lookup function.
(cache-name 0)
- ;; The alist translating type numbers to values for the currently cached
- ;; name.
+ ;; the alist translating type numbers to values for the currently
+ ;; cached name
(cache-types nil :type list)
- ;; Vector of alists of alists of the form:
+ ;; vector of alists of alists of the form:
;; ((Name . ((Type-Number . Value) ...) ...)
(table (required-argument) :type simple-vector)
- ;; The number of distinct names currently in this table (each name may have
- ;; multiple entries, since there can be many types of info.
+ ;; the number of distinct names currently in this table. Each name
+ ;; may have multiple entries, since there can be many types of info.
(count 0 :type index)
- ;; The number of names at which we should grow the table and rehash.
+ ;; the number of names at which we should grow the table and rehash
(threshold 0 :type index))
;;; Just like COMPACT-INFO-CACHE-HIT, only do it on a volatile environment.
(defstruct (compiler-error-context
#-no-ansi-print-object
(:print-object (lambda (x stream)
- (print-unreadable-object (x stream :type t)))))
+ (print-unreadable-object (x stream :type t))))
+ (:copier nil))
;; A list of the stringified CARs of the enclosing non-original source forms
;; exceeding the *enclosing-source-cutoff*.
(enclosing-source nil :type list)
\f
;;;; interfaces to defining macros
-;;; The TRANSFORM structure represents an IR1 transform.
-(defstruct transform
+;;; an IR1 transform
+(defstruct (transform (:copier nil))
;; the function-type which enables this transform
(type (required-argument) :type ctype)
;; the transformation function. Takes the COMBINATION node and returns a
(eval-when (:compile-toplevel :load-toplevel :execute)
-(defstruct event-info
+(defstruct (event-info (:copier nil))
;; The name of this event.
(name (required-argument) :type symbol)
;; The string rescribing this event.
;;; A FILE-INFO structure holds all the source information for a
;;; given file.
-(defstruct file-info
+(defstruct (file-info (:copier nil))
;; If a file, the truename of the corresponding source file. If from
;; a Lisp form, :LISP. If from a stream, :STREAM.
(name (required-argument) :type (or pathname (member :lisp :stream)))
(defstruct (source-info
#-no-ansi-print-object
(:print-object (lambda (s stream)
- (print-unreadable-object (s stream :type t)))))
+ (print-unreadable-object (s stream :type t))))
+ (:copier nil))
;; the UT that compilation started at
(start-time (get-universal-time) :type unsigned-byte)
;; a list of the FILE-INFO structures for this compilation
(def!method print-object ((x continuation) stream)
(print-unreadable-object (x stream :type t :identity t)))
-(defstruct (node (:constructor nil))
+(defstruct (node (:constructor nil)
+ (:copier nil))
;; the bottom-up derived type for this node. This does not take into
;; consideration output type assertions on this node (actually on its CONT).
(derived-type *wild-type* :type ctype)
;;; The Block-Annotation structure is shared (via :INCLUDE) by
;;; different block-info annotation structures so that code
;;; (specifically control analysis) can be shared.
-(defstruct (block-annotation (:constructor nil))
+(defstruct (block-annotation (:constructor nil)
+ (:copier nil))
;; The IR1 block that this block is in the INFO for.
(block (required-argument) :type cblock)
;; the next and previous block in emission order (not DFO). This
;;; The Component structure provides a handle on a connected piece of
;;; the flow graph. Most of the passes in the compiler operate on
;;; components rather than on the entire flow graph.
-(defstruct component
+(defstruct (component (:copier nil))
;; The kind of component:
;;
;; NIL
name
(reanalyze :test reanalyze))
-;;; The Cleanup structure represents some dynamic binding action.
+;;; The CLEANUP structure represents some dynamic binding action.
;;; Blocks are annotated with the current cleanup so that dynamic
;;; bindings can be removed when control is transferred out of the
;;; binding environment. We arrange for changes in dynamic bindings to
;;; by requiring that the exit continuations initially head their
;;; blocks, and then by not merging blocks when there is a cleanup
;;; change.
-(defstruct cleanup
+(defstruct (cleanup (:copier nil))
;; The kind of thing that has to be cleaned up.
(kind (required-argument)
:type (member :special-bind :catch :unwind-protect :block :tagbody))
(nlx-info :test nlx-info))
;;; The ENVIRONMENT structure represents the result of environment analysis.
-(defstruct environment
+(defstruct (environment (:copier nil))
;; the function that allocates this environment
(function (required-argument) :type clambda)
;; a list of all the lambdas that allocate variables in this environment
;;; The tail set is somewhat approximate, because it is too early to
;;; be sure which calls will be TR. Any call that *might* end up TR
;;; causes tail-set merging.
-(defstruct tail-set
+(defstruct (tail-set (:copier nil))
;; a list of all the lambdas in this tail set
(functions nil :type list)
;; our current best guess of the type returned by these functions.
;;; initially (and forever) NIL, since REFs don't receive any values
;;; and don't have any IR1 optimizer.
(defstruct (ref (:include node (:reoptimize nil))
- (:constructor make-ref (derived-type leaf)))
+ (:constructor make-ref (derived-type leaf))
+ (:copier nil))
;; The leaf referenced.
(leaf nil :type leaf))
(defprinter (ref)
;;; function appears as the successor. The NODE-CONT remains the
;;; continuation which receives the value of the call.
(defstruct (basic-combination (:include node)
- (:constructor nil))
+ (:constructor nil)
+ (:copier nil))
;; continuation for the function
(fun (required-argument) :type continuation)
;; list of CONTINUATIONs for the args. In a local call, an argument
;;; including FUNCALL. This is distinct from BASIC-COMBINATION so that
;;; an MV-COMBINATION isn't COMBINATION-P.
(defstruct (combination (:include basic-combination)
- (:constructor make-combination (fun))))
+ (:constructor make-combination (fun))
+ (:copier nil)))
(defprinter (combination)
(fun :prin1 (continuation-use fun))
(args :prin1 (mapcar (lambda (x)
;;; FUNCALL. This is used to implement all the multiple-value
;;; receiving forms.
(defstruct (mv-combination (:include basic-combination)
- (:constructor make-mv-combination (fun))))
+ (:constructor make-mv-combination (fun))
+ (:copier nil)))
(defprinter (mv-combination)
(fun :prin1 (continuation-use fun))
(args :prin1 (mapcar #'continuation-use args)))
-;;; The Bind node marks the beginning of a lambda body and represents
+;;; The BIND node marks the beginning of a lambda body and represents
;;; the creation and initialization of the variables.
-(defstruct (bind (:include node))
+(defstruct (bind (:include node)
+ (:copier nil))
;; the lambda we are binding variables for. Null when we are
;; creating the LAMBDA during IR1 translation.
(lambda nil :type (or clambda null)))
(defprinter (bind)
lambda)
-;;; The Return node marks the end of a lambda body. It collects the
+;;; The RETURN node marks the end of a lambda body. It collects the
;;; return values and represents the control transfer on return. This
-;;; is also where we stick information used for Tail-Set type
+;;; is also where we stick information used for TAIL-SET type
;;; inference.
(defstruct (creturn (:include node)
(:conc-name return-)
;;; The ENTRY node serves to mark the start of the dynamic extent of a
;;; lexical exit. It is the mess-up node for the corresponding :Entry
;;; cleanup.
-(defstruct (entry (:include node))
+(defstruct (entry (:include node)
+ (:copier nil))
;; All of the Exit nodes for potential non-local exits to this point.
(exits nil :type list)
;; The cleanup for this entry. NULL only temporarily.
;;; the returned value being delivered directly to the exit
;;; continuation, it is delivered to our VALUE continuation. The
;;; original exit continuation is the exit node's CONT.
-(defstruct (exit (:include node))
+(defstruct (exit (:include node)
+ (:copier nil))
;; The Entry node that this is an exit for. If null, this is a
;; degenerate exit. A degenerate exit is used to "fill" an empty
;; block (which isn't allowed in IR1.) In a degenerate exit, Value
#-no-ansi-print-object
(:print-object (lambda (x s)
(print-unreadable-object (x s :type t)
- (prin1 (undefined-warning-name x) s)))))
- ;; The name of the unknown thing.
+ (prin1 (undefined-warning-name x) s))))
+ (:copier nil))
+ ;; the name of the unknown thing
(name nil :type (or symbol list))
- ;; The kind of reference to Name.
+ ;; the kind of reference to NAME
(kind (required-argument) :type (member :function :type :variable))
- ;; The number of times this thing was used.
+ ;; the number of times this thing was used
(count 0 :type unsigned-byte)
- ;; A list of COMPILER-ERROR-CONTEXT structures describing places
+ ;; a list of COMPILER-ERROR-CONTEXT structures describing places
;; where this thing was used. Note that we only record the first
;; *UNDEFINED-WARNING-LIMIT* calls.
(warnings () :type list))
;;; the arguments to IR1 transforms. It bundles together the name of
;;; the argument (which should be referenced in any expansion), and
;;; the continuation for that argument (or NIL if unsupplied.)
-(defstruct (arg (:constructor %make-arg (name cont)))
+(defstruct (arg (:constructor %make-arg (name cont))
+ (:copier nil))
(name nil :type symbol)
(cont nil :type (or continuation null)))
(defmacro make-arg (name)
(eql (continuation-value cont) x)))
(eql default x)))
-(defstruct iterator
+(defstruct (iterator (:copier nil))
;; The kind of iterator.
(kind nil (member :normal :result))
;; A list of LET* bindings to create the initial state.
;;; The basic interval type. It can handle open and closed intervals.
;;; A bound is open if it is a list containing a number, just like
;;; Lisp says. NIL means unbounded.
-(defstruct (interval
- (:constructor %make-interval))
+(defstruct (interval (:constructor %make-interval)
+ (:copier nil))
low high)
(defun make-interval (&key low high)
;;; SSet-Element structure. We allow an initial value of NIL to mean
;;; that no ordering has been assigned yet (although an ordering must
;;; be assigned before doing set operations.)
-(defstruct (sset-element (:constructor nil))
+(defstruct (sset-element (:constructor nil)
+ (:copier nil))
(number nil :type (or index null)))
-(defstruct (sset (:constructor make-sset ())
- (:copier nil))
+(defstruct (sset (:constructor make-sset ()))
(elements (list nil) :type list))
(defprinter (sset)
(elements :prin1 (cdr elements)))
(defconstant lra-size (words-to-bytes 1))
\f
-(defstruct offs-hook
+(defstruct (offs-hook (:copier nil))
(offset 0 :type offset)
(function (required-argument) :type function)
(before-address nil :type (member t nil)))
(defstruct (segment (:conc-name seg-)
- (:constructor %make-segment))
+ (:constructor %make-segment)
+ (:copier nil))
(sap-maker (required-argument)
:type (function () sb!sys:system-area-pointer))
(length 0 :type length)
;;; information so that we can allow garbage collect during disassembly and
;;; not get tripped up by a code block being moved...
(defstruct (disassem-state (:conc-name dstate-)
- (:constructor %make-dstate))
+ (:constructor %make-dstate)
+ (:copier nil))
(cur-offs 0 :type offset) ; offset of current pos in segment
(next-offs 0 :type offset) ; offset of next position
\f
;;; getting at the source code...
-(defstruct (source-form-cache (:conc-name sfcache-))
+(defstruct (source-form-cache (:conc-name sfcache-)
+ (:copier nil))
(debug-source nil :type (or null sb!di:debug-source))
(top-level-form-index -1 :type fixnum)
(top-level-form nil :type list)
(form-number-mapping-table nil :type (or null (vector list)))
(last-location-retrieved nil :type (or null sb!di:code-location))
- (last-form-retrieved -1 :type fixnum)
- )
+ (last-form-retrieved -1 :type fixnum))
(defun get-top-level-form (debug-source tlf-index)
(let ((name (sb!di:debug-source-name debug-source)))
(declare (type sb!kernel:code-component code))
(sb!di::get-debug-info-function-map (sb!kernel:%code-debug-info code)))
-(defstruct location-group
- (locations #() :type (vector (or list fixnum)))
- )
+(defstruct (location-group (:copier nil))
+ (locations #() :type (vector (or list fixnum))))
-(defstruct storage-info
+(defstruct (storage-info (:copier nil))
(groups nil :type list) ; alist of (name . location-group)
(debug-vars #() :type vector))
(defun source-transform-intersection-typep (object type)
;; FIXME: This is just a placeholder; we should define a better
;; version by analogy with SOURCE-TRANSFORM-UNION-TYPEP.
+ (declare (ignore object type))
nil)
;;; If necessary recurse to check the cons type.
\f
;;;; PRIMITIVE-TYPEs
-;;; The primitive type is used to represent the aspects of type
+;;; A PRIMITIVE-TYPE is used to represent the aspects of type
;;; interesting to the VM. Selection of IR2 translation templates is
;;; done on the basis of the primitive types of the operands, and the
;;; primitive type of a value is used to constrain the possible
;;; representations of that value.
-(defstruct primitive-type
+(defstruct (primitive-type (:copier nil))
;; the name of this PRIMITIVE-TYPE
(name nil :type symbol)
;; a list of the SC numbers for all the SCs that a TN of this type
;;; and after IR2 conversion. It is stored in the BLOCK-INFO slot for
;;; the associated block.
(defstruct (ir2-block (:include block-annotation)
- (:constructor make-ir2-block (block)))
+ (:constructor make-ir2-block (block))
+ (:copier nil))
;; the IR2-Block's number, which differs from Block's Block-Number
;; if any blocks are split. This is assigned by lifetime analysis.
(number nil :type (or index null))
(local-tn-count :test (not (zerop local-tn-count)))
(%label :test %label))
-;;; An IR2-Continuation structure is used to annotate continuations
+;;; An IR2-CONTINUATION structure is used to annotate continuations
;;; that are used as a function result continuation or that receive MVs.
(defstruct (ir2-continuation
- (:constructor make-ir2-continuation (primitive-type)))
+ (:constructor make-ir2-continuation (primitive-type))
+ (:copier nil))
;; If this is :DELAYED, then this is a single value continuation for
;; which the evaluation of the use is to be postponed until the
;; evaluation of destination. This can be done for ref nodes or
primitive-type
locs)
-;;; The IR2-Component serves mostly to accumulate non-code information
+;;; An IR2-COMPONENT serves mostly to accumulate non-code information
;;; about the component being compiled.
-(defstruct ir2-component
+(defstruct (ir2-component (:copier nil))
;; the counter used to allocate global TN numbers
(global-tn-counter 0 :type index)
;; NORMAL-TNS is the head of the list of all the normal TNs that
;;; structures are somtimes created before they are initialized, since
;;; IR2 conversion may need to compile a forward reference. In this
;;; case the slots aren't actually initialized until entry analysis runs.
-(defstruct entry-info
+(defstruct (entry-info (:copier nil))
;; true if this function has a non-null closure environment
(closure-p nil :type boolean)
;; a label pointing to the entry vector for this function, or NIL
;;; An IR2-ENVIRONMENT is used to annotate non-LET lambdas with their
;;; passing locations. It is stored in the Environment-Info.
-(defstruct ir2-environment
+(defstruct (ir2-environment (:copier nil))
;; the TNs that hold the passed environment within the function.
;; This is an alist translating from the NLX-Info or lambda-var to
;; the TN that holds the corresponding value within this function.
;;; A RETURN-INFO is used by GTN to represent the return strategy and
;;; locations for all the functions in a given TAIL-SET. It is stored
;;; in the TAIL-SET-INFO.
-(defstruct return-info
+(defstruct (return-info (:copier nil))
;; The return convention used:
;; -- If :UNKNOWN, we use the standard return convention.
;; -- If :FIXED, we use the known-values convention.
types
locations)
-(defstruct ir2-nlx-info
+(defstruct (ir2-nlx-info (:copier nil))
;; If the kind is :ENTRY (a lexical exit), then in the home
;; environment, this holds a VALUE-CELL object containing the unwind
;; block pointer. In the other cases nobody directly references the
home
save-sp
dynamic-state)
-
-;;; FIXME: Delete? (was commented out in CMU CL)
-#|
-;;; The Loop structure holds information about a loop.
-(defstruct (cloop (:conc-name loop-)
- (:predicate loop-p)
- (:constructor make-loop)
- (:copier copy-loop))
- ;; The kind of loop that this is. These values are legal:
- ;;
- ;; :Outer
- ;; This is the outermost loop structure, and represents all the
- ;; code in a component.
- ;;
- ;; :Natural
- ;; A normal loop with only one entry.
- ;;
- ;; :Strange
- ;; A segment of a "strange loop" in a non-reducible flow graph.
- (kind (required-argument) :type (member :outer :natural :strange))
- ;; The first and last blocks in the loop. There may be more than one tail,
- ;; since there may be multiple back branches to the same head.
- (head nil :type (or cblock null))
- (tail nil :type list)
- ;; A list of all the blocks in this loop or its inferiors that have a
- ;; successor outside of the loop.
- (exits nil :type list)
- ;; The loop that this loop is nested within. This is null in the outermost
- ;; loop structure.
- (superior nil :type (or cloop null))
- ;; A list of the loops nested directly within this one.
- (inferiors nil :type list)
- ;; The head of the list of blocks directly within this loop. We must recurse
- ;; on Inferiors to find all the blocks.
- (blocks nil :type (or null cblock)))
-(defprinter (loop)
- kind
- head
- tail
- exits)
-|#
\f
;;;; VOPs and templates
;;; A VOP is a Virtual Operation. It represents an operation and the
;;; operands to the operation.
-(defstruct (vop (:constructor make-vop (block node info args results)))
+(defstruct (vop (:constructor make-vop (block node info args results))
+ (:copier nil))
;; VOP-Info structure containing static info about the operation.
(info nil :type (or vop-info null))
;; The IR2-Block this VOP is in.
;;; A TN-REF object contains information about a particular reference
;;; to a TN. The information in TN-REFs largely determines how TNs are
;;; packed.
-(defstruct (tn-ref (:constructor make-tn-ref (tn write-p)))
+(defstruct (tn-ref (:constructor make-tn-ref (tn write-p))
+ (:copier nil))
;; the TN referenced
(tn (required-argument) :type tn)
;; Is this is a write reference? (as opposed to a read reference)
;;; the SC structure holds the storage base that storage is allocated
;;; in and information used to select locations within the SB.
-(defstruct sc
+(defstruct (sc (:copier nil))
;; Name, for printing and reference.
(name nil :type symbol)
;; The number used to index SC cost vectors.
(defstruct (tn (:include sset-element)
(:constructor make-random-tn)
- (:constructor make-tn (number kind primitive-type sc)))
+ (:constructor make-tn (number kind primitive-type sc))
+ (:copier nil))
;; The kind of TN this is:
;;
;; :NORMAL
;;; lifetime analysis to represent the set of TNs live at the start of
;;; the IR2 block.
(defstruct (global-conflicts
- (:constructor make-global-conflicts (kind tn block number)))
+ (:constructor make-global-conflicts (kind tn block number))
+ (:copier nil))
;; The IR2-Block that this structure represents the conflicts for.
(block (required-argument) :type ir2-block)
;; Thread running through all the Global-Conflict for Block. This
(in-package "SB!VM")
-;; The move-argument vop is going to store args on the stack for
+;; The MOVE-ARGUMENT vop is going to store args on the stack for
;; call-out. These tn's will be used for that. move-arg is normally
;; used for things going down the stack but C wants to have args
;; indexed in the positive direction.
(sc-number-or-lose sc-name)
offset))
-(defstruct arg-state
+(defstruct (arg-state (:copier nil))
(stack-frame-size 0))
(def-alien-type-method (integer :arg-tn) (type state)
(setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
(my-make-wired-tn 'single-float 'single-stack stack-frame-size)))
-(defstruct result-state
+(defstruct (result-state (:copier nil))
(num-results 0))
(defun result-reg-offset (slot)
(logior (ash (logand offset 1) 2)
(ash offset -1))))
-(defstruct (ea (:constructor make-ea (size &key base index scale disp)))
+(defstruct (ea (:constructor make-ea (size &key base index scale disp))
+ (:copier nil))
(size nil :type (member :byte :word :dword))
(base nil :type (or tn null))
(index nil :type (or tn null))
`(not (null .next-method.))))
,@body))
-(defstruct method-call
+(defstruct (method-call (:copier nil))
(function #'identity :type function)
call-method-args)
`(list ,@required-args+rest-arg))
(method-call-call-method-args ,method-call)))
-(defstruct fast-method-call
+(defstruct (fast-method-call (:copier nil))
(function #'identity :type function)
pv-cell
next-method-call
(fast-method-call-next-method-call ,method-call)
,@required-args+rest-arg))
-(defstruct fast-instance-boundp
+(defstruct (fast-instance-boundp (:copier nil))
(index 0 :type fixnum))
#-sb-fluid (declaim (sb-ext:freeze-type fast-instance-boundp))
(defstruct (arg-info
(:conc-name nil)
- (:constructor make-arg-info ()))
+ (:constructor make-arg-info ())
+ (:copier nil))
(arg-info-lambda-list :no-lambda-list)
arg-info-precedence
arg-info-metatypes
(make-class-predicate-name name)))
(set-slot 'defstruct-form
`(defstruct (structure-object (:constructor
- ,constructor-sym))))
+ ,constructor-sym)
+ (:copier nil))))
(set-slot 'defstruct-constructor constructor-sym)
(set-slot 'from-defclass-p t)
(set-slot 'plist nil)
;; default here. -- WHN 19991204
(invalid nil))
(:conc-name %wrapper-)
- (:constructor make-wrapper-internal))
+ (:constructor make-wrapper-internal)
+ (:copier nil))
(instance-slots-layout nil :type list)
(class-slots nil :type list))
#-sb-fluid (declaim (sb-ext:freeze-type wrapper))
(compute-std-cpl root (class-direct-superclasses root)))
(defstruct (class-precedence-description
- (:conc-name nil)
- (:print-object (lambda (obj str)
- (print-unreadable-object (obj str :type t)
- (format str "~D" (cpd-count obj)))))
- (:constructor make-cpd ()))
+ (:conc-name nil)
+ (:print-object (lambda (obj str)
+ (print-unreadable-object (obj str :type t)
+ (format str "~D" (cpd-count obj)))))
+ (:constructor make-cpd ())
+ (:copier nil))
(cpd-class nil)
(cpd-supers ())
(cpd-after ())
(:metaclass structure-class))
(defstruct (dead-beef-structure-object
- (:constructor |STRUCTURE-OBJECT class constructor|)))
+ (:constructor |STRUCTURE-OBJECT class constructor|)
+ (:copier nil)))
(defclass std-object (slot-object) ()
(:metaclass std-class))
;;; slot index. A cache vector stores the wrappers and corresponding
;;; slot indexes. Because each cache line is more than one element
;;; long, a cache lock count is used.
-(defstruct (dfun-info (:constructor nil))
+(defstruct (dfun-info (:constructor nil)
+ (:copier nil))
(cache nil))
-(defstruct (no-methods
- (:constructor no-methods-dfun-info ())
- (:include dfun-info)))
+(defstruct (no-methods (:constructor no-methods-dfun-info ())
+ (:include dfun-info)
+ (:copier nil)))
-(defstruct (initial
- (:constructor initial-dfun-info ())
- (:include dfun-info)))
+(defstruct (initial (:constructor initial-dfun-info ())
+ (:include dfun-info)
+ (:copier nil)))
-(defstruct (initial-dispatch
- (:constructor initial-dispatch-dfun-info ())
- (:include dfun-info)))
+(defstruct (initial-dispatch (:constructor initial-dispatch-dfun-info ())
+ (:include dfun-info)
+ (:copier nil)))
-(defstruct (dispatch
- (:constructor dispatch-dfun-info ())
- (:include dfun-info)))
+(defstruct (dispatch (:constructor dispatch-dfun-info ())
+ (:include dfun-info)
+ (:copier nil)))
-(defstruct (default-method-only
- (:constructor default-method-only-dfun-info ())
- (:include dfun-info)))
+(defstruct (default-method-only (:constructor default-method-only-dfun-info ())
+ (:include dfun-info)
+ (:copier nil)))
;without caching:
; dispatch one-class two-class default-method-only
;accessor:
; one-class two-class one-index n-n
-(defstruct (accessor-dfun-info
- (:constructor nil)
- (:include dfun-info))
+(defstruct (accessor-dfun-info (:constructor nil)
+ (:include dfun-info)
+ (:copier nil))
accessor-type) ; (member reader writer)
(defmacro dfun-info-accessor-type (di)
`(accessor-dfun-info-accessor-type ,di))
-(defstruct (one-index-dfun-info
- (:constructor nil)
- (:include accessor-dfun-info))
+(defstruct (one-index-dfun-info (:constructor nil)
+ (:include accessor-dfun-info)
+ (:copier nil))
index)
(defmacro dfun-info-index (di)
`(one-index-dfun-info-index ,di))
-(defstruct (n-n
- (:constructor n-n-dfun-info (accessor-type cache))
- (:include accessor-dfun-info)))
+(defstruct (n-n (:constructor n-n-dfun-info (accessor-type cache))
+ (:include accessor-dfun-info)
+ (:copier nil)))
-(defstruct (one-class
- (:constructor one-class-dfun-info (accessor-type index wrapper0))
- (:include one-index-dfun-info))
+(defstruct (one-class (:constructor one-class-dfun-info
+ (accessor-type index wrapper0))
+ (:include one-index-dfun-info)
+ (:copier nil))
wrapper0)
(defmacro dfun-info-wrapper0 (di)
`(one-class-wrapper0 ,di))
-(defstruct (two-class
- (:constructor two-class-dfun-info (accessor-type index wrapper0 wrapper1))
- (:include one-class))
+(defstruct (two-class (:constructor two-class-dfun-info
+ (accessor-type index wrapper0 wrapper1))
+ (:include one-class)
+ (:copier nil))
wrapper1)
(defmacro dfun-info-wrapper1 (di)
`(two-class-wrapper1 ,di))
-(defstruct (one-index
- (:constructor one-index-dfun-info
- (accessor-type index cache))
- (:include one-index-dfun-info)))
+(defstruct (one-index (:constructor one-index-dfun-info
+ (accessor-type index cache))
+ (:include one-index-dfun-info)
+ (:copier nil)))
-(defstruct (checking
- (:constructor checking-dfun-info (function cache))
- (:include dfun-info))
+(defstruct (checking (:constructor checking-dfun-info (function cache))
+ (:include dfun-info)
+ (:copier nil))
function)
(defmacro dfun-info-function (di)
`(checking-function ,di))
-(defstruct (caching
- (:constructor caching-dfun-info (cache))
- (:include dfun-info)))
+(defstruct (caching (:constructor caching-dfun-info (cache))
+ (:include dfun-info)
+ (:copier nil)))
-(defstruct (constant-value
- (:constructor constant-value-dfun-info (cache))
- (:include dfun-info)))
+(defstruct (constant-value (:constructor constant-value-dfun-info (cache))
+ (:include dfun-info)
+ (:copier nil)))
(defmacro dfun-update (generic-function function &rest args)
`(multiple-value-bind (dfun cache info)
'initialize-info name)))
*initialize-info-cached-slots*)))
`(progn
- (defstruct initialize-info
+ (defstruct (initialize-info (:copier nil))
key wrapper
,@(mapcar #'(lambda (name)
`(,name :unknown))
(:print-function print-std-instance)
(:predicate nil)
(:conc-name ,conc-name)
- (:constructor ,constructor ()))
- ,@(mapcar #'(lambda (slot)
- `(,(slot-definition-name slot)
- +slot-unbound+))
+ (:constructor ,constructor ())
+ (:copier nil))
+ ,@(mapcar (lambda (slot)
+ `(,(slot-definition-name slot)
+ +slot-unbound+))
direct-slots)))
(reader-names (mapcar (lambda (slotd)
(intern (format nil
(defun pv-cache-limit-fn (nlines)
(default-limit-fn nlines))
-(defstruct (pv-table
- (:predicate pv-tablep)
- (:constructor make-pv-table-internal
- (slot-name-lists call-list)))
+(defstruct (pv-table (:predicate pv-tablep)
+ (:constructor make-pv-table-internal
+ (slot-name-lists call-list))
+ (:copier nil))
(cache nil :type (or cache null))
(pv-size 0 :type fixnum)
(slot-name-lists nil :type list)
(assert-nil-nil (subtypep '(vector utype-1) '(vector t)))
(assert-nil-nil (subtypep '(vector t) '(vector utype-2)))
+;;; ANSI specifically disallows bare AND and OR symbols as type specs.
+#| ; Alas, this is part of bug 10, still unfixed as of sbcl-0.6.11.10.
+(assert (raises-error? (typep 11 'and)))
+(assert (raises-error? (typep 11 'or)))
+|#
+;;; Of course empty lists of subtypes are still OK.
+(assert (typep 11 '(and)))
+(assert (not (typep 11 '(or))))
+
;;; success
(quit :unix-status 104)
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.11.9"
+"0.6.11.10"
projects / sbcl.git / commitdiff