30 |
(in-package 'system) |
(in-package 'system) |
31 |
|
|
32 |
|
|
33 |
(proclaim '(optimize (safety 2) (space 3))) |
;(proclaim '(optimize (safety 2) (space 3))) |
34 |
|
|
35 |
|
|
36 |
|
|
43 |
(defvar *vector-accessors* (make-array 2 :adjustable t)) |
(defvar *vector-accessors* (make-array 2 :adjustable t)) |
44 |
|
|
45 |
(or (fboundp 'record-fn) (setf (symbol-function 'record-fn) |
(or (fboundp 'record-fn) (setf (symbol-function 'record-fn) |
46 |
#'(lambda (&rest l) l nil))) |
(lambda (&rest l) l nil))) |
47 |
|
|
48 |
(defun make-access-function (name conc-name no-conc type named include no-fun |
(defun make-access-function (name conc-name no-conc type named include no-fun |
49 |
;; from apply |
;; from apply |
75 |
(or (aref accsrs offset) |
(or (aref accsrs offset) |
76 |
(setf (aref accsrs offset) |
(setf (aref accsrs offset) |
77 |
(cond ((eq accsrs *accessors*) |
(cond ((eq accsrs *accessors*) |
78 |
#'(lambda (x) |
(lambda (x) |
79 |
(or (structurep x) |
(declare (optimize (safety 1))) |
80 |
(error "~a is not a structure" x)) |
(or (structurep x) |
81 |
|
(error "~a is not a structure" x)) |
82 |
(structure-ref1 x offset))) |
(structure-ref1 x offset))) |
83 |
((eq accsrs *list-accessors*) |
((eq accsrs *list-accessors*) |
84 |
#'(lambda(x) |
(lambda(x) |
85 |
|
(declare (optimize (safety 1))) |
86 |
(si:list-nth offset x))) |
(si:list-nth offset x))) |
87 |
((eq accsrs *vector-accessors*) |
((eq accsrs *vector-accessors*) |
88 |
#'(lambda(x) |
(lambda(x) |
89 |
(aref x offset))))))))) |
(declare (optimize (safety 1))) |
90 |
|
(aref x offset))))))))) |
91 |
(cond (read-only |
(cond (read-only |
92 |
(remprop access-function 'structure-access) |
(remprop access-function 'structure-access) |
93 |
(setf (get access-function 'struct-read-only) t)) |
(setf (get access-function 'struct-read-only) t)) |
125 |
(defmacro maybe-add-keydef (key keydefs prior-keyword) |
(defmacro maybe-add-keydef (key keydefs prior-keyword) |
126 |
`(let ((def (cadar |
`(let ((def (cadar |
127 |
(member (key-name ,key ,prior-keyword) ,keydefs |
(member (key-name ,key ,prior-keyword) ,keydefs |
128 |
:key #'(lambda (k) (when (consp k) (car k))))))) |
:key (lambda (k) |
129 |
|
(declare (optimize (safety 1))) |
130 |
|
(when (consp k) (car k))))))) |
131 |
(if def |
(if def |
132 |
(cond ((not (consp ,key)) |
(cond ((not (consp ,key)) |
133 |
(list ,key def)) |
(list ,key def)) |
192 |
(declare (ignore named)) |
(declare (ignore named)) |
193 |
(let ((slot-names |
(let ((slot-names |
194 |
;; Collect the slot-names. |
;; Collect the slot-names. |
195 |
(mapcar #'(lambda (x) |
(mapcar (lambda (x) |
196 |
(cond ((null x) |
(cond ((null x) |
197 |
;; If the slot-description is NIL, |
;; If the slot-description is NIL, |
198 |
;; it is in the padding of initial-offset. |
;; it is in the padding of initial-offset. |
206 |
slot-descriptions)) |
slot-descriptions)) |
207 |
(keys |
(keys |
208 |
;; Make the keyword parameters. |
;; Make the keyword parameters. |
209 |
(mapcan #'(lambda (x) |
(mapcan (lambda (x) |
210 |
(cond ((null x) nil) |
(cond ((null x) nil) |
211 |
((null (car x)) nil) |
((null (car x)) nil) |
212 |
((null (cadr x)) (list (maybe-cons-keyname x))) |
((null (cadr x)) (list (maybe-cons-keyname x))) |
325 |
(cons (car olds) |
(cons (car olds) |
326 |
(overwrite-slot-descriptions news (cdr olds)))))))) |
(overwrite-slot-descriptions news (cdr olds)))))))) |
327 |
|
|
328 |
(defvar *all-t-s-type* (make-array 50 :element-type 'unsigned-char :static t)) |
(defconstant +aet-type-object+ (aet-type nil)) |
329 |
(defvar *alignment-t* (alignment t)) |
(defconstant +all-t-s-type+ |
330 |
|
(make-array 50 :element-type 'unsigned-char :static t :initial-element +aet-type-object+)) |
331 |
|
(defconstant +alignment-t+ (alignment t)) |
332 |
|
|
333 |
(defun make-t-type (n include slot-descriptions &aux i) |
(defun make-t-type (n include slot-descriptions &aux i) |
334 |
(let ((res (make-array n :element-type 'unsigned-char :static t))) |
(let ((res (make-array n :element-type 'unsigned-char :static t))) |
341 |
(dolist (v slot-descriptions) |
(dolist (v slot-descriptions) |
342 |
(setq i (nth 4 v)) |
(setq i (nth 4 v)) |
343 |
(let ((type (third v))) |
(let ((type (third v))) |
344 |
(cond ((<= (the fixnum (alignment type)) *alignment-t*) |
(cond ((<= (the fixnum (alignment type)) +alignment-t+) |
345 |
(setf (aref res i) (aet-type type)))))) |
(setf (aref res i) (aet-type type)))))) |
346 |
(cond ((< n (length *all-t-s-type*)) |
(cond ((< n (length +all-t-s-type+)) |
347 |
(dotimes (i n) |
(let ((def +aet-type-object+)) |
348 |
(cond ((not (eql (the fixnum (aref res i)) 0)) |
(dotimes (i n) |
349 |
(return-from make-t-type res)))) |
(cond ((not (= (the fixnum (aref res i)) def)) |
350 |
*all-t-s-type*) |
(return-from make-t-type res))))) |
351 |
|
+all-t-s-type+) |
352 |
(t res)))) |
(t res)))) |
353 |
|
|
354 |
(defvar *standard-slot-positions* |
(defvar *standard-slot-positions* |
359 |
(setf (aref ar i)(* (size-of t) i))) |
(setf (aref ar i)(* (size-of t) i))) |
360 |
ar)) |
ar)) |
361 |
|
|
362 |
(eval-when (compile ) |
;(eval-when (compile ) |
363 |
(proclaim '(function round-up (fixnum fixnum ) fixnum)) |
;(proclaim '(function round-up (fixnum fixnum ) fixnum)) |
364 |
) |
;) |
365 |
|
|
366 |
(defun round-up (a b) |
(defun round-up (a b) |
367 |
(declare (fixnum a b)) |
(declare (fixnum a b)) |
402 |
(v slot-descriptions) |
(v slot-descriptions) |
403 |
(setq type (caddr v)) |
(setq type (caddr v)) |
404 |
(setq align (alignment type)) |
(setq align (alignment type)) |
405 |
(unless (<= align *alignment-t*) |
(unless (<= align +alignment-t+) |
406 |
(setq type t) |
(setq type t) |
407 |
(setf (caddr v) t) |
(setf (caddr v) t) |
408 |
(setq align *alignment-t*) |
(setq align +alignment-t+) |
409 |
(setq v (nconc v '(t)))) |
(setq v (nconc v '(t)))) |
410 |
(setq next-pos (round-up pos align)) |
(setq next-pos (round-up pos align)) |
411 |
(or (eql pos next-pos) (setq has-holes t)) |
(or (eql pos next-pos) (setq has-holes t)) |
440 |
;bootstrapping code! |
;bootstrapping code! |
441 |
(setq def (make-s-data-structure |
(setq def (make-s-data-structure |
442 |
(make-array (* leng (size-of t)) |
(make-array (* leng (size-of t)) |
443 |
:element-type 'string-char :static t) |
:element-type 'unsigned-char :static t :initial-element +aet-type-object+) |
444 |
(make-t-type leng nil slot-descriptions) |
(make-t-type leng nil slot-descriptions) |
445 |
*standard-slot-positions* |
*standard-slot-positions* |
446 |
slot-descriptions |
slot-descriptions |
503 |
(record-fn predicate 'defun '(t) t) |
(record-fn predicate 'defun '(t) t) |
504 |
(or no-funs |
(or no-funs |
505 |
(setf (symbol-function predicate) |
(setf (symbol-function predicate) |
506 |
#'(lambda (x) |
(lambda (x) |
507 |
(si::structure-subtype-p x name)))) |
(declare (optimize (safety 1))) |
508 |
|
(si::structure-subtype-p x name)))) |
509 |
(setf (get predicate 'compiler::co1) |
(setf (get predicate 'compiler::co1) |
510 |
'compiler::co1structure-predicate) |
'compiler::co1structure-predicate) |
511 |
(setf (get predicate 'struct-predicate) name) |
(setf (get predicate 'struct-predicate) name) |
514 |
|
|
515 |
|
|
516 |
(defmacro defstruct (name &rest slots) |
(defmacro defstruct (name &rest slots) |
517 |
|
(declare (optimize (safety 1))) |
518 |
(let ((slot-descriptions slots) |
(let ((slot-descriptions slots) |
519 |
options |
options |
520 |
conc-name |
conc-name |
605 |
(when (and print-function print-object) |
(when (and print-function print-object) |
606 |
(error "Cannot specify both :print-function and :print-object.")) |
(error "Cannot specify both :print-function and :print-object.")) |
607 |
(when print-object |
(when print-object |
608 |
(setq print-function (lambda (x y z) (declare (ignore z)) (funcall print-object x y)))) |
(setq print-function (lambda (x y z) |
609 |
|
(declare (optimize (safety 1))) |
610 |
|
(declare (ignore z)) (funcall print-object x y)))) |
611 |
|
|
612 |
(and include (not print-function) |
(and include (not print-function) |
613 |
(setq print-function (s-data-print-function (get (car include) 's-data)))) |
(setq print-function (s-data-print-function (get (car include) 's-data)))) |
668 |
(t |
(t |
669 |
(setq slot-descriptions |
(setq slot-descriptions |
670 |
(append (overwrite-slot-descriptions |
(append (overwrite-slot-descriptions |
671 |
(mapcar #'(lambda (sd) |
(mapcar (lambda (sd) |
672 |
(parse-slot-description sd 0)) |
(parse-slot-description sd 0)) |
673 |
(cdr include)) |
(cdr include)) |
674 |
(s-data-slot-descriptions |
(s-data-slot-descriptions |
725 |
',offset ',predicate ',documentation |
',offset ',predicate ',documentation |
726 |
) |
) |
727 |
|
|
728 |
,@(mapcar #'(lambda (constructor) |
,@(mapcar (lambda (constructor) |
729 |
(make-constructor name constructor type named new-slot-descriptions)) |
(make-constructor name constructor type named new-slot-descriptions)) |
730 |
constructors) |
constructors) |
731 |
,@(if (and type predicate) |
,@(if (and type predicate) |